mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
226a56a3d4
* libguile/list.c (scm_append_x): Report correct argument number when validating arguments. Validate that the last cdr of each argument is null or nil. Rename formal rest argument from 'lists' to 'args'. * test-suite/tests/list.test (append!): Update tests to expect correct handling of improper lists.
709 lines
18 KiB
Scheme
709 lines
18 KiB
Scheme
;;;; 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!
|