tests/seq.pure.lisp

   1 ;;;; tests related to sequences
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE
  15 ;;; malfunctioned when given :START, :END and :FROM-END arguments.
  16 ;;; Make sure it doesn't happen again.
  17 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
  18        (x (copy-seq orig))
  19        (y (remove 3 x :from-end t :start 1 :end 5))
  20        (z (remove 2 x :from-end t :start 1 :end 5)))
  21   (assert (equalp orig x))
  22   (assert (equalp y '(1 2 2 6 1 2 4 1 3 2 7)))
  23   (assert (equalp z '(1 3 6 1 2 4 1 3 2 7))))
  24
  25 ;;; Similarly, NSUBSTITUTE and friends were getting things wrong with
  26 ;;; :START, :END and :FROM-END:
  27 (assert
  28  (loop for i from 0 to 9 always
  29        (loop for j from i to 10 always
  30              (loop for c from 0 to (- j i) always
  31                    (let* ((orig '(a a a a a a a a a a))
  32                           (x (copy-seq orig))
  33                           (y (nsubstitute 'x 'a x :start i :end j :count c)))
  34                      (equal y (nconc (make-list i :initial-element 'a)
  35                                      (make-list c :initial-element 'x)
  36                                      (make-list (- 10 (+ i c))
  37                                                 :initial-element 'a))))))))
  38
  39 (assert
  40  (loop for i from 0 to 9 always
  41        (loop for j from i to 10 always
  42              (loop for c from 0 to (- j i) always
  43                    (let* ((orig '(a a a a a a a a a a))
  44                           (x (copy-seq orig))
  45                           (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x
  46                                              :start i :end j
  47                                              :count c :from-end t)))
  48                      (equal y (nconc (make-list (- j c) :initial-element 'a)
  49                                      (make-list c :initial-element 'x)
  50                                      (make-list (- 10 j)
  51                                                 :initial-element 'a))))))))
  52 (assert
  53  (loop for i from 0 to 9 always
  54        (loop for j from i to 10 always
  55              (loop for c from 0 to (- j i) always
  56                    (let* ((orig '(a a a a a a a a a a))
  57                           (x (copy-seq orig))
  58                           (y (nsubstitute-if-not 'x (lambda (x)
  59                                                       (not (eq x 'a))) x
  60                                                  :start i :end j
  61                                                  :count c :from-end t)))
  62                      (equal y (nconc (make-list (- j c) :initial-element 'a)
  63                                      (make-list c :initial-element 'x)
  64                                      (make-list (- 10 j)
  65                                                 :initial-element 'a))))))))
  66
  67 ;;; And equally similarly, REMOVE-DUPLICATES misbehaved when given
  68 ;;; :START arguments:
  69
  70 (let ((orig (list 0 1 2 0 1 2 0 1 2 0 1 2)))
  71   (assert (equalp (remove-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))
  72   (assert (equalp (delete-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2))))
  73
  74 ;;; tests of COUNT
  75 (assert (= 1 (count 1 '(1 2 3))))
  76 (assert (= 2 (count 'z #(z 1 2 3 z))))
  77 (assert (= 0 (count 'y '(z 1 2 3 z))))
  78
  79 ;;; tests of COUNT-IF and COUNT-IF-NOT
  80 (macrolet (;; the guts of CCI, abstracted over whether we're testing
  81            ;; COUNT-IF or COUNT-IF-NOT
  82            (%cci (expected count-if test sequence-as-list &rest keys)
  83              `(let* ((list ',sequence-as-list)
  84                      (simple-vector (coerce list 'simple-vector))
  85                      (length (length list))
  86                      (vector (make-array (* 2 length) :fill-pointer length)))
  87                 (replace vector list :end1 length)
  88                 (dolist (seq (list list simple-vector vector))
  89                   (assert (= ,expected (,count-if ,test seq ,@keys))))))
  90            ;; "Check COUNT-IF"
  91            (cci (expected test sequence-as-list &rest keys)
  92              `(progn
  93                 (format t "~&SEQUENCE-AS-LIST=~S~%" ',sequence-as-list)
  94                 (%cci ,expected
  95                       count-if
  96                       ,test
  97                       ,sequence-as-list
  98                       ,@keys)
  99                 (%cci ,expected
 100                       count-if-not
 101                       (complement ,test)
 102                       ,sequence-as-list
 103                       ,@keys))))
 104   (cci 1 #'consp (1 (12) 1))
 105   (cci 3 #'consp (1 (2) 3 (4) (5) 6))
 106   (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t)
 107   (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2)
 108   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3)
 109   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3)
 110   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2)
 111   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2)
 112   (cci 2 #'zerop (0 10 0 11 12))
 113   (cci 1 #'zerop (0 10 0 11 12) :start 1)
 114   (cci 2 #'minusp (0 10 0 11 12) :key #'1-)
 115   (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2))
 116 (multiple-value-bind (v e)
 117     (ignore-errors (count-if #'zerop '(0 a 0 b c) :start 1))
 118   (declare (ignore v))
 119   (assert (eql (type-error-datum e) 'a)))
 120 (multiple-value-bind (v e)
 121     (ignore-errors (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11))
 122   (declare (ignore v))
 123   (assert (eql (type-error-datum e) 'c)))
 124
 125 ;;; :COUNT may be negative and BIGNUM
 126 (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
 127 (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
 128 (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1)))
 129
 130 ;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
 131 ;;; embedded calls of SORT do not work
 132 (assert (equal (sort (list 0 0 0) (lambda (x y) (sort (list 0 0 0) #'<) nil))
 133                '(0 0 0)))
 134 (assert (equal (sort (list 0 0 0 0 0)
 135                      (lambda (x y)
 136                        (declare (ignore x y))
 137                        (block compare
 138                          (sort (make-list 11 :initial-element 1)
 139                                (let ((counter 7))
 140                                  (lambda (x y)
 141                                    (declare (ignore x y))
 142                                    (when (= (decf counter) 0)
 143                                      (return-from compare nil))
 144                                    t))))))
 145                '(0 0 0 0 0)))
 146
 147 ;;; miscellaneous sanity checks on stuff which could've been broken by
 148 ;;; changes in MERGE-LIST* in sbcl-0.7.11.*
 149 (assert (equal (merge 'list () () '<) ()))
 150 (assert (equal (merge 'list () (list 1) #'< :key 'identity) '(1)))
 151 (assert (equal (merge 'list (list 2) () '>) '(2)))
 152 (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7)))
 153 (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7)))
 154 (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs)
 155                '(1 2 -2 3 4 7)))
 156 (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs)
 157                '(1 -2 -2 3 4 7)))
 158 (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13)))
 159 (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-)
 160                '(13 12 10 3 2 1)))
 161 (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-)
 162                '(1 2 3 10 12 13)))
 163 (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
 164                '(1 -1 2 -2 3 -3)))
 165
 166 ;;; CSR broke FILL by not returning the sequence argument in a transform.
 167 (let* ((s1 (copy-seq "abcde"))
 168        (s2 (fill s1 #\z)))
 169   (assert s2)
 170   (assert (string= s2 "zzzzz")))
 171
 172 ;;; POSITION on displaced arrays with non-zero offset has been broken
 173 ;;; for quite a while...
 174 (let ((fn (compile nil '(lambda (x) (position x)))))
 175   (let* ((x #(1 2 3))
 176          (y (make-array 2 :displaced-to x :displaced-index-offset 1)))
 177     (assert (= (position 2 y) 0))))
 178
 179 ;;; (SIMPLE-STRING) is a legal type specifier for creation functions
 180 (let ((a (make-sequence '(simple-string) 5))
 181       (b (concatenate '(simple-string) "a" "bdec"))
 182       (c (map '(simple-string) 'identity "abcde"))
 183       (d (merge '(simple-string) (copy-seq "acd") (copy-seq "be") 'char>))
 184       (e (coerce '(#\a #\b #\c #\e #\d) '(simple-string))))
 185   (assert (= (length a) 5))
 186   (assert (string= b "abdec"))
 187   (assert (string= c "abcde"))
 188   (assert (string= d "beacd"))
 189   (assert (string= e "abced")))
 190
 191 ;;; COPY-SEQ "should be prepared to signal an error if sequence is not
 192 ;;; a proper sequence".
 193 (locally (declare (optimize safety))
 194   (multiple-value-bind (seq err) (ignore-errors (copy-seq '(1 2 3 . 4)))
 195     (assert (not seq))
 196     (assert (typep err 'type-error))))
 197
 198 ;;; UBX-BASH-COPY transform had an inconsistent return type
 199 (let ((sb-c::*check-consistency* t))
 200   (handler-bind ((warning #'error))
 201     (compile nil
 202              '(lambda (l)
 203                (declare (type fixnum l))
 204                (let* ((bsize 128)
 205                       (b1 (make-array bsize :element-type '(unsigned-byte 8)))
 206                       (b2 (make-array l :element-type '(unsigned-byte 8))))
 207                  (replace b1 b2 :start2 0 :end2 l))))))