diff options
Diffstat (limited to 'test-suite/tests/list.test')
-rw-r--r-- | test-suite/tests/list.test | 709 |
1 files changed, 709 insertions, 0 deletions
diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test new file mode 100644 index 000000000..ff31c8605 --- /dev/null +++ b/test-suite/tests/list.test @@ -0,0 +1,709 @@ +;;;; list.test --- tests guile's lists -*- scheme -*- +;;;; Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(use-modules (test-suite lib) + (ice-9 documentation)) + + +;;; +;;; miscellaneous +;;; + +(define (documented? object) + (not (not (object-documentation object)))) + +;; +;; This unique tag is reserved for the unroll and diff-unrolled functions. +;; + +(define circle-indicator + (cons 'circle 'indicator)) + +;; +;; Extract every single scheme object that is contained within OBJ into a new +;; data structure. That means, if OBJ somewhere contains a pair, the newly +;; created structure holds a reference to the pair as well as references to +;; the car and cdr of that pair. For vectors, the newly created structure +;; holds a reference to that vector as well as references to every element of +;; that vector. Since this is done recursively, the original data structure +;; is deeply unrolled. If there are circles within the original data +;; structures, every reference that points backwards into the data structure +;; is denoted by storing the circle-indicator tag as well as the object the +;; circular reference points to. +;; + +(define (unroll obj) + (let unroll* ((objct obj) + (hist '())) + (reverse! + (let loop ((object objct) + (histry hist) + (result '())) + (if (memq object histry) + (cons (cons circle-indicator object) result) + (let ((history (cons object histry))) + (cond ((pair? object) + (loop (cdr object) history + (cons (cons object (unroll* (car object) history)) + result))) + ((vector? object) + (cons (cons object + (map (lambda (x) + (unroll* x history)) + (vector->list object))) + result)) + (else (cons object result))))))))) + +;; +;; Compare two data-structures that were generated with unroll. If any of the +;; elements found not to be eq?, return a pair that holds the position of the +;; first found differences of the two data structures. If all elements are +;; found to be eq?, #f is returned. +;; + +(define (diff-unrolled a b) + (cond ;; has everything been compared already? + ((and (null? a) (null? b)) + #f) + ;; do both structures still contain elements? + ((and (pair? a) (pair? b)) + (cond ;; are the next elements both plain objects? + ((and (not (pair? (car a))) (not (pair? (car b)))) + (if (eq? (car a) (car b)) + (diff-unrolled (cdr a) (cdr b)) + (cons a b))) + ;; are the next elements both container objects? + ((and (pair? (car a)) (pair? (car b))) + (if (eq? (caar a) (caar b)) + (cond ;; do both objects close a circular structure? + ((eq? circle-indicator (caar a)) + (if (eq? (cdar a) (cdar b)) + (diff-unrolled (cdr a) (cdr b)) + (cons a b))) + ;; do both objects hold a vector? + ((vector? (caar a)) + (or (let loop ((a1 (cdar a)) (b1 (cdar b))) + (cond + ((and (null? a1) (null? b1)) + #f) + ((and (pair? a1) (pair? b1)) + (or (diff-unrolled (car a1) (car b1)) + (loop (cdr a1) (cdr b1)))) + (else + (cons a1 b1)))) + (diff-unrolled (cdr a) (cdr b)))) + ;; do both objects hold a pair? + (else + (or (diff-unrolled (cdar a) (cdar b)) + (diff-unrolled (cdr a) (cdr b))))) + (cons a b))) + (else + (cons a b)))) + (else + (cons a b)))) + +;;; list + +(with-test-prefix "list" + + (pass-if "documented?" + (documented? list)) + + ;; in guile 1.6.7 and earlier `list' called using `apply' didn't make a + ;; new list, it just returned the given list + (pass-if "apply gets fresh list" + (let* ((x '(1 2 3)) + (y (apply list x))) + (not (eq? x y))))) + +;;; make-list + +(with-test-prefix "make-list" + + (pass-if "documented?" + (documented? make-list)) + + (with-test-prefix "no init" + (pass-if "0" + (equal? '() (make-list 0))) + (pass-if "1" + (equal? '(()) (make-list 1))) + (pass-if "2" + (equal? '(() ()) (make-list 2))) + (pass-if "3" + (equal? '(() () ()) (make-list 3)))) + + (with-test-prefix "with init" + (pass-if "0" + (equal? '() (make-list 0 'foo))) + (pass-if "1" + (equal? '(foo) (make-list 1 'foo))) + (pass-if "2" + (equal? '(foo foo) (make-list 2 'foo))) + (pass-if "3" + (equal? '(foo foo foo) (make-list 3 'foo))))) + +;;; cons* + +(with-test-prefix "cons*" + + (pass-if "documented?" + (documented? list)) + + (with-test-prefix "one arg" + (pass-if "empty list" + (eq? '() (cons* '()))) + (pass-if "one elem list" + (let* ((lst '(1))) + (eq? lst (cons* lst)))) + (pass-if "two elem list" + (let* ((lst '(1 2))) + (eq? lst (cons* lst))))) + + (with-test-prefix "two args" + (pass-if "empty list" + (equal? '(1) (cons* 1 '()))) + (pass-if "one elem list" + (let* ((lst '(1)) + (ret (cons* 2 lst))) + (and (equal? '(2 1) ret) + (eq? lst (cdr ret))))) + (pass-if "two elem list" + (let* ((lst '(1 2)) + (ret (cons* 3 lst))) + (and (equal? '(3 1 2) ret) + (eq? lst (cdr ret)))))) + + (with-test-prefix "three args" + (pass-if "empty list" + (equal? '(1 2) (cons* 1 2 '()))) + (pass-if "one elem list" + (let* ((lst '(1)) + (ret (cons* 2 3 lst))) + (and (equal? '(2 3 1) ret) + (eq? lst (cddr ret))))) + (pass-if "two elem list" + (let* ((lst '(1 2)) + (ret (cons* 3 4 lst))) + (and (equal? '(3 4 1 2) ret) + (eq? lst (cddr ret)))))) + + ;; in guile 1.6.7 and earlier `cons*' called using `apply' modified its + ;; list argument + (pass-if "apply list unchanged" + (let* ((lst '(1 2 (3 4))) + (ret (apply cons* lst))) + (and (equal? lst '(1 2 (3 4))) + (equal? ret '(1 2 3 4)))))) + +;;; null? + + +;;; list? + + +;;; length + + +;;; append + + +;;; +;;; append! +;;; + +(with-test-prefix "append!" + + (pass-if "documented?" + (documented? append!)) + + ;; Is the handling of empty lists as arguments correct? + + (pass-if "no arguments" + (eq? (append!) + '())) + + (pass-if "empty list argument" + (eq? (append! '()) + '())) + + (pass-if "some empty list arguments" + (eq? (append! '() '() '()) + '())) + + ;; Does the last non-empty-list argument remain unchanged? + + (pass-if "some empty lists with non-empty list" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (tst (append! '() '() '() foo)) + (tst-unrolled (unroll tst))) + (and (eq? tst foo) + (not (diff-unrolled foo-unrolled tst-unrolled))))) + + (pass-if "some empty lists with improper list" + (let* ((foo (cons 1 2)) + (foo-unrolled (unroll foo)) + (tst (append! '() '() '() foo)) + (tst-unrolled (unroll tst))) + (and (eq? tst foo) + (not (diff-unrolled foo-unrolled tst-unrolled))))) + + (pass-if "some empty lists with circular list" + (let ((foo (list 1 2))) + (set-cdr! (cdr foo) (cdr foo)) + (let* ((foo-unrolled (unroll foo)) + (tst (append! '() '() '() foo)) + (tst-unrolled (unroll tst))) + (and (eq? tst foo) + (not (diff-unrolled foo-unrolled tst-unrolled)))))) + + (pass-if "some empty lists with non list object" + (let* ((foo (vector 1 2 3)) + (foo-unrolled (unroll foo)) + (tst (append! '() '() '() foo)) + (tst-unrolled (unroll tst))) + (and (eq? tst foo) + (not (diff-unrolled foo-unrolled tst-unrolled))))) + + (pass-if "non-empty list between empty lists" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (tst (append! '() '() '() foo '() '() '())) + (tst-unrolled (unroll tst))) + (and (eq? tst foo) + (not (diff-unrolled foo-unrolled tst-unrolled))))) + + ;; Are arbitrary lists append!ed correctly? + + (pass-if "two one-element lists" + (let* ((foo (list 1)) + (foo-unrolled (unroll foo)) + (bar (list 2)) + (bar-unrolled (unroll bar)) + (tst (append! foo bar)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) + + (pass-if "three one-element lists" + (let* ((foo (list 1)) + (foo-unrolled (unroll foo)) + (bar (list 2)) + (bar-unrolled (unroll bar)) + (baz (list 3)) + (baz-unrolled (unroll baz)) + (tst (append! foo bar baz)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 3)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (let* ((tst-unrolled-2 (cdr diff-foo-tst)) + (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) + (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) + (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) + + (pass-if "two two-element lists" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (list 3 4)) + (bar-unrolled (unroll bar)) + (tst (append! foo bar)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 3 4)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) + + (pass-if "three two-element lists" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (list 3 4)) + (bar-unrolled (unroll bar)) + (baz (list 5 6)) + (baz-unrolled (unroll baz)) + (tst (append! foo bar baz)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 3 4 5 6)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (let* ((tst-unrolled-2 (cdr diff-foo-tst)) + (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) + (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) + (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) + + (pass-if "empty list between non-empty lists" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (list 3 4)) + (bar-unrolled (unroll bar)) + (baz (list 5 6)) + (baz-unrolled (unroll baz)) + (tst (append! foo '() bar '() '() baz '() '() '())) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 3 4 5 6)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (let* ((tst-unrolled-2 (cdr diff-foo-tst)) + (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) + (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) + (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) + + (pass-if "list and improper list" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (cons 3 4)) + (bar-unrolled (unroll bar)) + (tst (append! foo bar)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 3 . 4)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) + + (pass-if "list and circular list" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (list 3 4 5))) + (set-cdr! (cddr bar) (cdr bar)) + (let* ((bar-unrolled (unroll bar)) + (tst (append! foo bar)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) + (iota 9) + '(1 2 3 4 5 4 5 4 5)) + '(#t #t #t #t #t #t #t #t #t)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))) + + (pass-if "list and non list object" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (bar (vector 3 4)) + (bar-unrolled (unroll bar)) + (tst (append! foo bar)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? tst '(1 2 . #(3 4))) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) + + (pass-if "several arbitrary lists" + (equal? (append! (list 1 2) + (list (list 3) 4) + (list (list 5) (list 6)) + (list 7 (cons 8 9)) + (list 10 11) + (list (cons 12 13) 14) + (list (list))) + (list 1 2 + (list 3) 4 + (list 5) (list 6) + 7 (cons 8 9) + 10 11 + (cons 12 13) + 14 (list)))) + + (pass-if "list to itself" + (let* ((foo (list 1 2)) + (foo-unrolled (unroll foo)) + (tst (append! foo foo)) + (tst-unrolled (unroll tst)) + (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) + (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) + (iota 6) + '(1 2 1 2 1 2)) + '(#t #t #t #t #t #t)) + (not (diff-unrolled (car diff-foo-tst) (unroll '()))) + (eq? (caar (cdr diff-foo-tst)) circle-indicator) + (eq? (cdar (cdr diff-foo-tst)) foo)))) + + ;; Are wrong type arguments detected correctly? + + (with-test-prefix "wrong argument" + + (pass-if-exception "improper list and empty list" + exception:wrong-type-arg + (append! (cons 1 2) '())) + + (pass-if-exception "improper list and list" + exception:wrong-type-arg + (append! (cons 1 2) (list 3 4))) + + (pass-if-exception "list, improper list and list" + exception:wrong-type-arg + (append! (list 1 2) (cons 3 4) (list 5 6))) + + (expect-fail "circular list and empty list" + (let ((foo (list 1 2 3))) + (set-cdr! (cddr foo) (cdr foo)) + (catch #t + (lambda () + (catch 'wrong-type-arg + (lambda () + (append! foo '()) + #f) + (lambda (key . args) + #t))) + (lambda (key . args) + #f)))) + + (expect-fail "circular list and list" + (let ((foo (list 1 2 3))) + (set-cdr! (cddr foo) (cdr foo)) + (catch #t + (lambda () + (catch 'wrong-type-arg + (lambda () + (append! foo (list 4 5)) + #f) + (lambda (key . args) + #t))) + (lambda (key . args) + #f)))) + + (expect-fail "list, circular list and list" + (let ((foo (list 3 4 5))) + (set-cdr! (cddr foo) (cdr foo)) + (catch #t + (lambda () + (catch 'wrong-type-arg + (lambda () + (append! (list 1 2) foo (list 6 7)) + #f) + (lambda (key . args) + #t))) + (lambda (key . args) + #f)))))) + + +;;; last-pair + + +;;; reverse + + +;;; reverse! + + +;;; list-ref + +(with-test-prefix "list-ref" + + (pass-if "documented?" + (documented? list-ref)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if-exception "index 0" + exception:out-of-range + (list-ref '() 0)) + + (pass-if-exception "index > 0" + exception:out-of-range + (list-ref '() 1)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-ref '() -1))) + + (with-test-prefix "non-empty list" + + (pass-if-exception "index > length" + exception:out-of-range + (list-ref '(1) 1)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-ref '(1) -1)))))) + + +;;; list-set! + +(with-test-prefix "list-set!" + + (pass-if "documented?" + (documented? list-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if-exception "index 0" + exception:out-of-range + (list-set! (list) 0 #t)) + + (pass-if-exception "index > 0" + exception:out-of-range + (list-set! (list) 1 #t)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-set! (list) -1 #t))) + + (with-test-prefix "non-empty list" + + (pass-if-exception "index > length" + exception:out-of-range + (list-set! (list 1) 1 #t)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-set! (list 1) -1 #t)))))) + + +;;; list-cdr-ref + + +;;; list-tail + + +;;; list-cdr-set! + +(with-test-prefix "list-cdr-set!" + + (pass-if "documented?" + (documented? list-cdr-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if-exception "index 0" + exception:out-of-range + (list-cdr-set! (list) 0 #t)) + + (pass-if-exception "index > 0" + exception:out-of-range + (list-cdr-set! (list) 1 #t)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-cdr-set! (list) -1 #t))) + + (with-test-prefix "non-empty list" + + (pass-if-exception "index > length" + exception:out-of-range + (list-cdr-set! (list 1) 1 #t)) + + (pass-if-exception "index < 0" + exception:out-of-range + (list-cdr-set! (list 1) -1 #t)))))) + + +;;; list-head + + +;;; list-copy + + +;;; memq + +(with-test-prefix/c&e "memq" + + (pass-if "inline" + ;; In this case `memq' is inlined and the loop is unrolled. + (equal? '(b c d) (memq 'b '(a b c d)))) + + (pass-if "non inline" + ;; In this case a real function call is generated. + (equal? '(b c d) (memq 'b (list 'a 'b 'c 'd))))) + +;;; memv + +(with-test-prefix/c&e "memv" + (pass-if "inline" + ;; In this case `memv' is inlined and the loop is unrolled. + (equal? '(b c d) (memv 'b '(a b c d)))) + + (pass-if "non inline" + ;; In this case a real function call is generated. + (equal? '(b c d) (memv 'b (list 'a 'b 'c 'd))))) + +;;; member + + +;;; delq! + + +;;; delv! + + +;;; delete! + + +;;; delq + + +;;; delv + + +;;; delete + + +;;; delq1! + + +;;; delv1! + + +;;; delete1! |