1;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- 2;;;; 3;;;; Copyright 2003-2006, 2008-2011, 2014, 2020 Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library 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 GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19(define-module (test-srfi-1) 20 #:use-module (test-suite lib) 21 #:use-module (ice-9 copy-tree) 22 #:use-module (srfi srfi-1)) 23 24 25(define (ref-delete x lst . proc) 26 "Reference implemenation of srfi-1 `delete'." 27 (set! proc (if (null? proc) equal? (car proc))) 28 (do ((ret '()) 29 (lst lst (cdr lst))) 30 ((null? lst) 31 (reverse! ret)) 32 (if (not (proc x (car lst))) 33 (set! ret (cons (car lst) ret))))) 34 35(define (ref-delete-duplicates lst . proc) 36 "Reference implemenation of srfi-1 `delete-duplicates'." 37 (set! proc (if (null? proc) equal? (car proc))) 38 (if (null? lst) 39 '() 40 (do ((keep '())) 41 ((null? lst) 42 (reverse! keep)) 43 (let ((elem (car lst))) 44 (set! keep (cons elem keep)) 45 (set! lst (ref-delete elem lst proc)))))) 46 47 48;; 49;; alist-copy 50;; 51 52(with-test-prefix "alist-copy" 53 54 ;; return a list which is the pairs making up alist A, the spine and cells 55 (define (alist-pairs a) 56 (let more ((a a) 57 (result a)) 58 (if (pair? a) 59 (more (cdr a) (cons a result)) 60 result))) 61 62 ;; return a list of the elements common to lists X and Y, compared with eq? 63 (define (common-elements x y) 64 (if (null? x) 65 '() 66 (if (memq (car x) y) 67 (cons (car x) (common-elements (cdr x) y)) 68 (common-elements (cdr x) y)))) 69 70 ;; validate an alist-copy of OLD to NEW 71 ;; lists must be equal, and must comprise new pairs 72 (define (valid-alist-copy? old new) 73 (and (equal? old new) 74 (null? (common-elements old new)))) 75 76 (pass-if-exception "too few args" exception:wrong-num-args 77 (alist-copy)) 78 79 (pass-if-exception "too many args" exception:wrong-num-args 80 (alist-copy '() '())) 81 82 (let ((old '())) 83 (pass-if old (valid-alist-copy? old (alist-copy old)))) 84 85 (let ((old '((1 . 2)))) 86 (pass-if old (valid-alist-copy? old (alist-copy old)))) 87 88 (let ((old '((1 . 2) (3 . 4)))) 89 (pass-if old (valid-alist-copy? old (alist-copy old)))) 90 91 (let ((old '((1 . 2) (3 . 4) (5 . 6)))) 92 (pass-if old (valid-alist-copy? old (alist-copy old))))) 93 94;; 95;; alist-delete 96;; 97 98(with-test-prefix "alist-delete" 99 100 (pass-if "equality call arg order" 101 (let ((good #f)) 102 (alist-delete 'k '((ak . 123)) 103 (lambda (k ak) 104 (if (and (eq? k 'k) (eq? ak 'ak)) 105 (set! good #t)))) 106 good)) 107 108 (pass-if "delete keys greater than 5" 109 (equal? '((4 . x) (5 . y)) 110 (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <))) 111 112 (pass-if "empty" 113 (equal? '() (alist-delete 'x '()))) 114 115 (pass-if "(y)" 116 (equal? '() (alist-delete 'y '((y . 1))))) 117 118 (pass-if "(n)" 119 (equal? '((n . 1)) (alist-delete 'y '((n . 1))))) 120 121 (pass-if "(y y)" 122 (equal? '() (alist-delete 'y '((y . 1) (y . 2))))) 123 124 (pass-if "(n y)" 125 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2))))) 126 127 (pass-if "(y n)" 128 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2))))) 129 130 (pass-if "(n n)" 131 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2))))) 132 133 (pass-if "(y y y)" 134 (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3))))) 135 136 (pass-if "(n y y)" 137 (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3))))) 138 139 (pass-if "(y n y)" 140 (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3))))) 141 142 (pass-if "(n n y)" 143 (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3))))) 144 145 (pass-if "(y y n)" 146 (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3))))) 147 148 (pass-if "(n y n)" 149 (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3))))) 150 151 (pass-if "(y n n)" 152 (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3))))) 153 154 (pass-if "(n n n)" 155 (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3)))))) 156 157;; 158;; append-map 159;; 160 161(with-test-prefix "append-map" 162 163 (with-test-prefix "one list" 164 165 (pass-if "()" 166 (equal? '() (append-map noop '(())))) 167 168 (pass-if "(1)" 169 (equal? '(1) (append-map noop '((1))))) 170 171 (pass-if "(1 2)" 172 (equal? '(1 2) (append-map noop '((1 2))))) 173 174 (pass-if "() ()" 175 (equal? '() (append-map noop '(() ())))) 176 177 (pass-if "() (1)" 178 (equal? '(1) (append-map noop '(() (1))))) 179 180 (pass-if "() (1 2)" 181 (equal? '(1 2) (append-map noop '(() (1 2))))) 182 183 (pass-if "(1) (2)" 184 (equal? '(1 2) (append-map noop '((1) (2))))) 185 186 (pass-if "(1 2) ()" 187 (equal? '(1 2) (append-map noop '(() (1 2)))))) 188 189 (with-test-prefix "two lists" 190 191 (pass-if "() / 9" 192 (equal? '() (append-map noop '(()) '(9)))) 193 194 (pass-if "(1) / 9" 195 (equal? '(1) (append-map noop '((1)) '(9)))) 196 197 (pass-if "() () / 9 9" 198 (equal? '() (append-map noop '(() ()) '(9 9)))) 199 200 (pass-if "(1) (2) / 9" 201 (equal? '(1) (append-map noop '((1) (2)) '(9)))) 202 203 (pass-if "(1) (2) / 9 9" 204 (equal? '(1 2) (append-map noop '((1) (2)) '(9 9)))))) 205 206;; 207;; append-reverse 208;; 209 210(with-test-prefix "append-reverse" 211 212 ;; return a list which is the cars and cdrs of LST 213 (define (list-contents lst) 214 (if (null? lst) 215 '() 216 (cons* (car lst) (cdr lst) (list-contents (cdr lst))))) 217 218 (define (valid-append-reverse revhead tail want) 219 (let ((revhead-contents (list-contents revhead)) 220 (got (append-reverse revhead tail))) 221 (and (equal? got want) 222 ;; revhead unchanged 223 (equal? revhead-contents (list-contents revhead))))) 224 225 (pass-if-exception "too few args (0)" exception:wrong-num-args 226 (append-reverse)) 227 228 (pass-if-exception "too few args (1)" exception:wrong-num-args 229 (append-reverse '(x))) 230 231 (pass-if-exception "too many args (3)" exception:wrong-num-args 232 (append-reverse '() '() #f)) 233 234 (pass-if (valid-append-reverse '() '() '())) 235 (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3))) 236 237 (pass-if (valid-append-reverse '(1) '() '(1))) 238 (pass-if (valid-append-reverse '(1) '(2) '(1 2))) 239 (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3))) 240 241 (pass-if (valid-append-reverse '(1 2) '() '(2 1))) 242 (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3))) 243 (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4))) 244 245 (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1))) 246 (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4))) 247 (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5)))) 248 249;; 250;; append-reverse! 251;; 252 253(with-test-prefix "append-reverse!" 254 255 (pass-if-exception "too few args (0)" exception:wrong-num-args 256 (append-reverse!)) 257 258 (pass-if-exception "too few args (1)" exception:wrong-num-args 259 (append-reverse! '(x))) 260 261 (pass-if-exception "too many args (3)" exception:wrong-num-args 262 (append-reverse! '() '() #f)) 263 264 (pass-if (equal? '() (append-reverse! '() '()))) 265 (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3)))) 266 267 (pass-if (equal? '(1) (append-reverse! '(1) '()))) 268 (pass-if (equal? '(1 2) (append-reverse! '(1) '(2)))) 269 (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3)))) 270 271 (pass-if (equal? '(2 1) (append-reverse! '(1 2) '()))) 272 (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3)))) 273 (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4)))) 274 275 (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '()))) 276 (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4)))) 277 (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5))))) 278 279;; 280;; assoc 281;; 282 283(with-test-prefix "assoc" 284 285 (pass-if "not found" 286 (let ((alist '((a . 1) 287 (b . 2) 288 (c . 3)))) 289 (eqv? #f (assoc 'z alist)))) 290 291 (pass-if "found" 292 (let ((alist '((a . 1) 293 (b . 2) 294 (c . 3)))) 295 (eqv? (second alist) (assoc 'b alist)))) 296 297 ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8 298 ;; series, 1.6.x and earlier was ok) 299 (pass-if "= arg order" 300 (let ((alist '((b . 1))) 301 (good #f)) 302 (assoc 'a alist (lambda (x y) 303 (set! good (and (eq? x 'a) 304 (eq? y 'b))))) 305 good)) 306 307 ;; likewise this one bad in guile 1.8.0 308 (pass-if "srfi-1 example <" 309 (let ((alist '((1 . a) 310 (5 . b) 311 (6 . c)))) 312 (eq? (third alist) (assoc 5 alist <))))) 313 314;; 315;; break 316;; 317 318(with-test-prefix "break" 319 320 (define (test-break lst want-v1 want-v2) 321 (call-with-values 322 (lambda () 323 (break negative? lst)) 324 (lambda (got-v1 got-v2) 325 (and (equal? got-v1 want-v1) 326 (equal? got-v2 want-v2))))) 327 328 (pass-if "empty" 329 (test-break '() '() '())) 330 331 (pass-if "y" 332 (test-break '(1) '(1) '())) 333 334 (pass-if "n" 335 (test-break '(-1) '() '(-1))) 336 337 (pass-if "yy" 338 (test-break '(1 2) '(1 2) '())) 339 340 (pass-if "ny" 341 (test-break '(-1 1) '() '(-1 1))) 342 343 (pass-if "yn" 344 (test-break '(1 -1) '(1) '(-1))) 345 346 (pass-if "nn" 347 (test-break '(-1 -2) '() '(-1 -2))) 348 349 (pass-if "yyy" 350 (test-break '(1 2 3) '(1 2 3) '())) 351 352 (pass-if "nyy" 353 (test-break '(-1 1 2) '() '(-1 1 2))) 354 355 (pass-if "yny" 356 (test-break '(1 -1 2) '(1) '(-1 2))) 357 358 (pass-if "nny" 359 (test-break '(-1 -2 1) '() '(-1 -2 1))) 360 361 (pass-if "yyn" 362 (test-break '(1 2 -1) '(1 2) '(-1))) 363 364 (pass-if "nyn" 365 (test-break '(-1 1 -2) '() '(-1 1 -2))) 366 367 (pass-if "ynn" 368 (test-break '(1 -1 -2) '(1) '(-1 -2))) 369 370 (pass-if "nnn" 371 (test-break '(-1 -2 -3) '() '(-1 -2 -3)))) 372 373;; 374;; break! 375;; 376 377(with-test-prefix "break!" 378 379 (define (test-break! lst want-v1 want-v2) 380 (call-with-values 381 (lambda () 382 (break! negative? lst)) 383 (lambda (got-v1 got-v2) 384 (and (equal? got-v1 want-v1) 385 (equal? got-v2 want-v2))))) 386 387 (pass-if "empty" 388 (test-break! '() '() '())) 389 390 (pass-if "y" 391 (test-break! (list 1) '(1) '())) 392 393 (pass-if "n" 394 (test-break! (list -1) '() '(-1))) 395 396 (pass-if "yy" 397 (test-break! (list 1 2) '(1 2) '())) 398 399 (pass-if "ny" 400 (test-break! (list -1 1) '() '(-1 1))) 401 402 (pass-if "yn" 403 (test-break! (list 1 -1) '(1) '(-1))) 404 405 (pass-if "nn" 406 (test-break! (list -1 -2) '() '(-1 -2))) 407 408 (pass-if "yyy" 409 (test-break! (list 1 2 3) '(1 2 3) '())) 410 411 (pass-if "nyy" 412 (test-break! (list -1 1 2) '() '(-1 1 2))) 413 414 (pass-if "yny" 415 (test-break! (list 1 -1 2) '(1) '(-1 2))) 416 417 (pass-if "nny" 418 (test-break! (list -1 -2 1) '() '(-1 -2 1))) 419 420 (pass-if "yyn" 421 (test-break! (list 1 2 -1) '(1 2) '(-1))) 422 423 (pass-if "nyn" 424 (test-break! (list -1 1 -2) '() '(-1 1 -2))) 425 426 (pass-if "ynn" 427 (test-break! (list 1 -1 -2) '(1) '(-1 -2))) 428 429 (pass-if "nnn" 430 (test-break! (list -1 -2 -3) '() '(-1 -2 -3)))) 431 432;; 433;; car+cdr 434;; 435 436(with-test-prefix "car+cdr" 437 438 (pass-if "(1 . 2)" 439 (call-with-values 440 (lambda () 441 (car+cdr '(1 . 2))) 442 (lambda (x y) 443 (and (eqv? x 1) 444 (eqv? y 2)))))) 445 446;; 447;; concatenate and concatenate! 448;; 449 450(let () 451 (define (common-tests concatenate-proc unmodified?) 452 (define (try lstlst want) 453 (let ((lstlst-copy (copy-tree lstlst)) 454 (got (concatenate-proc lstlst))) 455 (if unmodified? 456 (if (not (equal? lstlst lstlst-copy)) 457 (error "input lists modified"))) 458 (equal? got want))) 459 460 (pass-if-exception "too few args" exception:wrong-num-args 461 (concatenate-proc)) 462 463 (pass-if-exception "too many args" exception:wrong-num-args 464 (concatenate-proc '() '())) 465 466 (pass-if-exception "number" exception:wrong-type-arg 467 (concatenate-proc 123)) 468 469 (pass-if-exception "vector" exception:wrong-type-arg 470 (concatenate-proc #(1 2 3))) 471 472 (pass-if "no lists" 473 (try '() '())) 474 475 (pass-if (try '((1)) '(1))) 476 (pass-if (try '((1 2)) '(1 2))) 477 (pass-if (try '(() (1)) '(1))) 478 (pass-if (try '(() () (1)) '(1))) 479 480 (pass-if (try '((1) (2)) '(1 2))) 481 (pass-if (try '(() (1 2)) '(1 2))) 482 483 (pass-if (try '((1) 2) '(1 . 2))) 484 (pass-if (try '((1) (2) 3) '(1 2 . 3))) 485 (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4))) 486 ) 487 488 (with-test-prefix "concatenate" 489 (common-tests concatenate #t)) 490 491 (with-test-prefix "concatenate!" 492 (common-tests concatenate! #f))) 493 494;; 495;; count 496;; 497 498(with-test-prefix "count" 499 (pass-if-exception "no args" exception:wrong-num-args 500 (count)) 501 502 (pass-if-exception "one arg" exception:wrong-num-args 503 (count noop)) 504 505 (with-test-prefix "one list" 506 (define (or1 x) 507 x) 508 509 (pass-if "empty list" (= 0 (count or1 '()))) 510 511 (pass-if-exception "pred arg count 0" exception:wrong-num-args 512 (count (lambda () x) '(1 2 3))) 513 (pass-if-exception "pred arg count 2" exception:wrong-num-args 514 (count (lambda (x y) x) '(1 2 3))) 515 516 (pass-if-exception "improper 1" exception:wrong-type-arg 517 (count or1 1)) 518 (pass-if-exception "improper 2" exception:wrong-type-arg 519 (count or1 '(1 . 2))) 520 (pass-if-exception "improper 3" exception:wrong-type-arg 521 (count or1 '(1 2 . 3))) 522 523 (pass-if (= 0 (count or1 '(#f)))) 524 (pass-if (= 1 (count or1 '(#t)))) 525 526 (pass-if (= 0 (count or1 '(#f #f)))) 527 (pass-if (= 1 (count or1 '(#f #t)))) 528 (pass-if (= 1 (count or1 '(#t #f)))) 529 (pass-if (= 2 (count or1 '(#t #t)))) 530 531 (pass-if (= 0 (count or1 '(#f #f #f)))) 532 (pass-if (= 1 (count or1 '(#f #f #t)))) 533 (pass-if (= 1 (count or1 '(#t #f #f)))) 534 (pass-if (= 2 (count or1 '(#t #f #t)))) 535 (pass-if (= 3 (count or1 '(#t #t #t))))) 536 537 (with-test-prefix "two lists" 538 (define (or2 x y) 539 (or x y)) 540 541 (pass-if "arg order" 542 (= 1 (count (lambda (x y) 543 (and (= 1 x) 544 (= 2 y))) 545 '(1) '(2)))) 546 547 (pass-if "empty lists" (= 0 (count or2 '() '()))) 548 549 (pass-if-exception "pred arg count 0" exception:wrong-num-args 550 (count (lambda () #t) '(1 2 3) '(1 2 3))) 551 (pass-if-exception "pred arg count 1" exception:wrong-num-args 552 (count (lambda (x) x) '(1 2 3) '(1 2 3))) 553 (pass-if-exception "pred arg count 3" exception:wrong-num-args 554 (count (lambda (x y z) x) '(1 2 3) '(1 2 3))) 555 556 (pass-if-exception "improper first 1" exception:wrong-type-arg 557 (count or2 1 '(1 2 3))) 558 (pass-if-exception "improper first 2" exception:wrong-type-arg 559 (count or2 '(1 . 2) '(1 2 3))) 560 (pass-if-exception "improper first 3" exception:wrong-type-arg 561 (count or2 '(1 2 . 3) '(1 2 3))) 562 563 (pass-if-exception "improper second 1" exception:wrong-type-arg 564 (count or2 '(1 2 3) 1)) 565 (pass-if-exception "improper second 2" exception:wrong-type-arg 566 (count or2 '(1 2 3) '(1 . 2))) 567 (pass-if-exception "improper second 3" exception:wrong-type-arg 568 (count or2 '(1 2 3) '(1 2 . 3))) 569 570 (pass-if (= 0 (count or2 '(#f) '(#f)))) 571 (pass-if (= 1 (count or2 '(#t) '(#f)))) 572 (pass-if (= 1 (count or2 '(#f) '(#t)))) 573 574 (pass-if (= 0 (count or2 '(#f #f) '(#f #f)))) 575 (pass-if (= 1 (count or2 '(#t #f) '(#t #f)))) 576 (pass-if (= 2 (count or2 '(#t #t) '(#f #f)))) 577 (pass-if (= 2 (count or2 '(#t #f) '(#f #t)))) 578 579 (with-test-prefix "stop shortest" 580 (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t)))) 581 (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t)))) 582 (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t)))) 583 (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t)))))) 584 585 (with-test-prefix "three lists" 586 (define (or3 x y z) 587 (or x y z)) 588 589 (pass-if "arg order" 590 (= 1 (count (lambda (x y z) 591 (and (= 1 x) 592 (= 2 y) 593 (= 3 z))) 594 '(1) '(2) '(3)))) 595 596 (pass-if "empty lists" (= 0 (count or3 '() '() '()))) 597 598 ;; currently bad pred argument gives wrong-num-args when 3 or more 599 ;; lists, as opposed to wrong-type-arg for 1 or 2 lists 600 (pass-if-exception "pred arg count 0" exception:wrong-num-args 601 (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) 602 (pass-if-exception "pred arg count 2" exception:wrong-num-args 603 (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) 604 (pass-if-exception "pred arg count 4" exception:wrong-num-args 605 (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) 606 607 (pass-if-exception "improper first 1" exception:wrong-type-arg 608 (count or3 1 '(1 2 3) '(1 2 3))) 609 (pass-if-exception "improper first 2" exception:wrong-type-arg 610 (count or3 '(1 . 2) '(1 2 3) '(1 2 3))) 611 (pass-if-exception "improper first 3" exception:wrong-type-arg 612 (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3))) 613 614 (pass-if-exception "improper second 1" exception:wrong-type-arg 615 (count or3 '(1 2 3) 1 '(1 2 3))) 616 (pass-if-exception "improper second 2" exception:wrong-type-arg 617 (count or3 '(1 2 3) '(1 . 2) '(1 2 3))) 618 (pass-if-exception "improper second 3" exception:wrong-type-arg 619 (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3))) 620 621 (pass-if-exception "improper third 1" exception:wrong-type-arg 622 (count or3 '(1 2 3) '(1 2 3) 1)) 623 (pass-if-exception "improper third 2" exception:wrong-type-arg 624 (count or3 '(1 2 3) '(1 2 3) '(1 . 2))) 625 (pass-if-exception "improper third 3" exception:wrong-type-arg 626 (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3))) 627 628 (pass-if (= 0 (count or3 '(#f) '(#f) '(#f)))) 629 (pass-if (= 1 (count or3 '(#t) '(#f) '(#f)))) 630 (pass-if (= 1 (count or3 '(#f) '(#t) '(#f)))) 631 (pass-if (= 1 (count or3 '(#f) '(#f) '(#t)))) 632 633 (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f)))) 634 635 (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f)))) 636 (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f)))) 637 (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f)))) 638 (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f)))) 639 (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f)))) 640 (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t)))) 641 642 (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f)))) 643 (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f)))) 644 (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t)))) 645 (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t)))) 646 647 (with-test-prefix "stop shortest" 648 (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t)))) 649 (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t)))) 650 (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '()))) 651 652 (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t)))) 653 (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t)))) 654 (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t))))) 655 656 (pass-if "apply list unchanged" 657 (let ((lst (list (list 1 2) (list 3 4) (list 5 6)))) 658 (and (equal? 2 (apply count or3 lst)) 659 ;; lst unmodified 660 (equal? '((1 2) (3 4) (5 6)) lst)))))) 661 662;; 663;; delete and delete! 664;; 665 666(let () 667 ;; Call (PROC lst) for all lists of length up to 6, with all combinations 668 ;; of elements to be retained or deleted. Elements to retain are numbers, 669 ;; 0 upwards. Elements to be deleted are #f. 670 (define (test-lists proc) 671 (do ((n 0 (1+ n))) 672 ((>= n 6)) 673 (do ((limit (ash 1 n)) 674 (i 0 (1+ i))) 675 ((>= i limit)) 676 (let ((lst '())) 677 (do ((bit 0 (1+ bit))) 678 ((>= bit n)) 679 (set! lst (cons (if (logbit? bit i) bit #f) lst))) 680 (proc lst))))) 681 682 (define (common-tests delete-proc) 683 (pass-if-exception "too few args" exception:wrong-num-args 684 (delete-proc 0)) 685 686 (pass-if-exception "too many args" exception:wrong-num-args 687 (delete-proc 0 '() equal? 99)) 688 689 (pass-if "empty" 690 (eq? '() (delete-proc 0 '() equal?))) 691 692 (pass-if "equal?" 693 (equal? '((1) (3)) 694 (delete-proc '(2) '((1) (2) (3)) equal?))) 695 696 (pass-if "eq?" 697 (equal? '((1) (2) (3)) 698 (delete-proc '(2) '((1) (2) (3)) eq?))) 699 700 (pass-if "called arg order" 701 (equal? '(1 2 3) 702 (delete-proc 3 '(1 2 3 4 5) <)))) 703 704 (with-test-prefix "delete" 705 (common-tests delete) 706 707 (test-lists 708 (lambda (lst) 709 (let ((lst-copy (list-copy lst))) 710 (with-test-prefix lst-copy 711 (pass-if "result" 712 (equal? (delete #f lst equal?) 713 (ref-delete #f lst equal?))) 714 (pass-if "non-destructive" 715 (equal? lst-copy lst))))))) 716 717 (with-test-prefix "delete!" 718 (common-tests delete!) 719 720 (test-lists 721 (lambda (lst) 722 (pass-if lst 723 (equal? (delete! #f lst) 724 (ref-delete #f lst))))))) 725 726;; 727;; delete-duplicates and delete-duplicates! 728;; 729 730(let () 731 ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all 732 ;; combinations of numbers 1 to n in the elements 733 (define (test-lists proc) 734 (do ((n 1 (1+ n))) 735 ((> n 4)) 736 (do ((limit (integer-expt n n)) 737 (i 0 (1+ i))) 738 ((>= i limit)) 739 (let ((lst '())) 740 (do ((j 0 (1+ j)) 741 (rem i (quotient rem n))) 742 ((>= j n)) 743 (set! lst (cons (remainder rem n) lst))) 744 (proc lst))))) 745 746 (define (common-tests delete-duplicates-proc) 747 (pass-if-exception "too few args" exception:wrong-num-args 748 (delete-duplicates-proc)) 749 750 (pass-if-exception "too many args" exception:wrong-num-args 751 (delete-duplicates-proc '() equal? 99)) 752 753 (pass-if "empty" 754 (eq? '() (delete-duplicates-proc '()))) 755 756 (pass-if "equal? (the default)" 757 (equal? '((2)) 758 (delete-duplicates-proc '((2) (2) (2))))) 759 760 (pass-if "eq?" 761 (equal? '((2) (2) (2)) 762 (delete-duplicates-proc '((2) (2) (2)) eq?))) 763 764 (pass-if "called arg order" 765 (let ((ok #t)) 766 (delete-duplicates-proc '(1 2 3 4 5) 767 (lambda (x y) 768 (if (> x y) 769 (set! ok #f)) 770 #f)) 771 ok))) 772 773 (with-test-prefix "delete-duplicates" 774 (common-tests delete-duplicates) 775 776 (test-lists 777 (lambda (lst) 778 (let ((lst-copy (list-copy lst))) 779 (with-test-prefix lst-copy 780 (pass-if "result" 781 (equal? (delete-duplicates lst) 782 (ref-delete-duplicates lst))) 783 (pass-if "non-destructive" 784 (equal? lst-copy lst))))))) 785 786 (with-test-prefix "delete-duplicates!" 787 (common-tests delete-duplicates!) 788 789 (test-lists 790 (lambda (lst) 791 (pass-if lst 792 (equal? (delete-duplicates! lst) 793 (ref-delete-duplicates lst))))))) 794 795;; 796;; drop 797;; 798 799(with-test-prefix "drop" 800 801 (pass-if "'() 0" 802 (null? (drop '() 0))) 803 804 (pass-if "'(a) 0" 805 (let ((lst '(a))) 806 (eq? lst 807 (drop lst 0)))) 808 809 (pass-if "'(a b) 0" 810 (let ((lst '(a b))) 811 (eq? lst 812 (drop lst 0)))) 813 814 (pass-if "'(a) 1" 815 (let ((lst '(a))) 816 (eq? (cdr lst) 817 (drop lst 1)))) 818 819 (pass-if "'(a b) 1" 820 (let ((lst '(a b))) 821 (eq? (cdr lst) 822 (drop lst 1)))) 823 824 (pass-if "'(a b) 2" 825 (let ((lst '(a b))) 826 (eq? (cddr lst) 827 (drop lst 2)))) 828 829 (pass-if "'(a b c) 1" 830 (let ((lst '(a b c))) 831 (eq? (cddr lst) 832 (drop lst 2)))) 833 834 (pass-if "circular '(a) 0" 835 (let ((lst (circular-list 'a))) 836 (eq? lst 837 (drop lst 0)))) 838 839 (pass-if "circular '(a) 1" 840 (let ((lst (circular-list 'a))) 841 (eq? lst 842 (drop lst 1)))) 843 844 (pass-if "circular '(a) 2" 845 (let ((lst (circular-list 'a))) 846 (eq? lst 847 (drop lst 1)))) 848 849 (pass-if "circular '(a b) 1" 850 (let ((lst (circular-list 'a))) 851 (eq? (cdr lst) 852 (drop lst 0)))) 853 854 (pass-if "circular '(a b) 2" 855 (let ((lst (circular-list 'a))) 856 (eq? lst 857 (drop lst 1)))) 858 859 (pass-if "circular '(a b) 5" 860 (let ((lst (circular-list 'a))) 861 (eq? (cdr lst) 862 (drop lst 5)))) 863 864 (pass-if "'(a . b) 1" 865 (eq? 'b 866 (drop '(a . b) 1))) 867 868 (pass-if "'(a b . c) 1" 869 (equal? 'c 870 (drop '(a b . c) 2)))) 871 872;; 873;; drop-right 874;; 875 876(with-test-prefix "drop-right" 877 878 (pass-if-exception "() -1" exception:out-of-range 879 (drop-right '() -1)) 880 (pass-if (equal? '() (drop-right '() 0))) 881 (pass-if-exception "() 1" exception:wrong-type-arg 882 (drop-right '() 1)) 883 884 (pass-if-exception "(1) -1" exception:out-of-range 885 (drop-right '(1) -1)) 886 (pass-if (equal? '(1) (drop-right '(1) 0))) 887 (pass-if (equal? '() (drop-right '(1) 1))) 888 (pass-if-exception "(1) 2" exception:wrong-type-arg 889 (drop-right '(1) 2)) 890 891 (pass-if-exception "(4 5) -1" exception:out-of-range 892 (drop-right '(4 5) -1)) 893 (pass-if (equal? '(4 5) (drop-right '(4 5) 0))) 894 (pass-if (equal? '(4) (drop-right '(4 5) 1))) 895 (pass-if (equal? '() (drop-right '(4 5) 2))) 896 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 897 (drop-right '(4 5) 3)) 898 899 (pass-if-exception "(4 5 6) -1" exception:out-of-range 900 (drop-right '(4 5 6) -1)) 901 (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0))) 902 (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1))) 903 (pass-if (equal? '(4) (drop-right '(4 5 6) 2))) 904 (pass-if (equal? '() (drop-right '(4 5 6) 3))) 905 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 906 (drop-right '(4 5 6) 4)) 907 908 (pass-if "(a b . c) 0" 909 (equal? (drop-right '(a b . c) 0) '(a b))) 910 (pass-if "(a b . c) 1" 911 (equal? (drop-right '(a b . c) 1) '(a)))) 912 913;; 914;; drop-right! 915;; 916 917(with-test-prefix "drop-right!" 918 919 (pass-if-exception "() -1" exception:out-of-range 920 (drop-right! '() -1)) 921 (pass-if (equal? '() (drop-right! '() 0))) 922 (pass-if-exception "() 1" exception:wrong-type-arg 923 (drop-right! '() 1)) 924 925 (pass-if-exception "(1) -1" exception:out-of-range 926 (drop-right! (list 1) -1)) 927 (pass-if (equal? '(1) (drop-right! (list 1) 0))) 928 (pass-if (equal? '() (drop-right! (list 1) 1))) 929 (pass-if-exception "(1) 2" exception:wrong-type-arg 930 (drop-right! (list 1) 2)) 931 932 (pass-if-exception "(4 5) -1" exception:out-of-range 933 (drop-right! (list 4 5) -1)) 934 (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0))) 935 (pass-if (equal? '(4) (drop-right! (list 4 5) 1))) 936 (pass-if (equal? '() (drop-right! (list 4 5) 2))) 937 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 938 (drop-right! (list 4 5) 3)) 939 940 (pass-if-exception "(4 5 6) -1" exception:out-of-range 941 (drop-right! (list 4 5 6) -1)) 942 (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0))) 943 (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1))) 944 (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2))) 945 (pass-if (equal? '() (drop-right! (list 4 5 6) 3))) 946 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 947 (drop-right! (list 4 5 6) 4))) 948 949;; 950;; drop-while 951;; 952 953(with-test-prefix "drop-while" 954 955 (pass-if (equal? '() (drop-while odd? '()))) 956 (pass-if (equal? '() (drop-while odd? '(1)))) 957 (pass-if (equal? '() (drop-while odd? '(1 3)))) 958 (pass-if (equal? '() (drop-while odd? '(1 3 5)))) 959 960 (pass-if (equal? '(2) (drop-while odd? '(2)))) 961 (pass-if (equal? '(2) (drop-while odd? '(1 2)))) 962 (pass-if (equal? '(4) (drop-while odd? '(1 3 4)))) 963 964 (pass-if (equal? '(2 1) (drop-while odd? '(2 1)))) 965 (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3)))) 966 (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3))))) 967 968;; 969;; eighth 970;; 971 972(with-test-prefix "eighth" 973 (pass-if-exception "() -1" exception:wrong-type-arg 974 (eighth '(a b c d e f g))) 975 (pass-if (eq? 'h (eighth '(a b c d e f g h)))) 976 (pass-if (eq? 'h (eighth '(a b c d e f g h i))))) 977 978;; 979;; fifth 980;; 981 982(with-test-prefix "fifth" 983 (pass-if-exception "() -1" exception:wrong-type-arg 984 (fifth '(a b c d))) 985 (pass-if (eq? 'e (fifth '(a b c d e)))) 986 (pass-if (eq? 'e (fifth '(a b c d e f))))) 987 988;; 989;; filter-map 990;; 991 992(with-test-prefix "filter-map" 993 994 (with-test-prefix "one list" 995 (pass-if-exception "'x" exception:wrong-type-arg 996 (filter-map noop 'x)) 997 998 (pass-if-exception "'(1 . x)" exception:wrong-type-arg 999 (filter-map noop '(1 . x))) 1000 1001 (pass-if "(1)" 1002 (equal? '(1) (filter-map noop '(1)))) 1003 1004 (pass-if "(#f)" 1005 (equal? '() (filter-map noop '(#f)))) 1006 1007 (pass-if "(1 2)" 1008 (equal? '(1 2) (filter-map noop '(1 2)))) 1009 1010 (pass-if "(#f 2)" 1011 (equal? '(2) (filter-map noop '(#f 2)))) 1012 1013 (pass-if "(#f #f)" 1014 (equal? '() (filter-map noop '(#f #f)))) 1015 1016 (pass-if "(1 2 3)" 1017 (equal? '(1 2 3) (filter-map noop '(1 2 3)))) 1018 1019 (pass-if "(#f 2 3)" 1020 (equal? '(2 3) (filter-map noop '(#f 2 3)))) 1021 1022 (pass-if "(1 #f 3)" 1023 (equal? '(1 3) (filter-map noop '(1 #f 3)))) 1024 1025 (pass-if "(1 2 #f)" 1026 (equal? '(1 2) (filter-map noop '(1 2 #f))))) 1027 1028 (with-test-prefix "two lists" 1029 (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg 1030 (filter-map noop 'x '(1 2 3))) 1031 1032 (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg 1033 (filter-map noop '(1 2 3) 'x)) 1034 1035 (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg 1036 (filter-map noop '(1 . x) '(1 2 3))) 1037 1038 (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg 1039 (filter-map noop '(1 2 3) '(1 . x))) 1040 1041 (pass-if "(1 2 3) (4 5 6)" 1042 (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6)))) 1043 1044 (pass-if "(#f 2 3) (4 5)" 1045 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5)))) 1046 1047 (pass-if "(4 #f) (1 2 3)" 1048 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3)))) 1049 1050 (pass-if "() (1 2 3)" 1051 (equal? '() (filter-map noop '() '(1 2 3)))) 1052 1053 (pass-if "(1 2 3) ()" 1054 (equal? '() (filter-map noop '(1 2 3) '())))) 1055 1056 (with-test-prefix "three lists" 1057 (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg 1058 (filter-map noop 'x '(1 2 3) '(1 2 3))) 1059 1060 (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg 1061 (filter-map noop '(1 2 3) 'x '(1 2 3))) 1062 1063 (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg 1064 (filter-map noop '(1 2 3) '(1 2 3) 'x)) 1065 1066 (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg 1067 (filter-map noop '(1 . x) '(1 2 3) '(1 2 3))) 1068 1069 (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg 1070 (filter-map noop '(1 2 3) '(1 . x) '(1 2 3))) 1071 1072 (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg 1073 (filter-map noop '(1 2 3) '(1 2 3) '(1 . x))) 1074 1075 (pass-if "(1 2 3) (4 5 6) (7 8 9)" 1076 (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9)))) 1077 1078 (pass-if "(#f 2 3) (4 5) (7 8 9)" 1079 (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9)))) 1080 1081 (pass-if "(#f 2 3) (7 8 9) (4 5)" 1082 (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5)))) 1083 1084 (pass-if "(4 #f) (1 2 3) (7 8 9)" 1085 (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9)))) 1086 1087 (pass-if "apply list unchanged" 1088 (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8)))) 1089 (and (equal? '(1 2) (apply filter-map noop lst)) 1090 ;; lst unmodified 1091 (equal? lst '((1 #f 2) (3 4 5) (6 7 8)))))))) 1092 1093;; 1094;; find 1095;; 1096 1097(with-test-prefix "find" 1098 (pass-if (eqv? #f (find odd? '()))) 1099 (pass-if (eqv? #f (find odd? '(0)))) 1100 (pass-if (eqv? #f (find odd? '(0 2)))) 1101 (pass-if (eqv? 1 (find odd? '(1)))) 1102 (pass-if (eqv? 1 (find odd? '(0 1)))) 1103 (pass-if (eqv? 1 (find odd? '(0 1 2)))) 1104 (pass-if (eqv? 1 (find odd? '(2 0 1)))) 1105 (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1))))) 1106 1107;; 1108;; find-tail 1109;; 1110 1111(with-test-prefix "find-tail" 1112 (pass-if (let ((lst '())) 1113 (eq? #f (find-tail odd? lst)))) 1114 (pass-if (let ((lst '(0))) 1115 (eq? #f (find-tail odd? lst)))) 1116 (pass-if (let ((lst '(0 2))) 1117 (eq? #f (find-tail odd? lst)))) 1118 (pass-if (let ((lst '(1))) 1119 (eq? lst (find-tail odd? lst)))) 1120 (pass-if (let ((lst '(1 2))) 1121 (eq? lst (find-tail odd? lst)))) 1122 (pass-if (let ((lst '(2 1))) 1123 (eq? (cdr lst) (find-tail odd? lst)))) 1124 (pass-if (let ((lst '(2 1 0))) 1125 (eq? (cdr lst) (find-tail odd? lst)))) 1126 (pass-if (let ((lst '(2 0 1))) 1127 (eq? (cddr lst) (find-tail odd? lst)))) 1128 (pass-if (let ((lst '(2 0 1))) 1129 (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst))))) 1130 1131;; 1132;; fold 1133;; 1134 1135(with-test-prefix "fold" 1136 (pass-if-exception "no args" exception:wrong-num-args 1137 (fold)) 1138 1139 (pass-if-exception "one arg" exception:wrong-num-args 1140 (fold 123)) 1141 1142 (pass-if-exception "two args" exception:wrong-num-args 1143 (fold 123 noop)) 1144 1145 (with-test-prefix "one list" 1146 1147 (pass-if "arg order" 1148 (eq? #t (fold (lambda (x prev) 1149 (and (= 1 x) 1150 (= 2 prev))) 1151 2 '(1)))) 1152 1153 (pass-if "empty list" (= 123 (fold + 123 '()))) 1154 1155 (pass-if-exception "proc arg count 0" exception:wrong-num-args 1156 (fold (lambda () x) 123 '(1 2 3))) 1157 (pass-if-exception "proc arg count 1" exception:wrong-num-args 1158 (fold (lambda (x) x) 123 '(1 2 3))) 1159 (pass-if-exception "proc arg count 3" exception:wrong-num-args 1160 (fold (lambda (x y z) x) 123 '(1 2 3))) 1161 1162 (pass-if-exception "improper 1" exception:wrong-type-arg 1163 (fold + 123 1)) 1164 (pass-if-exception "improper 2" exception:wrong-type-arg 1165 (fold + 123 '(1 . 2))) 1166 (pass-if-exception "improper 3" exception:wrong-type-arg 1167 (fold + 123 '(1 2 . 3))) 1168 1169 (pass-if (= 3 (fold + 1 '(2)))) 1170 (pass-if (= 6 (fold + 1 '(2 3)))) 1171 (pass-if (= 10 (fold + 1 '(2 3 4))))) 1172 1173 (with-test-prefix "two lists" 1174 1175 (pass-if "arg order" 1176 (eq? #t (fold (lambda (x y prev) 1177 (and (= 1 x) 1178 (= 2 y) 1179 (= 3 prev))) 1180 3 '(1) '(2)))) 1181 1182 (pass-if "empty lists" (= 1 (fold + 1 '() '()))) 1183 1184 ;; currently bad proc argument gives wrong-num-args when 2 or more 1185 ;; lists, as opposed to wrong-type-arg for 1 list 1186 (pass-if-exception "proc arg count 2" exception:wrong-num-args 1187 (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3))) 1188 (pass-if-exception "proc arg count 4" exception:wrong-num-args 1189 (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3))) 1190 1191 (pass-if-exception "improper first 1" exception:wrong-type-arg 1192 (fold + 1 1 '(1 2 3))) 1193 (pass-if-exception "improper first 2" exception:wrong-type-arg 1194 (fold + 1 '(1 . 2) '(1 2 3))) 1195 (pass-if-exception "improper first 3" exception:wrong-type-arg 1196 (fold + 1 '(1 2 . 3) '(1 2 3))) 1197 1198 (pass-if-exception "improper second 1" exception:wrong-type-arg 1199 (fold + 1 '(1 2 3) 1)) 1200 (pass-if-exception "improper second 2" exception:wrong-type-arg 1201 (fold + 1 '(1 2 3) '(1 . 2))) 1202 (pass-if-exception "improper second 3" exception:wrong-type-arg 1203 (fold + 1 '(1 2 3) '(1 2 . 3))) 1204 1205 (pass-if (= 6 (fold + 1 '(2) '(3)))) 1206 (pass-if (= 15 (fold + 1 '(2 3) '(4 5)))) 1207 (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7)))) 1208 1209 (with-test-prefix "stop shortest" 1210 (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5)))) 1211 (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3)))) 1212 (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9)))) 1213 (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4))))) 1214 1215 (pass-if "apply list unchanged" 1216 (let ((lst (list (list 1 2) (list 3 4)))) 1217 (and (equal? 11 (apply fold + 1 lst)) 1218 ;; lst unmodified 1219 (equal? '((1 2) (3 4)) lst))))) 1220 1221 (with-test-prefix "three lists" 1222 1223 (pass-if "arg order" 1224 (eq? #t (fold (lambda (x y z prev) 1225 (and (= 1 x) 1226 (= 2 y) 1227 (= 3 z) 1228 (= 4 prev))) 1229 4 '(1) '(2) '(3)))) 1230 1231 (pass-if "empty lists" (= 1 (fold + 1 '() '() '()))) 1232 1233 (pass-if-exception "proc arg count 3" exception:wrong-num-args 1234 (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) )) 1235 (pass-if-exception "proc arg count 5" exception:wrong-num-args 1236 (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3))) 1237 1238 (pass-if-exception "improper first 1" exception:wrong-type-arg 1239 (fold + 1 1 '(1 2 3) '(1 2 3))) 1240 (pass-if-exception "improper first 2" exception:wrong-type-arg 1241 (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3))) 1242 (pass-if-exception "improper first 3" exception:wrong-type-arg 1243 (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3))) 1244 1245 (pass-if-exception "improper second 1" exception:wrong-type-arg 1246 (fold + 1 '(1 2 3) 1 '(1 2 3))) 1247 (pass-if-exception "improper second 2" exception:wrong-type-arg 1248 (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3))) 1249 (pass-if-exception "improper second 3" exception:wrong-type-arg 1250 (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3))) 1251 1252 (pass-if-exception "improper third 1" exception:wrong-type-arg 1253 (fold + 1 '(1 2 3) '(1 2 3) 1)) 1254 (pass-if-exception "improper third 2" exception:wrong-type-arg 1255 (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2))) 1256 (pass-if-exception "improper third 3" exception:wrong-type-arg 1257 (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3))) 1258 1259 (pass-if (= 10 (fold + 1 '(2) '(3) '(4)))) 1260 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7)))) 1261 (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10)))) 1262 1263 (with-test-prefix "stop shortest" 1264 (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7)))) 1265 (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7)))) 1266 (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9))))) 1267 1268 (pass-if "apply list unchanged" 1269 (let ((lst (list (list 1 2) (list 3 4) (list 5 6)))) 1270 (and (equal? 22 (apply fold + 1 lst)) 1271 ;; lst unmodified 1272 (equal? '((1 2) (3 4) (5 6)) lst)))))) 1273 1274;; 1275;; fold-right 1276;; 1277 1278(with-test-prefix "fold-right" 1279 1280 (pass-if "one list" 1281 (equal? (iota 10) 1282 (fold-right cons '() (iota 10)))) 1283 1284 (pass-if "two lists" 1285 (equal? (zip (iota 10) (map integer->char (iota 10))) 1286 (fold-right (lambda (x y z) 1287 (cons (list x y) z)) 1288 '() 1289 (iota 10) 1290 (map integer->char (iota 10))))) 1291 1292 (pass-if "tail-recursive" 1293 (= 1e6 (fold-right (lambda (x y) (+ 1 y)) 1294 0 1295 (iota 1e6))))) 1296;; 1297;; unfold 1298;; 1299 1300(with-test-prefix "unfold" 1301 1302 (pass-if "basic" 1303 (equal? (iota 10) 1304 (unfold (lambda (x) (>= x 10)) 1305 identity 1306 1+ 1307 0))) 1308 1309 (pass-if "tail-gen" 1310 (equal? (append (iota 10) '(tail 10)) 1311 (unfold (lambda (x) (>= x 10)) 1312 identity 1313 1+ 1314 0 1315 (lambda (seed) (list 'tail seed))))) 1316 1317 (pass-if "tail-recursive" 1318 ;; Bug #30071. 1319 (pair? (unfold (lambda (x) (>= x 1e6)) 1320 identity 1321 1+ 1322 0)))) 1323 1324;; 1325;; length+ 1326;; 1327 1328(with-test-prefix "length+" 1329 (pass-if-exception "too few args" exception:wrong-num-args 1330 (length+)) 1331 (pass-if-exception "too many args" exception:wrong-num-args 1332 (length+ 123 456)) 1333 (pass-if-exception "not a pair" exception:wrong-type-arg 1334 (length+ 'x)) 1335 (pass-if-exception "improper list" exception:wrong-type-arg 1336 (length+ '(x y . z))) 1337 (pass-if (= 0 (length+ '()))) 1338 (pass-if (= 1 (length+ '(x)))) 1339 (pass-if (= 2 (length+ '(x y)))) 1340 (pass-if (= 3 (length+ '(x y z)))) 1341 (pass-if (not (length+ (circular-list 1)))) 1342 (pass-if (not (length+ (circular-list 1 2)))) 1343 (pass-if (not (length+ (circular-list 1 2 3))))) 1344 1345;; 1346;; last 1347;; 1348 1349(with-test-prefix "last" 1350 1351 (pass-if-exception "empty" exception:wrong-type-arg 1352 (last '())) 1353 (pass-if "one elem" 1354 (eqv? 1 (last '(1)))) 1355 (pass-if "two elems" 1356 (eqv? 2 (last '(1 2)))) 1357 (pass-if "three elems" 1358 (eqv? 3 (last '(1 2 3)))) 1359 (pass-if "four elems" 1360 (eqv? 4 (last '(1 2 3 4))))) 1361 1362;; 1363;; list= 1364;; 1365 1366(with-test-prefix "list=" 1367 1368 (pass-if "no lists" 1369 (eq? #t (list= eqv?))) 1370 1371 (with-test-prefix "one list" 1372 1373 (pass-if "empty" 1374 (eq? #t (list= eqv? '()))) 1375 (pass-if "one elem" 1376 (eq? #t (list= eqv? '(1)))) 1377 (pass-if "two elems" 1378 (eq? #t (list= eqv? '(2))))) 1379 1380 (with-test-prefix "two lists" 1381 1382 (pass-if "empty / empty" 1383 (eq? #t (list= eqv? '() '()))) 1384 1385 (pass-if "one / empty" 1386 (eq? #f (list= eqv? '(1) '()))) 1387 1388 (pass-if "empty / one" 1389 (eq? #f (list= eqv? '() '(1)))) 1390 1391 (pass-if "one / one same" 1392 (eq? #t (list= eqv? '(1) '(1)))) 1393 1394 (pass-if "one / one diff" 1395 (eq? #f (list= eqv? '(1) '(2)))) 1396 1397 (pass-if "called arg order" 1398 (let ((good #t)) 1399 (list= (lambda (x y) 1400 (set! good (and good (= (1+ x) y))) 1401 #t) 1402 '(1 3) '(2 4)) 1403 good))) 1404 1405 (with-test-prefix "three lists" 1406 1407 (pass-if "empty / empty / empty" 1408 (eq? #t (list= eqv? '() '() '()))) 1409 1410 (pass-if "one / empty / empty" 1411 (eq? #f (list= eqv? '(1) '() '()))) 1412 1413 (pass-if "one / one / empty" 1414 (eq? #f (list= eqv? '(1) '(1) '()))) 1415 1416 (pass-if "one / diff / empty" 1417 (eq? #f (list= eqv? '(1) '(2) '()))) 1418 1419 (pass-if "one / one / one" 1420 (eq? #t (list= eqv? '(1) '(1) '(1)))) 1421 1422 (pass-if "two / two / diff" 1423 (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99)))) 1424 1425 (pass-if "two / two / two" 1426 (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2)))) 1427 1428 (pass-if "called arg order" 1429 (let ((good #t)) 1430 (list= (lambda (x y) 1431 (set! good (and good (= (1+ x) y))) 1432 #t) 1433 '(1 4) '(2 5) '(3 6)) 1434 good)))) 1435 1436;; 1437;; list-copy 1438;; 1439 1440(with-test-prefix "list-copy" 1441 (pass-if (equal? '() (list-copy '()))) 1442 (pass-if (equal? '(1 2) (list-copy '(1 2)))) 1443 (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) 1444 (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) 1445 (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) 1446 1447 ;; improper lists can be copied 1448 (pass-if (equal? 1 (list-copy 1))) 1449 (pass-if (equal? '(1 . 2) (list-copy '(1 . 2)))) 1450 (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) 1451 (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) 1452 (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))) 1453 1454;; 1455;; list-index 1456;; 1457 1458(with-test-prefix "list-index" 1459 (pass-if-exception "no args" exception:wrong-num-args 1460 (list-index)) 1461 1462 (pass-if-exception "one arg" exception:wrong-num-args 1463 (list-index noop)) 1464 1465 (with-test-prefix "one list" 1466 1467 (pass-if "empty list" (eq? #f (list-index symbol? '()))) 1468 1469 (pass-if-exception "pred arg count 0" exception:wrong-num-args 1470 (list-index (lambda () x) '(1 2 3))) 1471 (pass-if-exception "pred arg count 2" exception:wrong-num-args 1472 (list-index (lambda (x y) x) '(1 2 3))) 1473 1474 (pass-if-exception "improper 1" exception:wrong-type-arg 1475 (list-index symbol? 1)) 1476 (pass-if-exception "improper 2" exception:wrong-type-arg 1477 (list-index symbol? '(1 . 2))) 1478 (pass-if-exception "improper 3" exception:wrong-type-arg 1479 (list-index symbol? '(1 2 . 3))) 1480 1481 (pass-if (eqv? #f (list-index symbol? '(1)))) 1482 (pass-if (eqv? 0 (list-index symbol? '(x)))) 1483 1484 (pass-if (eqv? #f (list-index symbol? '(1 2)))) 1485 (pass-if (eqv? 0 (list-index symbol? '(x 1)))) 1486 (pass-if (eqv? 1 (list-index symbol? '(1 x)))) 1487 1488 (pass-if (eqv? #f (list-index symbol? '(1 2 3)))) 1489 (pass-if (eqv? 0 (list-index symbol? '(x 1 2)))) 1490 (pass-if (eqv? 1 (list-index symbol? '(1 x 2)))) 1491 (pass-if (eqv? 2 (list-index symbol? '(1 2 x))))) 1492 1493 (with-test-prefix "two lists" 1494 (define (sym1 x y) 1495 (symbol? x)) 1496 (define (sym2 x y) 1497 (symbol? y)) 1498 1499 (pass-if "arg order" 1500 (eqv? 0 (list-index (lambda (x y) 1501 (and (= 1 x) 1502 (= 2 y))) 1503 '(1) '(2)))) 1504 1505 (pass-if "empty lists" (eqv? #f (list-index sym2 '() '()))) 1506 1507 (pass-if-exception "pred arg count 0" exception:wrong-num-args 1508 (list-index (lambda () #t) '(1 2 3) '(1 2 3))) 1509 (pass-if-exception "pred arg count 1" exception:wrong-num-args 1510 (list-index (lambda (x) x) '(1 2 3) '(1 2 3))) 1511 (pass-if-exception "pred arg count 3" exception:wrong-num-args 1512 (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3))) 1513 1514 (pass-if-exception "improper first 1" exception:wrong-type-arg 1515 (list-index sym2 1 '(1 2 3))) 1516 (pass-if-exception "improper first 2" exception:wrong-type-arg 1517 (list-index sym2 '(1 . 2) '(1 2 3))) 1518 (pass-if-exception "improper first 3" exception:wrong-type-arg 1519 (list-index sym2 '(1 2 . 3) '(1 2 3))) 1520 1521 (pass-if-exception "improper second 1" exception:wrong-type-arg 1522 (list-index sym2 '(1 2 3) 1)) 1523 (pass-if-exception "improper second 2" exception:wrong-type-arg 1524 (list-index sym2 '(1 2 3) '(1 . 2))) 1525 (pass-if-exception "improper second 3" exception:wrong-type-arg 1526 (list-index sym2 '(1 2 3) '(1 2 . 3))) 1527 1528 (pass-if (eqv? #f (list-index sym2 '(1) '(2)))) 1529 (pass-if (eqv? 0 (list-index sym2 '(1) '(x)))) 1530 1531 (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4)))) 1532 (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3)))) 1533 (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x)))) 1534 1535 (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5)))) 1536 (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4)))) 1537 (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4)))) 1538 (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x)))) 1539 1540 (with-test-prefix "stop shortest" 1541 (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5)))) 1542 (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x)))) 1543 (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y)))) 1544 (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4)))))) 1545 1546 (with-test-prefix "three lists" 1547 (define (sym1 x y z) 1548 (symbol? x)) 1549 (define (sym2 x y z) 1550 (symbol? y)) 1551 (define (sym3 x y z) 1552 (symbol? z)) 1553 1554 (pass-if "arg order" 1555 (eqv? 0 (list-index (lambda (x y z) 1556 (and (= 1 x) 1557 (= 2 y) 1558 (= 3 z))) 1559 '(1) '(2) '(3)))) 1560 1561 (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '()))) 1562 1563 ;; currently bad pred argument gives wrong-num-args when 3 or more 1564 ;; lists, as opposed to wrong-type-arg for 1 or 2 lists 1565 (pass-if-exception "pred arg count 0" exception:wrong-num-args 1566 (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) 1567 (pass-if-exception "pred arg count 2" exception:wrong-num-args 1568 (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) 1569 (pass-if-exception "pred arg count 4" exception:wrong-num-args 1570 (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) 1571 1572 (pass-if-exception "improper first 1" exception:wrong-type-arg 1573 (list-index sym3 1 '(1 2 3) '(1 2 3))) 1574 (pass-if-exception "improper first 2" exception:wrong-type-arg 1575 (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3))) 1576 (pass-if-exception "improper first 3" exception:wrong-type-arg 1577 (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3))) 1578 1579 (pass-if-exception "improper second 1" exception:wrong-type-arg 1580 (list-index sym3 '(1 2 3) 1 '(1 2 3))) 1581 (pass-if-exception "improper second 2" exception:wrong-type-arg 1582 (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3))) 1583 (pass-if-exception "improper second 3" exception:wrong-type-arg 1584 (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3))) 1585 1586 (pass-if-exception "improper third 1" exception:wrong-type-arg 1587 (list-index sym3 '(1 2 3) '(1 2 3) 1)) 1588 (pass-if-exception "improper third 2" exception:wrong-type-arg 1589 (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2))) 1590 (pass-if-exception "improper third 3" exception:wrong-type-arg 1591 (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3))) 1592 1593 (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f)))) 1594 (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x)))) 1595 1596 (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f)))) 1597 (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f)))) 1598 (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x)))) 1599 1600 (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f)))) 1601 (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f)))) 1602 (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f)))) 1603 (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x)))) 1604 1605 (with-test-prefix "stop shortest" 1606 (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x)))) 1607 (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x)))) 1608 (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '()))) 1609 1610 (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x)))) 1611 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x)))) 1612 (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t))))) 1613 1614 (pass-if "apply list unchanged" 1615 (let ((lst (list (list 1 2) (list 3 4) (list 5 6)))) 1616 (and (equal? #f (apply list-index sym3 lst)) 1617 ;; lst unmodified 1618 (equal? '((1 2) (3 4) (5 6)) lst)))))) 1619 1620;; 1621;; list-tabulate 1622;; 1623 1624(with-test-prefix "list-tabulate" 1625 1626 (pass-if-exception "-1" exception:wrong-type-arg 1627 (list-tabulate -1 identity)) 1628 (pass-if "0" 1629 (equal? '() (list-tabulate 0 identity))) 1630 (pass-if "1" 1631 (equal? '(0) (list-tabulate 1 identity))) 1632 (pass-if "2" 1633 (equal? '(0 1) (list-tabulate 2 identity))) 1634 (pass-if "3" 1635 (equal? '(0 1 2) (list-tabulate 3 identity))) 1636 (pass-if "4" 1637 (equal? '(0 1 2 3) (list-tabulate 4 identity))) 1638 (pass-if "string ref proc" 1639 (equal? '(#\a #\b #\c #\d) (list-tabulate 4 1640 (lambda (i) 1641 (string-ref "abcd" i)))))) 1642 1643;; 1644;; lset= 1645;; 1646 1647(with-test-prefix "lset=" 1648 1649 ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one 1650 ;; list arg 1651 (pass-if "no args" 1652 (eq? #t (lset= eq?))) 1653 1654 (with-test-prefix "one arg" 1655 1656 (pass-if "()" 1657 (eq? #t (lset= eqv? '()))) 1658 1659 (pass-if "(1)" 1660 (eq? #t (lset= eqv? '(1)))) 1661 1662 (pass-if "(1 2)" 1663 (eq? #t (lset= eqv? '(1 2))))) 1664 1665 (with-test-prefix "two args" 1666 1667 (pass-if "() ()" 1668 (eq? #t (lset= eqv? '() '()))) 1669 1670 (pass-if "(1) (1)" 1671 (eq? #t (lset= eqv? '(1) '(1)))) 1672 1673 (pass-if "(1) (2)" 1674 (eq? #f (lset= eqv? '(1) '(2)))) 1675 1676 (pass-if "(1) (1 2)" 1677 (eq? #f (lset= eqv? '(1) '(1 2)))) 1678 1679 (pass-if "(1 2) (2 1)" 1680 (eq? #t (lset= eqv? '(1 2) '(2 1)))) 1681 1682 (pass-if "called arg order" 1683 (let ((good #t)) 1684 (lset= (lambda (x y) 1685 (if (not (= x (1- y))) 1686 (set! good #f)) 1687 #t) 1688 '(1 1) '(2 2)) 1689 good))) 1690 1691 (with-test-prefix "three args" 1692 1693 (pass-if "() () ()" 1694 (eq? #t (lset= eqv? '() '() '()))) 1695 1696 (pass-if "(1) (1) (1)" 1697 (eq? #t (lset= eqv? '(1) '(1) '(1)))) 1698 1699 (pass-if "(1) (1) (2)" 1700 (eq? #f (lset= eqv? '(1) '(1) '(2)))) 1701 1702 (pass-if "(1) (1) (1 2)" 1703 (eq? #f (lset= eqv? '(1) '(1) '(1 2)))) 1704 1705 (pass-if "(1 2 3) (3 2 1) (1 3 2)" 1706 (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2)))) 1707 1708 (pass-if "called arg order" 1709 (let ((good #t)) 1710 (lset= (lambda (x y) 1711 (if (not (= x (1- y))) 1712 (set! good #f)) 1713 #t) 1714 '(1 1) '(2 2) '(3 3)) 1715 good)))) 1716 1717;; 1718;; lset-adjoin 1719;; 1720 1721(with-test-prefix "lset-adjoin" 1722 1723 ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given 1724 ;; `=' procedure, all comparisons were just with `equal? 1725 ;; 1726 (with-test-prefix "case-insensitive =" 1727 1728 (pass-if "(\"x\") \"X\"" 1729 (equal? '("x") (lset-adjoin string-ci=? '("x") "X")))) 1730 1731 (pass-if "called arg order" 1732 (let ((good #f)) 1733 (lset-adjoin (lambda (x y) 1734 (set! good (and (= x 1) (= y 2))) 1735 (= x y)) 1736 '(1) 2) 1737 good)) 1738 1739 (pass-if (equal? '() (lset-adjoin = '()))) 1740 1741 (pass-if (equal? '(1) (lset-adjoin = '() 1))) 1742 1743 (pass-if (equal? '(1) (lset-adjoin = '() 1 1))) 1744 1745 (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2))) 1746 1747 (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1))) 1748 1749 (pass-if "apply list unchanged" 1750 (let ((lst (list 1 2))) 1751 (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst)) 1752 ;; lst unmodified 1753 (equal? '(1 2) lst)))) 1754 1755 (pass-if "(1 1) 1 1" 1756 (equal? '(1 1) (lset-adjoin = '(1 1) 1 1))) 1757 1758 ;; duplicates among args are cast out 1759 (pass-if "(2) 1 1" 1760 (equal? '(1 2) (lset-adjoin = '(2) 1 1)))) 1761 1762;; 1763;; lset-difference 1764;; 1765 1766(with-test-prefix "lset-difference" 1767 1768 (pass-if "called arg order" 1769 (let ((good #f)) 1770 (lset-difference (lambda (x y) 1771 (set! good (and (= x 1) (= y 2))) 1772 (= x y)) 1773 '(1) '(2)) 1774 good))) 1775 1776;; 1777;; lset-difference! 1778;; 1779 1780(with-test-prefix "lset-difference!" 1781 1782 (pass-if-exception "proc - num" exception:wrong-type-arg 1783 (lset-difference! 123 '(4))) 1784 (pass-if-exception "proc - list" exception:wrong-type-arg 1785 (lset-difference! (list 1 2 3) '(4))) 1786 1787 (pass-if "called arg order" 1788 (let ((good #f)) 1789 (lset-difference! (lambda (x y) 1790 (set! good (and (= x 1) (= y 2))) 1791 (= x y)) 1792 (list 1) (list 2)) 1793 good)) 1794 1795 (pass-if (equal? '() (lset-difference! = '()))) 1796 (pass-if (equal? '(1) (lset-difference! = (list 1)))) 1797 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2)))) 1798 1799 (pass-if (equal? '() (lset-difference! = (list ) '(3)))) 1800 (pass-if (equal? '() (lset-difference! = (list 3) '(3)))) 1801 (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3)))) 1802 (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3)))) 1803 (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3)))) 1804 (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3)))) 1805 (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3)))) 1806 1807 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3)))) 1808 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2)))) 1809 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2)))) 1810 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3)))) 1811 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3)))) 1812 (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2)))) 1813 1814 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3)))) 1815 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3)))) 1816 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3)))) 1817 1818 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4)))) 1819 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4)))) 1820 (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4)))) 1821 (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4)))) 1822 1823 (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3)))) 1824 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3)))) 1825 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3)))) 1826 (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3)))) 1827 (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3)))) 1828 (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3))))) 1829 1830;; 1831;; lset-diff+intersection 1832;; 1833 1834(with-test-prefix "lset-diff+intersection" 1835 1836 (pass-if "called arg order" 1837 (let ((good #f)) 1838 (lset-diff+intersection (lambda (x y) 1839 (set! good (and (= x 1) (= y 2))) 1840 (= x y)) 1841 '(1) '(2)) 1842 good))) 1843 1844;; 1845;; lset-diff+intersection! 1846;; 1847 1848(with-test-prefix "lset-diff+intersection" 1849 1850 (pass-if "called arg order" 1851 (let ((good #f)) 1852 (lset-diff+intersection (lambda (x y) 1853 (set! good (and (= x 1) (= y 2))) 1854 (= x y)) 1855 (list 1) (list 2)) 1856 good))) 1857 1858;; 1859;; lset-intersection 1860;; 1861 1862(with-test-prefix "lset-intersection" 1863 1864 (pass-if "called arg order" 1865 (let ((good #f)) 1866 (lset-intersection (lambda (x y) 1867 (set! good (and (= x 1) (= y 2))) 1868 (= x y)) 1869 '(1) '(2)) 1870 good))) 1871 1872;; 1873;; lset-intersection! 1874;; 1875 1876(with-test-prefix "lset-intersection" 1877 1878 (pass-if "called arg order" 1879 (let ((good #f)) 1880 (lset-intersection (lambda (x y) 1881 (set! good (and (= x 1) (= y 2))) 1882 (= x y)) 1883 (list 1) (list 2)) 1884 good))) 1885 1886;; 1887;; lset-union 1888;; 1889 1890(with-test-prefix "lset-union" 1891 1892 (pass-if "no args" 1893 (eq? '() (lset-union eq?))) 1894 1895 (pass-if "one arg" 1896 (equal? '(1 2 3) (lset-union eq? '(1 2 3)))) 1897 1898 (pass-if "'() '()" 1899 (equal? '() (lset-union eq? '() '()))) 1900 1901 (pass-if "'() '(1 2 3)" 1902 (equal? '(1 2 3) (lset-union eq? '() '(1 2 3)))) 1903 1904 (pass-if "'(1 2 3) '()" 1905 (equal? '(1 2 3) (lset-union eq? '(1 2 3) '()))) 1906 1907 (pass-if "'(1 2 3) '(4 3 5)" 1908 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5)))) 1909 1910 (pass-if "'(1 2 3) '(4) '(3 5))" 1911 (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5)))) 1912 1913 ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong 1914 ;; way around 1915 (pass-if "called arg order" 1916 (let ((good #f)) 1917 (lset-union (lambda (x y) 1918 (set! good (and (= x 1) (= y 2))) 1919 (= x y)) 1920 '(1) '(2)) 1921 good))) 1922 1923;; 1924;; member 1925;; 1926 1927(with-test-prefix "member" 1928 1929 (pass-if-exception "no args" exception:wrong-num-args 1930 (member)) 1931 1932 (pass-if-exception "one arg" exception:wrong-num-args 1933 (member 1)) 1934 1935 (pass-if "1 (1 2 3)" 1936 (let ((lst '(1 2 3))) 1937 (eq? lst (member 1 lst)))) 1938 1939 (pass-if "2 (1 2 3)" 1940 (let ((lst '(1 2 3))) 1941 (eq? (cdr lst) (member 2 lst)))) 1942 1943 (pass-if "3 (1 2 3)" 1944 (let ((lst '(1 2 3))) 1945 (eq? (cddr lst) (member 3 lst)))) 1946 1947 (pass-if "4 (1 2 3)" 1948 (let ((lst '(1 2 3))) 1949 (eq? #f (member 4 lst)))) 1950 1951 (pass-if "called arg order" 1952 (let ((good #f)) 1953 (member 1 '(2) (lambda (x y) 1954 (set! good (and (eqv? 1 x) 1955 (eqv? 2 y))))) 1956 good))) 1957 1958;; 1959;; ninth 1960;; 1961 1962(with-test-prefix "ninth" 1963 (pass-if-exception "() -1" exception:wrong-type-arg 1964 (ninth '(a b c d e f g h))) 1965 (pass-if (eq? 'i (ninth '(a b c d e f g h i)))) 1966 (pass-if (eq? 'i (ninth '(a b c d e f g h i j))))) 1967 1968 1969;; 1970;; not-pair? 1971;; 1972 1973(with-test-prefix "not-pair?" 1974 (pass-if "inum" 1975 (eq? #t (not-pair? 123))) 1976 (pass-if "pair" 1977 (eq? #f (not-pair? '(x . y)))) 1978 (pass-if "symbol" 1979 (eq? #t (not-pair? 'x)))) 1980 1981;; 1982;; take 1983;; 1984 1985(with-test-prefix "take" 1986 1987 (pass-if "'() 0" 1988 (null? (take '() 0))) 1989 1990 (pass-if "'(a) 0" 1991 (null? (take '(a) 0))) 1992 1993 (pass-if "'(a b) 0" 1994 (null? (take '() 0))) 1995 1996 (pass-if "'(a b c) 0" 1997 (null? (take '() 0))) 1998 1999 (pass-if "'(a) 1" 2000 (let* ((lst '(a)) 2001 (got (take lst 1))) 2002 (and (equal? '(a) got) 2003 (not (eq? lst got))))) 2004 2005 (pass-if "'(a b) 1" 2006 (equal? '(a) 2007 (take '(a b) 1))) 2008 2009 (pass-if "'(a b c) 1" 2010 (equal? '(a) 2011 (take '(a b c) 1))) 2012 2013 (pass-if "'(a b) 2" 2014 (let* ((lst '(a b)) 2015 (got (take lst 2))) 2016 (and (equal? '(a b) got) 2017 (not (eq? lst got))))) 2018 2019 (pass-if "'(a b c) 2" 2020 (equal? '(a b) 2021 (take '(a b c) 2))) 2022 2023 (pass-if "circular '(a) 0" 2024 (equal? '() 2025 (take (circular-list 'a) 0))) 2026 2027 (pass-if "circular '(a) 1" 2028 (equal? '(a) 2029 (take (circular-list 'a) 1))) 2030 2031 (pass-if "circular '(a) 2" 2032 (equal? '(a a) 2033 (take (circular-list 'a) 2))) 2034 2035 (pass-if "circular '(a b) 5" 2036 (equal? '(a b a b a) 2037 (take (circular-list 'a 'b) 5))) 2038 2039 (pass-if "'(a . b) 1" 2040 (equal? '(a) 2041 (take '(a . b) 1))) 2042 2043 (pass-if "'(a b . c) 1" 2044 (equal? '(a) 2045 (take '(a b . c) 1))) 2046 2047 (pass-if "'(a b . c) 2" 2048 (equal? '(a b) 2049 (take '(a b . c) 2)))) 2050 2051;; 2052;; take-while 2053;; 2054 2055(with-test-prefix "take-while" 2056 2057 (pass-if (equal? '() (take-while odd? '()))) 2058 (pass-if (equal? '(1) (take-while odd? '(1)))) 2059 (pass-if (equal? '(1 3) (take-while odd? '(1 3)))) 2060 (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5)))) 2061 2062 (pass-if (equal? '() (take-while odd? '(2)))) 2063 (pass-if (equal? '(1) (take-while odd? '(1 2)))) 2064 (pass-if (equal? '(1 3) (take-while odd? '(1 3 4)))) 2065 2066 (pass-if (equal? '() (take-while odd? '(2 1)))) 2067 (pass-if (equal? '(1) (take-while odd? '(1 4 3)))) 2068 (pass-if (equal? '() (take-while odd? '(4 1 3))))) 2069 2070;; 2071;; take-while! 2072;; 2073 2074(with-test-prefix "take-while!" 2075 2076 (pass-if (equal? '() (take-while! odd? '()))) 2077 (pass-if (equal? '(1) (take-while! odd? (list 1)))) 2078 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3)))) 2079 (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5)))) 2080 2081 (pass-if (equal? '() (take-while! odd? (list 2)))) 2082 (pass-if (equal? '(1) (take-while! odd? (list 1 2)))) 2083 (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4)))) 2084 2085 (pass-if (equal? '() (take-while! odd? (list 2 1)))) 2086 (pass-if (equal? '(1) (take-while! odd? (list 1 4 3)))) 2087 (pass-if (equal? '() (take-while! odd? (list 4 1 3))))) 2088 2089;; 2090;; partition 2091;; 2092 2093(define (test-partition pred list kept-good dropped-good) 2094 (call-with-values (lambda () 2095 (partition pred list)) 2096 (lambda (kept dropped) 2097 (and (equal? kept kept-good) 2098 (equal? dropped dropped-good))))) 2099 2100(with-test-prefix "partition" 2101 2102 (pass-if "with dropped tail" 2103 (test-partition even? '(1 2 3 4 5 6 7) 2104 '(2 4 6) '(1 3 5 7))) 2105 2106 (pass-if "with kept tail" 2107 (test-partition even? '(1 2 3 4 5 6) 2108 '(2 4 6) '(1 3 5))) 2109 2110 (pass-if "with everything dropped" 2111 (test-partition even? '(1 3 5 7) 2112 '() '(1 3 5 7))) 2113 2114 (pass-if "with everything kept" 2115 (test-partition even? '(2 4 6) 2116 '(2 4 6) '())) 2117 2118 (pass-if "with empty list" 2119 (test-partition even? '() 2120 '() '())) 2121 2122 (pass-if "with reasonably long list" 2123 ;; the old implementation from SRFI-1 reference implementation 2124 ;; would signal a stack-overflow for a list of only 500 elements! 2125 (call-with-values (lambda () 2126 (partition even? 2127 (make-list 10000 1))) 2128 (lambda (even odd) 2129 (and (= (length odd) 10000) 2130 (= (length even) 0))))) 2131 2132 (pass-if-exception "with improper list" 2133 exception:wrong-type-arg 2134 (partition symbol? '(a b . c)))) 2135 2136;; 2137;; partition! 2138;; 2139 2140(define (test-partition! pred list kept-good dropped-good) 2141 (call-with-values (lambda () 2142 (partition! pred list)) 2143 (lambda (kept dropped) 2144 (and (equal? kept kept-good) 2145 (equal? dropped dropped-good))))) 2146 2147(with-test-prefix "partition!" 2148 2149 (pass-if "with dropped tail" 2150 (test-partition! even? (list 1 2 3 4 5 6 7) 2151 '(2 4 6) '(1 3 5 7))) 2152 2153 (pass-if "with kept tail" 2154 (test-partition! even? (list 1 2 3 4 5 6) 2155 '(2 4 6) '(1 3 5))) 2156 2157 (pass-if "with everything dropped" 2158 (test-partition! even? (list 1 3 5 7) 2159 '() '(1 3 5 7))) 2160 2161 (pass-if "with everything kept" 2162 (test-partition! even? (list 2 4 6) 2163 '(2 4 6) '())) 2164 2165 (pass-if "with empty list" 2166 (test-partition! even? '() 2167 '() '())) 2168 2169 (pass-if "with reasonably long list" 2170 ;; the old implementation from SRFI-1 reference implementation 2171 ;; would signal a stack-overflow for a list of only 500 elements! 2172 (call-with-values (lambda () 2173 (partition! even? 2174 (make-list 10000 1))) 2175 (lambda (even odd) 2176 (and (= (length odd) 10000) 2177 (= (length even) 0))))) 2178 2179 (pass-if-exception "with improper list" 2180 exception:wrong-type-arg 2181 (partition! symbol? (cons* 'a 'b 'c)))) 2182 2183;; 2184;; reduce 2185;; 2186 2187(with-test-prefix "reduce" 2188 2189 (pass-if "empty" 2190 (let* ((calls '()) 2191 (ret (reduce (lambda (x prev) 2192 (set! calls (cons (list x prev) calls)) 2193 x) 2194 1 '()))) 2195 (and (equal? calls '()) 2196 (equal? ret 1)))) 2197 2198 (pass-if "one elem" 2199 (let* ((calls '()) 2200 (ret (reduce (lambda (x prev) 2201 (set! calls (cons (list x prev) calls)) 2202 x) 2203 1 '(2)))) 2204 (and (equal? calls '()) 2205 (equal? ret 2)))) 2206 2207 (pass-if "two elems" 2208 (let* ((calls '()) 2209 (ret (reduce (lambda (x prev) 2210 (set! calls (cons (list x prev) calls)) 2211 x) 2212 1 '(2 3)))) 2213 (and (equal? calls '((3 2))) 2214 (equal? ret 3)))) 2215 2216 (pass-if "three elems" 2217 (let* ((calls '()) 2218 (ret (reduce (lambda (x prev) 2219 (set! calls (cons (list x prev) calls)) 2220 x) 2221 1 '(2 3 4)))) 2222 (and (equal? calls '((4 3) 2223 (3 2))) 2224 (equal? ret 4)))) 2225 2226 (pass-if "four elems" 2227 (let* ((calls '()) 2228 (ret (reduce (lambda (x prev) 2229 (set! calls (cons (list x prev) calls)) 2230 x) 2231 1 '(2 3 4 5)))) 2232 (and (equal? calls '((5 4) 2233 (4 3) 2234 (3 2))) 2235 (equal? ret 5))))) 2236 2237;; 2238;; reduce-right 2239;; 2240 2241(with-test-prefix "reduce-right" 2242 2243 (pass-if "empty" 2244 (let* ((calls '()) 2245 (ret (reduce-right (lambda (x prev) 2246 (set! calls (cons (list x prev) calls)) 2247 x) 2248 1 '()))) 2249 (and (equal? calls '()) 2250 (equal? ret 1)))) 2251 2252 (pass-if "one elem" 2253 (let* ((calls '()) 2254 (ret (reduce-right (lambda (x prev) 2255 (set! calls (cons (list x prev) calls)) 2256 x) 2257 1 '(2)))) 2258 (and (equal? calls '()) 2259 (equal? ret 2)))) 2260 2261 (pass-if "two elems" 2262 (let* ((calls '()) 2263 (ret (reduce-right (lambda (x prev) 2264 (set! calls (cons (list x prev) calls)) 2265 x) 2266 1 '(2 3)))) 2267 (and (equal? calls '((2 3))) 2268 (equal? ret 2)))) 2269 2270 (pass-if "three elems" 2271 (let* ((calls '()) 2272 (ret (reduce-right (lambda (x prev) 2273 (set! calls (cons (list x prev) calls)) 2274 x) 2275 1 '(2 3 4)))) 2276 (and (equal? calls '((2 3) 2277 (3 4))) 2278 (equal? ret 2)))) 2279 2280 (pass-if "four elems" 2281 (let* ((calls '()) 2282 (ret (reduce-right (lambda (x prev) 2283 (set! calls (cons (list x prev) calls)) 2284 x) 2285 1 '(2 3 4 5)))) 2286 (and (equal? calls '((2 3) 2287 (3 4) 2288 (4 5))) 2289 (equal? ret 2))))) 2290 2291;; 2292;; remove 2293;; 2294 2295(with-test-prefix "remove" 2296 2297 (pass-if (equal? '() (remove odd? '()))) 2298 (pass-if (equal? '() (remove odd? '(1)))) 2299 (pass-if (equal? '(2) (remove odd? '(2)))) 2300 2301 (pass-if (equal? '() (remove odd? '(1 3)))) 2302 (pass-if (equal? '(2) (remove odd? '(2 3)))) 2303 (pass-if (equal? '(2) (remove odd? '(1 2)))) 2304 (pass-if (equal? '(2 4) (remove odd? '(2 4)))) 2305 2306 (pass-if (equal? '() (remove odd? '(1 3 5)))) 2307 (pass-if (equal? '(2) (remove odd? '(2 3 5)))) 2308 (pass-if (equal? '(2) (remove odd? '(1 2 5)))) 2309 (pass-if (equal? '(2 4) (remove odd? '(2 4 5)))) 2310 2311 (pass-if (equal? '(6) (remove odd? '(1 3 6)))) 2312 (pass-if (equal? '(2 6) (remove odd? '(2 3 6)))) 2313 (pass-if (equal? '(2 6) (remove odd? '(1 2 6)))) 2314 (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6))))) 2315 2316;; 2317;; remove! 2318;; 2319 2320(with-test-prefix "remove!" 2321 2322 (pass-if (equal? '() (remove! odd? '()))) 2323 (pass-if (equal? '() (remove! odd? (list 1)))) 2324 (pass-if (equal? '(2) (remove! odd? (list 2)))) 2325 2326 (pass-if (equal? '() (remove! odd? (list 1 3)))) 2327 (pass-if (equal? '(2) (remove! odd? (list 2 3)))) 2328 (pass-if (equal? '(2) (remove! odd? (list 1 2)))) 2329 (pass-if (equal? '(2 4) (remove! odd? (list 2 4)))) 2330 2331 (pass-if (equal? '() (remove! odd? (list 1 3 5)))) 2332 (pass-if (equal? '(2) (remove! odd? (list 2 3 5)))) 2333 (pass-if (equal? '(2) (remove! odd? (list 1 2 5)))) 2334 (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5)))) 2335 2336 (pass-if (equal? '(6) (remove! odd? (list 1 3 6)))) 2337 (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6)))) 2338 (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6)))) 2339 (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6))))) 2340 2341;; 2342;; seventh 2343;; 2344 2345(with-test-prefix "seventh" 2346 (pass-if-exception "() -1" exception:wrong-type-arg 2347 (seventh '(a b c d e f))) 2348 (pass-if (eq? 'g (seventh '(a b c d e f g)))) 2349 (pass-if (eq? 'g (seventh '(a b c d e f g h))))) 2350 2351;; 2352;; sixth 2353;; 2354 2355(with-test-prefix "sixth" 2356 (pass-if-exception "() -1" exception:wrong-type-arg 2357 (sixth '(a b c d e))) 2358 (pass-if (eq? 'f (sixth '(a b c d e f)))) 2359 (pass-if (eq? 'f (sixth '(a b c d e f g))))) 2360 2361;; 2362;; split-at 2363;; 2364 2365(with-test-prefix "split-at" 2366 2367 (define (equal-values? lst thunk) 2368 (call-with-values thunk 2369 (lambda got 2370 (equal? lst got)))) 2371 2372 (pass-if-exception "() -1" exception:out-of-range 2373 (split-at '() -1)) 2374 (pass-if (equal-values? '(() ()) 2375 (lambda () (split-at '() 0)))) 2376 (pass-if-exception "() 1" exception:wrong-type-arg 2377 (split-at '() 1)) 2378 2379 (pass-if-exception "(1) -1" exception:out-of-range 2380 (split-at '(1) -1)) 2381 (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0)))) 2382 (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1)))) 2383 (pass-if-exception "(1) 2" exception:wrong-type-arg 2384 (split-at '(1) 2)) 2385 2386 (pass-if-exception "(4 5) -1" exception:out-of-range 2387 (split-at '(4 5) -1)) 2388 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0)))) 2389 (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1)))) 2390 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2)))) 2391 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 2392 (split-at '(4 5) 3)) 2393 2394 (pass-if-exception "(4 5 6) -1" exception:out-of-range 2395 (split-at '(4 5 6) -1)) 2396 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0)))) 2397 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1)))) 2398 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2)))) 2399 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3)))) 2400 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 2401 (split-at '(4 5 6) 4))) 2402 2403;; 2404;; split-at! 2405;; 2406 2407(with-test-prefix "split-at!" 2408 2409 (define (equal-values? lst thunk) 2410 (call-with-values thunk 2411 (lambda got 2412 (equal? lst got)))) 2413 2414 (pass-if-exception "() -1" exception:out-of-range 2415 (split-at! '() -1)) 2416 (pass-if (equal-values? '(() ()) 2417 (lambda () (split-at! '() 0)))) 2418 (pass-if-exception "() 1" exception:wrong-type-arg 2419 (split-at! '() 1)) 2420 2421 (pass-if-exception "(1) -1" exception:out-of-range 2422 (split-at! (list 1) -1)) 2423 (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0)))) 2424 (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1)))) 2425 (pass-if-exception "(1) 2" exception:wrong-type-arg 2426 (split-at! (list 1) 2)) 2427 2428 (pass-if-exception "(4 5) -1" exception:out-of-range 2429 (split-at! (list 4 5) -1)) 2430 (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0)))) 2431 (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1)))) 2432 (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2)))) 2433 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 2434 (split-at! (list 4 5) 3)) 2435 2436 (pass-if-exception "(4 5 6) -1" exception:out-of-range 2437 (split-at! (list 4 5 6) -1)) 2438 (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0)))) 2439 (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1)))) 2440 (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2)))) 2441 (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3)))) 2442 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 2443 (split-at! (list 4 5 6) 4))) 2444 2445;; 2446;; span 2447;; 2448 2449(with-test-prefix "span" 2450 2451 (define (test-span lst want-v1 want-v2) 2452 (call-with-values 2453 (lambda () 2454 (span positive? lst)) 2455 (lambda (got-v1 got-v2) 2456 (and (equal? got-v1 want-v1) 2457 (equal? got-v2 want-v2))))) 2458 2459 (pass-if "empty" 2460 (test-span '() '() '())) 2461 2462 (pass-if "y" 2463 (test-span '(1) '(1) '())) 2464 2465 (pass-if "n" 2466 (test-span '(-1) '() '(-1))) 2467 2468 (pass-if "yy" 2469 (test-span '(1 2) '(1 2) '())) 2470 2471 (pass-if "ny" 2472 (test-span '(-1 1) '() '(-1 1))) 2473 2474 (pass-if "yn" 2475 (test-span '(1 -1) '(1) '(-1))) 2476 2477 (pass-if "nn" 2478 (test-span '(-1 -2) '() '(-1 -2))) 2479 2480 (pass-if "yyy" 2481 (test-span '(1 2 3) '(1 2 3) '())) 2482 2483 (pass-if "nyy" 2484 (test-span '(-1 1 2) '() '(-1 1 2))) 2485 2486 (pass-if "yny" 2487 (test-span '(1 -1 2) '(1) '(-1 2))) 2488 2489 (pass-if "nny" 2490 (test-span '(-1 -2 1) '() '(-1 -2 1))) 2491 2492 (pass-if "yyn" 2493 (test-span '(1 2 -1) '(1 2) '(-1))) 2494 2495 (pass-if "nyn" 2496 (test-span '(-1 1 -2) '() '(-1 1 -2))) 2497 2498 (pass-if "ynn" 2499 (test-span '(1 -1 -2) '(1) '(-1 -2))) 2500 2501 (pass-if "nnn" 2502 (test-span '(-1 -2 -3) '() '(-1 -2 -3)))) 2503 2504;; 2505;; span! 2506;; 2507 2508(with-test-prefix "span!" 2509 2510 (define (test-span! lst want-v1 want-v2) 2511 (call-with-values 2512 (lambda () 2513 (span! positive? lst)) 2514 (lambda (got-v1 got-v2) 2515 (and (equal? got-v1 want-v1) 2516 (equal? got-v2 want-v2))))) 2517 2518 (pass-if "empty" 2519 (test-span! '() '() '())) 2520 2521 (pass-if "y" 2522 (test-span! (list 1) '(1) '())) 2523 2524 (pass-if "n" 2525 (test-span! (list -1) '() '(-1))) 2526 2527 (pass-if "yy" 2528 (test-span! (list 1 2) '(1 2) '())) 2529 2530 (pass-if "ny" 2531 (test-span! (list -1 1) '() '(-1 1))) 2532 2533 (pass-if "yn" 2534 (test-span! (list 1 -1) '(1) '(-1))) 2535 2536 (pass-if "nn" 2537 (test-span! (list -1 -2) '() '(-1 -2))) 2538 2539 (pass-if "yyy" 2540 (test-span! (list 1 2 3) '(1 2 3) '())) 2541 2542 (pass-if "nyy" 2543 (test-span! (list -1 1 2) '() '(-1 1 2))) 2544 2545 (pass-if "yny" 2546 (test-span! (list 1 -1 2) '(1) '(-1 2))) 2547 2548 (pass-if "nny" 2549 (test-span! (list -1 -2 1) '() '(-1 -2 1))) 2550 2551 (pass-if "yyn" 2552 (test-span! (list 1 2 -1) '(1 2) '(-1))) 2553 2554 (pass-if "nyn" 2555 (test-span! (list -1 1 -2) '() '(-1 1 -2))) 2556 2557 (pass-if "ynn" 2558 (test-span! (list 1 -1 -2) '(1) '(-1 -2))) 2559 2560 (pass-if "nnn" 2561 (test-span! (list -1 -2 -3) '() '(-1 -2 -3)))) 2562 2563;; 2564;; take! 2565;; 2566 2567(with-test-prefix "take!" 2568 2569 (pass-if-exception "() -1" exception:out-of-range 2570 (take! '() -1)) 2571 (pass-if (equal? '() (take! '() 0))) 2572 (pass-if-exception "() 1" exception:wrong-type-arg 2573 (take! '() 1)) 2574 2575 (pass-if-exception "(1) -1" exception:out-of-range 2576 (take! '(1) -1)) 2577 (pass-if (equal? '() (take! '(1) 0))) 2578 (pass-if (equal? '(1) (take! '(1) 1))) 2579 (pass-if-exception "(1) 2" exception:wrong-type-arg 2580 (take! '(1) 2)) 2581 2582 (pass-if-exception "(4 5) -1" exception:out-of-range 2583 (take! '(4 5) -1)) 2584 (pass-if (equal? '() (take! '(4 5) 0))) 2585 (pass-if (equal? '(4) (take! '(4 5) 1))) 2586 (pass-if (equal? '(4 5) (take! '(4 5) 2))) 2587 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 2588 (take! '(4 5) 3)) 2589 2590 (pass-if-exception "(4 5 6) -1" exception:out-of-range 2591 (take! '(4 5 6) -1)) 2592 (pass-if (equal? '() (take! '(4 5 6) 0))) 2593 (pass-if (equal? '(4) (take! '(4 5 6) 1))) 2594 (pass-if (equal? '(4 5) (take! '(4 5 6) 2))) 2595 (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3))) 2596 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 2597 (take! '(4 5 6) 4))) 2598 2599 2600;; 2601;; take-right 2602;; 2603 2604(with-test-prefix "take-right" 2605 2606 (pass-if-exception "() -1" exception:out-of-range 2607 (take-right '() -1)) 2608 (pass-if (equal? '() (take-right '() 0))) 2609 (pass-if-exception "() 1" exception:wrong-type-arg 2610 (take-right '() 1)) 2611 2612 (pass-if-exception "(1) -1" exception:out-of-range 2613 (take-right '(1) -1)) 2614 (pass-if (equal? '() (take-right '(1) 0))) 2615 (pass-if (equal? '(1) (take-right '(1) 1))) 2616 (pass-if-exception "(1) 2" exception:wrong-type-arg 2617 (take-right '(1) 2)) 2618 2619 (pass-if-exception "(4 5) -1" exception:out-of-range 2620 (take-right '(4 5) -1)) 2621 (pass-if (equal? '() (take-right '(4 5) 0))) 2622 (pass-if (equal? '(5) (take-right '(4 5) 1))) 2623 (pass-if (equal? '(4 5) (take-right '(4 5) 2))) 2624 (pass-if-exception "(4 5) 3" exception:wrong-type-arg 2625 (take-right '(4 5) 3)) 2626 2627 (pass-if-exception "(4 5 6) -1" exception:out-of-range 2628 (take-right '(4 5 6) -1)) 2629 (pass-if (equal? '() (take-right '(4 5 6) 0))) 2630 (pass-if (equal? '(6) (take-right '(4 5 6) 1))) 2631 (pass-if (equal? '(5 6) (take-right '(4 5 6) 2))) 2632 (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3))) 2633 (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg 2634 (take-right '(4 5 6) 4)) 2635 2636 (pass-if "(a b . c) 0" 2637 (equal? (take-right '(a b . c) 0) 'c)) 2638 (pass-if "(a b . c) 1" 2639 (equal? (take-right '(a b . c) 1) '(b . c)))) 2640 2641;; 2642;; tenth 2643;; 2644 2645(with-test-prefix "tenth" 2646 (pass-if-exception "() -1" exception:wrong-type-arg 2647 (tenth '(a b c d e f g h i))) 2648 (pass-if (eq? 'j (tenth '(a b c d e f g h i j)))) 2649 (pass-if (eq? 'j (tenth '(a b c d e f g h i j k))))) 2650 2651;; 2652;; xcons 2653;; 2654 2655(with-test-prefix "xcons" 2656 (pass-if (equal? '(y . x) (xcons 'x 'y)))) 2657