diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 236905e28..fa5fde685 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -20,588 +20,23 @@ (use-modules (srfi srfi-1) (test-suite lib)) -(define (ref-delete x lst . proc) - "Reference implemenation of srfi-1 `delete'." - (set! proc (if (null? proc) equal? (car proc))) - (do ((ret '()) - (lst lst (cdr lst))) - ((null? lst) - (reverse! ret)) - (if (not (proc x (car lst))) - (set! ret (cons (car lst) ret))))) - -(define (ref-delete-duplicates lst . proc) - "Reference implemenation of srfi-1 `delete-duplicates'." - (set! proc (if (null? proc) equal? (car proc))) - (if (null? lst) - '() - (do ((keep '())) - ((null? lst) - (reverse! keep)) - (let ((elem (car lst))) - (set! keep (cons elem keep)) - (set! lst (ref-delete elem lst proc)))))) - - -;; -;; concatenate and concatenate! -;; - -(let () - (define (common-tests concatenate-proc unmodified?) - (define (try lstlst want) - (let ((lstlst-copy (copy-tree lstlst)) - (got (concatenate-proc lstlst))) - (if unmodified? - (if (not (equal? lstlst lstlst-copy)) - (error "input lists modified"))) - (equal? got want))) - - (pass-if-exception "too few args" exception:wrong-num-args - (concatenate-proc)) - - (pass-if-exception "too many args" exception:wrong-num-args - (concatenate-proc '() '())) - - (pass-if "no lists" - (try '() '())) - - (pass-if (try '((1)) '(1))) - (pass-if (try '((1 2)) '(1 2))) - (pass-if (try '(() (1)) '(1))) - (pass-if (try '(() () (1)) '(1))) - - (pass-if (try '((1) (2)) '(1 2))) - (pass-if (try '(() (1 2)) '(1 2))) - - (pass-if (try '((1) 2) '(1 . 2))) - (pass-if (try '((1) (2) 3) '(1 2 . 3))) - (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4))) - ) - - (with-test-prefix "concatenate" - (common-tests concatenate #t)) - - (with-test-prefix "concatenate!" - (common-tests concatenate! #f))) - -;; -;; count -;; - -(with-test-prefix "count" - (pass-if-exception "no args" exception:wrong-num-args - (count)) - - (pass-if-exception "one arg" exception:wrong-num-args - (count noop)) - - (with-test-prefix "one list" - (define (or1 x) - x) - - (pass-if "empty list" (= 0 (count or1 '()))) - - (pass-if-exception "pred arg count 0" exception:wrong-type-arg - (count (lambda () x) '(1 2 3))) - (pass-if-exception "pred arg count 2" exception:wrong-type-arg - (count (lambda (x y) x) '(1 2 3))) - - (pass-if-exception "improper 1" exception:wrong-type-arg - (count or1 1)) - (pass-if-exception "improper 2" exception:wrong-type-arg - (count or1 '(1 . 2))) - (pass-if-exception "improper 3" exception:wrong-type-arg - (count or1 '(1 2 . 3))) - - (pass-if (= 0 (count or1 '(#f)))) - (pass-if (= 1 (count or1 '(#t)))) - - (pass-if (= 0 (count or1 '(#f #f)))) - (pass-if (= 1 (count or1 '(#f #t)))) - (pass-if (= 1 (count or1 '(#t #f)))) - (pass-if (= 2 (count or1 '(#t #t)))) - - (pass-if (= 0 (count or1 '(#f #f #f)))) - (pass-if (= 1 (count or1 '(#f #f #t)))) - (pass-if (= 1 (count or1 '(#t #f #f)))) - (pass-if (= 2 (count or1 '(#t #f #t)))) - (pass-if (= 3 (count or1 '(#t #t #t))))) - - (with-test-prefix "two lists" - (define (or2 x y) - (or x y)) - - (pass-if "arg order" - (= 1 (count (lambda (x y) - (and (= 1 x) - (= 2 y))) - '(1) '(2)))) - - (pass-if "empty lists" (= 0 (count or2 '() '()))) - - (pass-if-exception "pred arg count 0" exception:wrong-type-arg - (count (lambda () #t) '(1 2 3) '(1 2 3))) - (pass-if-exception "pred arg count 1" exception:wrong-type-arg - (count (lambda (x) x) '(1 2 3) '(1 2 3))) - (pass-if-exception "pred arg count 3" exception:wrong-type-arg - (count (lambda (x y z) x) '(1 2 3) '(1 2 3))) - - (pass-if-exception "improper first 1" exception:wrong-type-arg - (count or2 1 '(1 2 3))) - (pass-if-exception "improper first 2" exception:wrong-type-arg - (count or2 '(1 . 2) '(1 2 3))) - (pass-if-exception "improper first 3" exception:wrong-type-arg - (count or2 '(1 2 . 3) '(1 2 3))) - - (pass-if-exception "improper second 1" exception:wrong-type-arg - (count or2 '(1 2 3) 1)) - (pass-if-exception "improper second 2" exception:wrong-type-arg - (count or2 '(1 2 3) '(1 . 2))) - (pass-if-exception "improper second 3" exception:wrong-type-arg - (count or2 '(1 2 3) '(1 2 . 3))) - - (pass-if (= 0 (count or2 '(#f) '(#f)))) - (pass-if (= 1 (count or2 '(#t) '(#f)))) - (pass-if (= 1 (count or2 '(#f) '(#t)))) - - (pass-if (= 0 (count or2 '(#f #f) '(#f #f)))) - (pass-if (= 1 (count or2 '(#t #f) '(#t #f)))) - (pass-if (= 2 (count or2 '(#t #t) '(#f #f)))) - (pass-if (= 2 (count or2 '(#t #f) '(#f #t)))) - - (with-test-prefix "stop shortest" - (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t)))) - (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t)))) - (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t)))) - (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t)))))) - - (with-test-prefix "three lists" - (define (or3 x y z) - (or x y z)) - - (pass-if "arg order" - (= 1 (count (lambda (x y z) - (and (= 1 x) - (= 2 y) - (= 3 z))) - '(1) '(2) '(3)))) - - (pass-if "empty lists" (= 0 (count or3 '() '() '()))) - - ;; currently bad pred argument gives wrong-num-args when 3 or more - ;; lists, as opposed to wrong-type-arg for 1 or 2 lists - (pass-if-exception "pred arg count 0" exception:wrong-num-args - (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) - (pass-if-exception "pred arg count 2" exception:wrong-num-args - (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) - (pass-if-exception "pred arg count 4" exception:wrong-num-args - (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) - - (pass-if-exception "improper first 1" exception:wrong-type-arg - (count or3 1 '(1 2 3) '(1 2 3))) - (pass-if-exception "improper first 2" exception:wrong-type-arg - (count or3 '(1 . 2) '(1 2 3) '(1 2 3))) - (pass-if-exception "improper first 3" exception:wrong-type-arg - (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3))) - - (pass-if-exception "improper second 1" exception:wrong-type-arg - (count or3 '(1 2 3) 1 '(1 2 3))) - (pass-if-exception "improper second 2" exception:wrong-type-arg - (count or3 '(1 2 3) '(1 . 2) '(1 2 3))) - (pass-if-exception "improper second 3" exception:wrong-type-arg - (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3))) - - (pass-if-exception "improper third 1" exception:wrong-type-arg - (count or3 '(1 2 3) '(1 2 3) 1)) - (pass-if-exception "improper third 2" exception:wrong-type-arg - (count or3 '(1 2 3) '(1 2 3) '(1 . 2))) - (pass-if-exception "improper third 3" exception:wrong-type-arg - (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3))) - - (pass-if (= 0 (count or3 '(#f) '(#f) '(#f)))) - (pass-if (= 1 (count or3 '(#t) '(#f) '(#f)))) - (pass-if (= 1 (count or3 '(#f) '(#t) '(#f)))) - (pass-if (= 1 (count or3 '(#f) '(#f) '(#t)))) - - (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f)))) - - (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f)))) - (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f)))) - (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f)))) - (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f)))) - (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f)))) - (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t)))) - - (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f)))) - (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f)))) - (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t)))) - (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t)))) - - (with-test-prefix "stop shortest" - (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t)))) - (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t)))) - (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '()))) - - (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t)))) - (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t)))) - (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t))))))) - -;; -;; delete and delete! -;; - -(let () - ;; Call (PROC lst) for all lists of length up to 6, with all combinations - ;; of elements to be retained or deleted. Elements to retain are numbers, - ;; 0 upwards. Elements to be deleted are #f. - (define (test-lists proc) - (do ((n 0 (1+ n))) - ((>= n 6)) - (do ((limit (ash 1 n)) - (i 0 (1+ i))) - ((>= i limit)) - (let ((lst '())) - (do ((bit 0 (1+ bit))) - ((>= bit n)) - (set! lst (cons (if (logbit? bit i) bit #f) lst))) - (proc lst))))) - - (define (common-tests delete-proc) - (pass-if-exception "too few args" exception:wrong-num-args - (delete-proc 0)) - - (pass-if-exception "too many args" exception:wrong-num-args - (delete-proc 0 '() equal? 99)) - - (pass-if "empty" - (eq? '() (delete-proc 0 '()))) - - (pass-if "equal? (the default)" - (equal? '((1) (3)) - (delete-proc '(2) '((1) (2) (3))))) - - (pass-if "eq?" - (equal? '((1) (2) (3)) - (delete-proc '(2) '((1) (2) (3)) eq?))) - - (pass-if "called arg order" - (equal? '(1 2 3) - (delete-proc 3 '(1 2 3 4 5) <)))) - - (with-test-prefix "delete" - (common-tests delete) - - (test-lists - (lambda (lst) - (let ((lst-copy (list-copy lst))) - (with-test-prefix lst-copy - (pass-if "result" - (equal? (delete #f lst) - (ref-delete #f lst))) - (pass-if "non-destructive" - (equal? lst-copy lst))))))) - - (with-test-prefix "delete!" - (common-tests delete!) - - (test-lists - (lambda (lst) - (pass-if lst - (equal? (delete! #f lst) - (ref-delete #f lst))))))) - -;; -;; delete-duplicates and delete-duplicates! -;; - -(let () - ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all - ;; combinations of numbers 1 to n in the elements - (define (test-lists proc) - (do ((n 1 (1+ n))) - ((> n 4)) - (do ((limit (integer-expt n n)) - (i 0 (1+ i))) - ((>= i limit)) - (let ((lst '())) - (do ((j 0 (1+ j)) - (rem i (quotient rem n))) - ((>= j n)) - (set! lst (cons (remainder rem n) lst))) - (proc lst))))) - - (define (common-tests delete-duplicates-proc) - (pass-if-exception "too few args" exception:wrong-num-args - (delete-duplicates-proc)) - - (pass-if-exception "too many args" exception:wrong-num-args - (delete-duplicates-proc '() equal? 99)) - - (pass-if "empty" - (eq? '() (delete-duplicates-proc '()))) - - (pass-if "equal? (the default)" - (equal? '((2)) - (delete-duplicates-proc '((2) (2) (2))))) - - (pass-if "eq?" - (equal? '((2) (2) (2)) - (delete-duplicates-proc '((2) (2) (2)) eq?))) - - (pass-if "called arg order" - (let ((ok #t)) - (delete-duplicates-proc '(1 2 3 4 5) - (lambda (x y) - (if (> x y) - (set! ok #f)) - #f)) - ok))) - - (with-test-prefix "delete-duplicates" - (common-tests delete-duplicates) - - (test-lists - (lambda (lst) - (let ((lst-copy (list-copy lst))) - (with-test-prefix lst-copy - (pass-if "result" - (equal? (delete-duplicates lst) - (ref-delete-duplicates lst))) - (pass-if "non-destructive" - (equal? lst-copy lst))))))) - - (with-test-prefix "delete-duplicates!" - (common-tests delete-duplicates!) - - (test-lists - (lambda (lst) - (pass-if lst - (equal? (delete-duplicates! lst) - (ref-delete-duplicates lst))))))) - -;; -;; drop -;; - -(with-test-prefix "drop" - - (pass-if "'() 0" - (null? (drop '() 0))) - - (pass-if "'(a) 0" - (let ((lst '(a))) - (eq? lst - (drop lst 0)))) - - (pass-if "'(a b) 0" - (let ((lst '(a b))) - (eq? lst - (drop lst 0)))) - - (pass-if "'(a) 1" - (let ((lst '(a))) - (eq? (cdr lst) - (drop lst 1)))) - - (pass-if "'(a b) 1" - (let ((lst '(a b))) - (eq? (cdr lst) - (drop lst 1)))) - - (pass-if "'(a b) 2" - (let ((lst '(a b))) - (eq? (cddr lst) - (drop lst 2)))) - - (pass-if "'(a b c) 1" - (let ((lst '(a b c))) - (eq? (cddr lst) - (drop lst 2)))) - - (pass-if "circular '(a) 0" - (let ((lst (circular-list 'a))) - (eq? lst - (drop lst 0)))) - - (pass-if "circular '(a) 1" - (let ((lst (circular-list 'a))) - (eq? lst - (drop lst 1)))) - - (pass-if "circular '(a) 2" - (let ((lst (circular-list 'a))) - (eq? lst - (drop lst 1)))) - - (pass-if "circular '(a b) 1" - (let ((lst (circular-list 'a))) - (eq? (cdr lst) - (drop lst 0)))) - - (pass-if "circular '(a b) 2" - (let ((lst (circular-list 'a))) - (eq? lst - (drop lst 1)))) - - (pass-if "circular '(a b) 5" - (let ((lst (circular-list 'a))) - (eq? (cdr lst) - (drop lst 5)))) - - (pass-if "'(a . b) 1" - (eq? 'b - (drop '(a . b) 1))) - - (pass-if "'(a b . c) 1" - (equal? 'c - (drop '(a b . c) 2)))) - -;; -;; length+ -;; - -(with-test-prefix "length+" - (pass-if-exception "too few args" exception:wrong-num-args - (length+)) - (pass-if-exception "too many args" exception:wrong-num-args - (length+ 123 456)) - (pass-if (= 0 (length+ '()))) - (pass-if (= 1 (length+ '(x)))) - (pass-if (= 2 (length+ '(x y)))) - (pass-if (= 3 (length+ '(x y z)))) - (pass-if (not (length+ (circular-list 1)))) - (pass-if (not (length+ (circular-list 1 2)))) - (pass-if (not (length+ (circular-list 1 2 3))))) - ;; ;; list-copy ;; (with-test-prefix "list-copy" - (pass-if (equal? '() (list-copy '()))) - (pass-if (equal? '(1 2) (list-copy '(1 2)))) - (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) - (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) - (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) ;; improper lists can be copied - (pass-if (equal? 1 (list-copy 1))) - (pass-if (equal? '(1 . 2) (list-copy '(1 . 2)))) - (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) - (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) - (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))) - -;; -;; take -;; - -(with-test-prefix "take" + (pass-if "empty" (equal? '() (list-copy '()))) + (pass-if "one" (equal? '(1) (list-copy '(1)))) + (pass-if "two" (equal? '(1 2) (list-copy '(1 2)))) + (pass-if "three" (equal? '(1 2 3) (list-copy '(1 2 3)))) + (pass-if "four" (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) + (pass-if "five" (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) - (pass-if "'() 0" - (null? (take '() 0))) - - (pass-if "'(a) 0" - (null? (take '(a) 0))) - - (pass-if "'(a b) 0" - (null? (take '() 0))) - - (pass-if "'(a b c) 0" - (null? (take '() 0))) - - (pass-if "'(a) 1" - (let* ((lst '(a)) - (got (take lst 1))) - (and (equal? '(a) got) - (not (eq? lst got))))) - - (pass-if "'(a b) 1" - (equal? '(a) - (take '(a b) 1))) - - (pass-if "'(a b c) 1" - (equal? '(a) - (take '(a b c) 1))) - - (pass-if "'(a b) 2" - (let* ((lst '(a b)) - (got (take lst 2))) - (and (equal? '(a b) got) - (not (eq? lst got))))) - - (pass-if "'(a b c) 2" - (equal? '(a b) - (take '(a b c) 2))) - - (pass-if "circular '(a) 0" - (equal? '() - (take (circular-list 'a) 0))) - - (pass-if "circular '(a) 1" - (equal? '(a) - (take (circular-list 'a) 1))) - - (pass-if "circular '(a) 2" - (equal? '(a a) - (take (circular-list 'a) 2))) - - (pass-if "circular '(a b) 5" - (equal? '(a b a b a) - (take (circular-list 'a 'b) 5))) - - (pass-if "'(a . b) 1" - (equal? '(a) - (take '(a . b) 1))) - - (pass-if "'(a b . c) 1" - (equal? '(a) - (take '(a b . c) 1))) - - (pass-if "'(a b . c) 2" - (equal? '(a b) - (take '(a b . c) 2)))) - -;; -;; partition -;; - -(define (test-partition pred list kept-good dropped-good) - (call-with-values (lambda () - (partition pred list)) - (lambda (kept dropped) - (and (equal? kept kept-good) - (equal? dropped dropped-good))))) - -(with-test-prefix "partition" - - (pass-if "with dropped tail" - (test-partition even? '(1 2 3 4 5 6 7) - '(2 4 6) '(1 3 5 7))) - - (pass-if "with kept tail" - (test-partition even? '(1 2 3 4 5 6) - '(2 4 6) '(1 3 5))) - - (pass-if "with everything dropped" - (test-partition even? '(1 3 5 7) - '() '(1 3 5 7))) - - (pass-if "with everything kept" - (test-partition even? '(2 4 6) - '(2 4 6) '())) - - (pass-if "with empty list" - (test-partition even? '() - '() '())) - - (pass-if "with reasonably long list" - ;; the old implementation from SRFI-1 reference implementation - ;; would signal a stack-overflow for a list of only 500 elements! - (call-with-values (lambda () - (partition even? - (make-list 10000 1))) - (lambda (even odd) - (and (= (length odd) 10000) - (= (length even) 0)))))) - + ;; improper lists can be copied + (pass-if "one improper" (equal? 1 (list-copy 1))) + (pass-if "two improper" (equal? '(1 . 2) (list-copy '(1 . 2)))) + (pass-if "three improper" (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) + (pass-if "four improper" (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) + (pass-if "five improper" (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))