test-suite/tests/list.test

   1 ;;;; list.test --- tests guile's lists     -*- scheme -*-
   2 ;;;; Copyright (C) 2000 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This program is free software; you can redistribute it and/or modify
   5 ;;;; it under the terms of the GNU General Public License as published by
   6 ;;;; the Free Software Foundation; either version 2, or (at your option)
   7 ;;;; any later version.
   8 ;;;;
   9 ;;;; This program is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;;; GNU General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU General Public License
  15 ;;;; along with this software; see the file COPYING.  If not, write to
  16 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17 ;;;; Boston, MA 02111-1307 USA
  18 ;;;;
  19 ;;;; As a special exception, the Free Software Foundation gives permission
  20 ;;;; for additional uses of the text contained in its release of GUILE.
  21 ;;;;
  22 ;;;; The exception is that, if you link the GUILE library with other files
  23 ;;;; to produce an executable, this does not by itself cause the
  24 ;;;; resulting executable to be covered by the GNU General Public License.
  25 ;;;; Your use of that executable is in no way restricted on account of
  26 ;;;; linking the GUILE library code into it.
  27 ;;;;
  28 ;;;; This exception does not however invalidate any other reasons why
  29 ;;;; the executable file might be covered by the GNU General Public License.
  30 ;;;;
  31 ;;;; This exception applies only to the code released by the
  32 ;;;; Free Software Foundation under the name GUILE.  If you copy
  33 ;;;; code from other Free Software Foundation releases into a copy of
  34 ;;;; GUILE, as the General Public License permits, the exception does
  35 ;;;; not apply to the code that you add in this way.  To avoid misleading
  36 ;;;; anyone as to the status of such modified files, you must delete
  37 ;;;; this exception notice from them.
  38 ;;;;
  39 ;;;; If you write modifications of your own for GUILE, it is your choice
  40 ;;;; whether to permit this exception to apply to your modifications.
  41 ;;;; If you do not wish that, delete this exception notice.
  42
  43 (use-modules (ice-9 documentation))
  44
  45
  46 ;;;
  47 ;;; miscellaneous
  48 ;;;
  49
  50 ;;
  51 ;; This unique tag is reserved for the unroll and diff-unrolled functions.
  52 ;;
  53
  54 (define circle-indicator
  55   (cons 'circle 'indicator))
  56
  57 ;;
  58 ;; Extract every single scheme object that is contained within OBJ into a new
  59 ;; data structure.  That means, if OBJ somewhere contains a pair, the newly
  60 ;; created structure holds a reference to the pair as well as references to
  61 ;; the car and cdr of that pair.  For vectors, the newly created structure
  62 ;; holds a reference to that vector as well as references to every element of
  63 ;; that vector.  Since this is done recursively, the original data structure
  64 ;; is deeply unrolled.  If there are circles within the original data
  65 ;; structures, every reference that points backwards into the data structure
  66 ;; is denoted by storing the circle-indicator tag as well as the object the
  67 ;; circular reference points to.
  68 ;;
  69
  70 (define (unroll obj)
  71   (let unroll* ((objct obj)
  72                 (hist '()))
  73     (reverse!
  74      (let loop ((object objct)
  75                 (histry hist)
  76                 (result '()))
  77        (if (memq object histry)
  78            (cons (cons circle-indicator object) result)
  79            (let ((history (cons object histry)))
  80              (cond ((pair? object)
  81                     (loop (cdr object) history
  82                           (cons (cons object (unroll* (car object) history))
  83                                 result)))
  84                    ((vector? object)
  85                     (cons (cons object
  86                                 (map (lambda (x)
  87                                        (unroll* x history))
  88                                      (vector->list object)))
  89                           result))
  90                    (else (cons object result)))))))))
  91
  92 ;;
  93 ;; Compare two data-structures that were generated with unroll.  If any of the
  94 ;; elements found not to be eq?, return a pair that holds the position of the
  95 ;; first found differences of the two data structures.  If all elements are
  96 ;; found to be eq?, #f is returned.
  97 ;;
  98
  99 (define (diff-unrolled a b)
 100   (cond ;; has everything been compared already?
 101         ((and (null? a) (null? b))
 102          #f)
 103         ;; do both structures still contain elements?
 104         ((and (pair? a) (pair? b))
 105          (cond ;; are the next elements both plain objects?
 106                ((and (not (pair? (car a))) (not (pair? (car b))))
 107                 (if (eq? (car a) (car b))
 108                     (diff-unrolled (cdr a) (cdr b))
 109                     (cons a b)))
 110                ;; are the next elements both container objects?
 111                ((and (pair? (car a)) (pair? (car b)))
 112                 (if (eq? (caar a) (caar b))
 113                     (cond ;; do both objects close a circular structure?
 114                           ((eq? circle-indicator (caar a))
 115                            (if (eq? (cdar a) (cdar b))
 116                                (diff-unrolled (cdr a) (cdr b))
 117                                (cons a b)))
 118                           ;; do both objects hold a vector?
 119                           ((vector? (caar a))
 120                            (or (let loop ((a1 (cdar a)) (b1 (cdar b)))
 121                                  (cond
 122                                   ((and (null? a1) (null? b1))
 123                                    #f)
 124                                   ((and (pair? a1) (pair? b1))
 125                                    (or (diff-unrolled (car a1) (car b1))
 126                                        (loop (cdr a1) (cdr b1))))
 127                                   (else
 128                                    (cons a1 b1))))
 129                                (diff-unrolled (cdr a) (cdr b))))
 130                           ;; do both objects hold a pair?
 131                           (else
 132                            (or (diff-unrolled (cdar a) (cdar b))
 133                                (diff-unrolled (cdr a) (cdr b)))))
 134                     (cons a b)))
 135                (else
 136                 (cons a b))))
 137         (else
 138          (cons a b))))
 139
 140 ;;; list
 141
 142
 143 ;;; cons*
 144
 145
 146 ;;; null?
 147
 148
 149 ;;; list?
 150
 151
 152 ;;; length
 153
 154
 155 ;;; append
 156
 157
 158 ;;;
 159 ;;; append!
 160 ;;;
 161
 162 (with-test-prefix "append!"
 163
 164   ;; Is documentation available?
 165
 166   (pass-if "documented?" (object-documentation append!))
 167
 168   ;; Is the handling of empty lists as arguments correct?
 169
 170   (pass-if "no arguments"
 171     (eq? (append!)
 172          '()))
 173
 174   (pass-if "empty list argument"
 175     (eq? (append! '())
 176          '()))
 177
 178   (pass-if "some empty list arguments"
 179     (eq? (append! '() '() '())
 180          '()))
 181
 182   ;; Does the last non-empty-list argument remain unchanged?
 183
 184   (pass-if "some empty lists with non-empty list"
 185     (let* ((foo (list 1 2))
 186            (foo-unrolled (unroll foo))
 187            (tst (append! '() '() '() foo))
 188            (tst-unrolled (unroll tst)))
 189       (and (eq? tst foo)
 190            (not (diff-unrolled foo-unrolled tst-unrolled)))))
 191
 192   (pass-if "some empty lists with improper list"
 193     (let* ((foo (cons 1 2))
 194            (foo-unrolled (unroll foo))
 195            (tst (append! '() '() '() foo))
 196            (tst-unrolled (unroll tst)))
 197       (and (eq? tst foo)
 198            (not (diff-unrolled foo-unrolled tst-unrolled)))))
 199
 200   (pass-if "some empty lists with circular list"
 201     (let ((foo (list 1 2)))
 202       (set-cdr! (cdr foo) (cdr foo))
 203       (let* ((foo-unrolled (unroll foo))
 204              (tst (append! '() '() '() foo))
 205              (tst-unrolled (unroll tst)))
 206         (and (eq? tst foo)
 207              (not (diff-unrolled foo-unrolled tst-unrolled))))))
 208
 209   (pass-if "some empty lists with non list object"
 210     (let* ((foo (vector 1 2 3))
 211            (foo-unrolled (unroll foo))
 212            (tst (append! '() '() '() foo))
 213            (tst-unrolled (unroll tst)))
 214       (and (eq? tst foo)
 215            (not (diff-unrolled foo-unrolled tst-unrolled)))))
 216
 217   (pass-if "non-empty list between empty lists"
 218     (let* ((foo (list 1 2))
 219            (foo-unrolled (unroll foo))
 220            (tst (append! '() '() '() foo '() '() '()))
 221            (tst-unrolled (unroll tst)))
 222       (and (eq? tst foo)
 223            (not (diff-unrolled foo-unrolled tst-unrolled)))))
 224
 225   ;; Are arbitrary lists append!ed correctly?
 226
 227   (pass-if "two one-element lists"
 228     (let* ((foo (list 1))
 229            (foo-unrolled (unroll foo))
 230            (bar (list 2))
 231            (bar-unrolled (unroll bar))
 232            (tst (append! foo bar))
 233            (tst-unrolled (unroll tst))
 234            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 235       (and (equal? tst '(1 2))
 236            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 237            (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
 238
 239   (pass-if "three one-element lists"
 240     (let* ((foo (list 1))
 241            (foo-unrolled (unroll foo))
 242            (bar (list 2))
 243            (bar-unrolled (unroll bar))
 244            (baz (list 3))
 245            (baz-unrolled (unroll baz))
 246            (tst (append! foo bar baz))
 247            (tst-unrolled (unroll tst))
 248            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 249       (and (equal? tst '(1 2 3))
 250            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 251            (let* ((tst-unrolled-2 (cdr diff-foo-tst))
 252                   (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
 253              (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
 254                   (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
 255
 256   (pass-if "two two-element lists"
 257     (let* ((foo (list 1 2))
 258            (foo-unrolled (unroll foo))
 259            (bar (list 3 4))
 260            (bar-unrolled (unroll bar))
 261            (tst (append! foo bar))
 262            (tst-unrolled (unroll tst))
 263            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 264       (and (equal? tst '(1 2 3 4))
 265            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 266            (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
 267
 268   (pass-if "three two-element lists"
 269     (let* ((foo (list 1 2))
 270            (foo-unrolled (unroll foo))
 271            (bar (list 3 4))
 272            (bar-unrolled (unroll bar))
 273            (baz (list 5 6))
 274            (baz-unrolled (unroll baz))
 275            (tst (append! foo bar baz))
 276            (tst-unrolled (unroll tst))
 277            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 278       (and (equal? tst '(1 2 3 4 5 6))
 279            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 280            (let* ((tst-unrolled-2 (cdr diff-foo-tst))
 281                   (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
 282              (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
 283                   (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
 284
 285   (pass-if "empty list between non-empty lists"
 286     (let* ((foo (list 1 2))
 287            (foo-unrolled (unroll foo))
 288            (bar (list 3 4))
 289            (bar-unrolled (unroll bar))
 290            (baz (list 5 6))
 291            (baz-unrolled (unroll baz))
 292            (tst (append! foo '() bar '() '() baz '() '() '()))
 293            (tst-unrolled (unroll tst))
 294            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 295       (and (equal? tst '(1 2 3 4 5 6))
 296            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 297            (let* ((tst-unrolled-2 (cdr diff-foo-tst))
 298                   (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
 299              (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
 300                   (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
 301
 302   (pass-if "list and improper list"
 303     (let* ((foo (list 1 2))
 304            (foo-unrolled (unroll foo))
 305            (bar (cons 3 4))
 306            (bar-unrolled (unroll bar))
 307            (tst (append! foo bar))
 308            (tst-unrolled (unroll tst))
 309            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 310       (and (equal? tst '(1 2 3 . 4))
 311            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 312            (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
 313
 314   (pass-if "list and circular list"
 315     (let* ((foo (list 1 2))
 316            (foo-unrolled (unroll foo))
 317            (bar (list 3 4 5)))
 318       (set-cdr! (cddr bar) (cdr bar))
 319       (let* ((bar-unrolled (unroll bar))
 320              (tst (append! foo bar))
 321              (tst-unrolled (unroll tst))
 322              (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 323         (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
 324                           (iota 9)
 325                           '(1 2 3 4 5 4 5 4 5))
 326                      '(#t #t #t #t #t #t #t #t #t))
 327              (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 328              (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))))
 329
 330   (pass-if "list and non list object"
 331     (let* ((foo (list 1 2))
 332            (foo-unrolled (unroll foo))
 333            (bar (vector 3 4))
 334            (bar-unrolled (unroll bar))
 335            (tst (append! foo bar))
 336            (tst-unrolled (unroll tst))
 337            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 338       (and (equal? tst '(1 2 . #(3 4)))
 339            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 340            (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
 341
 342   (pass-if "several arbitrary lists"
 343     (equal? (append! (list 1 2)
 344                      (list (list 3) 4)
 345                      (list (list 5) (list 6))
 346                      (list 7 (cons 8 9))
 347                      (list 10 11)
 348                      (list (cons 12 13) 14)
 349                      (list (list)))
 350             (list 1 2
 351                   (list 3) 4
 352                   (list 5) (list 6)
 353                   7 (cons 8 9)
 354                   10 11
 355                   (cons 12 13)
 356                   14 (list))))
 357
 358   (pass-if "list to itself"
 359     (let* ((foo (list 1 2))
 360            (foo-unrolled (unroll foo))
 361            (tst (append! foo foo))
 362            (tst-unrolled (unroll tst))
 363            (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
 364       (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
 365                         (iota 6)
 366                         '(1 2 1 2 1 2))
 367                    '(#t #t #t #t #t #t))
 368            (not (diff-unrolled (car diff-foo-tst) (unroll '())))
 369            (eq? (caar (cdr diff-foo-tst)) circle-indicator)
 370            (eq? (cdar (cdr diff-foo-tst)) foo))))
 371
 372   ;; Are wrong type arguments detected correctly?
 373
 374   (with-test-prefix "wrong argument"
 375
 376     (expect-fail "improper list and empty list"
 377       (catch 'wrong-type-arg
 378         (lambda ()
 379           (append! (cons 1 2) '())
 380           #f)
 381         (lambda (key . args)
 382           #t)))
 383
 384     (expect-fail "improper list and list"
 385       (catch 'wrong-type-arg
 386         (lambda ()
 387           (append! (cons 1 2) (list 3 4))
 388           #f)
 389         (lambda (key . args)
 390           #t)))
 391
 392     (expect-fail "list, improper list and list"
 393       (catch 'wrong-type-arg
 394         (lambda ()
 395           (append! (list 1 2) (cons 3 4) (list 5 6))
 396           #f)
 397         (lambda (key . args)
 398           #t)))
 399
 400     (expect-fail "circular list and empty list"
 401       (let ((foo (list 1 2 3)))
 402         (set-cdr! (cddr foo) (cdr foo))
 403         (catch #t
 404           (lambda ()
 405             (catch 'wrong-type-arg
 406               (lambda ()
 407                 (append! foo '())
 408                 #f)
 409               (lambda (key . args)
 410                 #t)))
 411           (lambda (key . args)
 412             #f))))
 413
 414     (expect-fail "circular list and list"
 415       (let ((foo (list 1 2 3)))
 416         (set-cdr! (cddr foo) (cdr foo))
 417         (catch #t
 418           (lambda ()
 419             (catch 'wrong-type-arg
 420               (lambda ()
 421                 (append! foo (list 4 5))
 422                 #f)
 423               (lambda (key . args)
 424                 #t)))
 425           (lambda (key . args)
 426             #f))))
 427
 428     (expect-fail "list, circular list and list"
 429       (let ((foo (list 3 4 5)))
 430         (set-cdr! (cddr foo) (cdr foo))
 431         (catch #t
 432           (lambda ()
 433             (catch 'wrong-type-arg
 434               (lambda ()
 435                 (append! (list 1 2) foo (list 6 7))
 436                 #f)
 437               (lambda (key . args)
 438                 #t)))
 439           (lambda (key . args)
 440             #f))))))
 441
 442
 443 ;;; last-pair
 444
 445
 446 ;;; reverse
 447
 448
 449 ;;; reverse!
 450
 451
 452 ;;; list-ref
 453
 454 (with-test-prefix "list-ref"
 455
 456   ;; Is documentation available?
 457
 458   (pass-if "documented?" (object-documentation list-ref))
 459
 460   (with-test-prefix "argument error"
 461
 462     (with-test-prefix "non list argument"
 463       #t)
 464
 465     (with-test-prefix "improper list argument"
 466       #t)
 467
 468     (with-test-prefix "non integer index"
 469       #t)
 470
 471     (with-test-prefix "index out of range"
 472
 473       (with-test-prefix "empty list"
 474
 475         (pass-if "index 0"
 476           (catch 'out-of-range
 477             (lambda ()
 478               (list-ref '() 0)
 479               #f)
 480             (lambda (key . args)
 481               #t)))
 482
 483         (pass-if "index > 0"
 484           (catch 'out-of-range
 485             (lambda ()
 486               (list-ref '() 1)
 487               #f)
 488             (lambda (key . args)
 489               #t)))
 490
 491         (pass-if "index < 0"
 492           (catch 'out-of-range
 493             (lambda ()
 494               (list-ref '() -1)
 495               #f)
 496             (lambda (key . args)
 497               #t))))
 498
 499       (with-test-prefix "non-empty list"
 500
 501         (pass-if "index > length"
 502           (catch 'out-of-range
 503             (lambda ()
 504               (list-ref '(1) 1)
 505               #f)
 506             (lambda (key . args)
 507               #t)))
 508
 509         (pass-if "index < 0"
 510           (catch 'out-of-range
 511             (lambda ()
 512               (list-ref '(1) -1)
 513               #f)
 514             (lambda (key . args)
 515               #t)))))))
 516
 517
 518 ;;; list-set!
 519
 520 (with-test-prefix "list-set!"
 521
 522   ;; Is documentation available?
 523
 524   (pass-if "documented?" (object-documentation list-set!))
 525
 526   (with-test-prefix "argument error"
 527
 528     (with-test-prefix "non list argument"
 529       #t)
 530
 531     (with-test-prefix "improper list argument"
 532       #t)
 533
 534     (with-test-prefix "read-only list argument"
 535       #t)
 536
 537     (with-test-prefix "non integer index"
 538       #t)
 539
 540     (with-test-prefix "index out of range"
 541
 542       (with-test-prefix "empty list"
 543
 544         (pass-if "index 0"
 545           (catch 'out-of-range
 546             (lambda ()
 547               (list-set! (list) 0 #t)
 548               #f)
 549             (lambda (key . args)
 550               #t)))
 551
 552         (pass-if "index > 0"
 553           (catch 'out-of-range
 554             (lambda ()
 555               (list-set! (list) 1 #t)
 556               #f)
 557             (lambda (key . args)
 558               #t)))
 559
 560         (pass-if "index < 0"
 561           (catch 'out-of-range
 562             (lambda ()
 563               (list-set! (list) -1 #t)
 564               #f)
 565             (lambda (key . args)
 566               #t))))
 567
 568       (with-test-prefix "non-empty list"
 569
 570         (pass-if "index > length"
 571           (catch 'out-of-range
 572             (lambda ()
 573               (list-set! (list 1) 1 #t)
 574               #f)
 575             (lambda (key . args)
 576               #t)))
 577
 578         (pass-if "index < 0"
 579           (catch 'out-of-range
 580             (lambda ()
 581               (list-set! (list 1) -1 #t)
 582               #f)
 583             (lambda (key . args)
 584               #t)))))))
 585
 586
 587 ;;; list-cdr-ref
 588
 589
 590 ;;; list-tail
 591
 592
 593 ;;; list-cdr-set!
 594
 595 (with-test-prefix "list-cdr-set!"
 596
 597   ;; Is documentation available?
 598
 599   (pass-if "documented?" (object-documentation list-cdr-set!))
 600
 601   (with-test-prefix "argument error"
 602
 603     (with-test-prefix "non list argument"
 604       #t)
 605
 606     (with-test-prefix "improper list argument"
 607       #t)
 608
 609     (with-test-prefix "read-only list argument"
 610       #t)
 611
 612     (with-test-prefix "non integer index"
 613       #t)
 614
 615     (with-test-prefix "index out of range"
 616
 617       (with-test-prefix "empty list"
 618
 619         (pass-if "index 0"
 620           (catch 'out-of-range
 621             (lambda ()
 622               (list-cdr-set! (list) 0 #t)
 623               #f)
 624             (lambda (key . args)
 625               #t)))
 626
 627         (pass-if "index > 0"
 628           (catch 'out-of-range
 629             (lambda ()
 630               (list-cdr-set! (list) 1 #t)
 631               #f)
 632             (lambda (key . args)
 633               #t)))
 634
 635         (pass-if "index < 0"
 636           (catch 'out-of-range
 637             (lambda ()
 638               (list-cdr-set! (list) -1 #t)
 639               #f)
 640             (lambda (key . args)
 641               #t))))
 642
 643       (with-test-prefix "non-empty list"
 644
 645         (pass-if "index > length"
 646           (catch 'out-of-range
 647             (lambda ()
 648               (list-cdr-set! (list 1) 1 #t)
 649               #f)
 650             (lambda (key . args)
 651               #t)))
 652
 653         (pass-if "index < 0"
 654           (catch 'out-of-range
 655             (lambda ()
 656               (list-cdr-set! (list 1) -1 #t)
 657               #f)
 658             (lambda (key . args)
 659               #t)))))))
 660
 661
 662 ;;; list-head
 663
 664
 665 ;;; list-copy
 666
 667
 668 ;;; sloppy-memq
 669
 670
 671 ;;; sloppy-memv
 672
 673
 674 ;;; sloppy-member
 675
 676
 677 ;;; memq
 678
 679
 680 ;;; memv
 681
 682
 683 ;;; member
 684
 685
 686 ;;; delq!
 687
 688
 689 ;;; delv!
 690
 691
 692 ;;; delete!
 693
 694
 695 ;;; delq
 696
 697
 698 ;;; delv
 699
 700
 701 ;;; delete
 702
 703
 704 ;;; delq1!
 705
 706
 707 ;;; delv1!
 708
 709
 710 ;;; delete1!