guile/test-suite/tests/list.test

;;;; 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!