some.lsp 8.63 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 07:07:07 2002
;;;; Contains: Tests for SOME

6

7 8 9 10 11 12 13 14 15 16 17 18 19

(deftest some.1
  (some #'identity nil)
  nil)

(deftest some.2
  (some #'identity #())
  nil)

(deftest some.3
  (let ((count 0))
    (values
     (some #'(lambda (x) (incf count) (if (>= x 10) x nil))
sds's avatar
sds committed
20
            '(1 2 4 13 5 1))
21 22 23 24 25 26 27 28 29 30 31 32
     count))
  13 4)

(deftest some.4
  (some #'/= '(1 2 3 4) '(1 2 3 4 5))
  nil)

(deftest some.5
  (some #'/= '(1 2 3 4 5) '(1 2 3 4))
  nil)

(deftest some.6
33
  (not-mv (some #'/= '(1 2 3 4 5) '(1 2 3 4 6)))
34 35 36 37
  nil)

(deftest some.7
  (some #'(lambda (x y) (and x y))
sds's avatar
sds committed
38
        '(nil t t nil t) #(t nil nil t nil nil))
39 40 41 42
  nil)

(deftest some.8
  (let ((x '(1))
sds's avatar
sds committed
43
        (args nil))
44
    (loop for i from 1 below (1- (min 100 call-arguments-limit))
sds's avatar
sds committed
45 46
          do (push x args)
          always (apply #'some #'/= args)))
47 48 49 50 51 52 53 54 55 56 57
  nil)

(deftest some.9
  (some #'zerop #*11111111111111)
  nil)

(deftest some.10
  (some #'zerop #*)
  nil)

(deftest some.11
58
  (not-mv (some #'zerop #*1111111011111))
59 60 61 62 63 64 65 66 67 68 69
  nil)

(deftest some.12
  (some #'(lambda (x) (not (eql x #\a))) "aaaaaaaa")
  nil)

(deftest some.13
  (some #'(lambda (x) (eql x #\a)) "")
  nil)

(deftest some.14
70
  (not-mv (some #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa"))
71 72 73
  nil)

(deftest some.15
74 75 76 77
  (some 'null '(1 2 3 4))
  nil)

(deftest some.16
78
  (not-mv (some 'null '(1 2 3 nil 5)))
79 80
  nil)

81 82 83 84
;;; Other specialized sequences

(deftest some.17
  (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6)
sds's avatar
sds committed
85
                       :fill-pointer 4)))
86
    (loop for j from 0 to 9
sds's avatar
sds committed
87 88
          do (setf (fill-pointer v) j)
          collect (notnot (some #'plusp v))))
89 90 91 92
  (nil nil nil nil nil t t t t t))

(deftest some.18
  (loop for i from 1 to 40
sds's avatar
sds committed
93 94 95 96 97 98 99 100 101 102 103
        for type = `(unsigned-byte ,i)
        unless
        (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6)
                                                           collect (mod j (ash 1 i)))
                             :element-type type
                             :fill-pointer 4)))
          (equal (loop for j from 0 to 9
                       do (setf (fill-pointer v) j)
                       collect (notnot (some #'plusp v)))
                 '(nil nil nil nil nil t t t t t)))
        collect i)
104 105 106 107
  nil)

(deftest some.19
  (loop for i from 1 to 40
sds's avatar
sds committed
108 109 110 111 112 113 114 115 116 117
        for type = `(signed-byte ,i)
        unless
        (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1)
                             :element-type type
                             :fill-pointer 4)))
          (equal (loop for j from 0 to 9
                       do (setf (fill-pointer v) j)
                       collect (notnot (some #'minusp v)))
                 '(nil nil nil nil nil t t t t t)))
        collect i)
118 119 120 121
  nil)

(deftest some.20
  (let ((v (make-array '(10) :initial-contents "abcd012345"
sds's avatar
sds committed
122 123
                       :element-type 'character
                       :fill-pointer 4)))
124
    (loop for j from 0 to 9
sds's avatar
sds committed
125 126
          do (setf (fill-pointer v) j)
          collect (notnot (some #'digit-char-p v))))
127 128 129 130
  (nil nil nil nil nil t t t t t))

(deftest some.21
  (let ((v (make-array '(10) :initial-contents "abcd012345"
sds's avatar
sds committed
131 132
                       :element-type 'base-char
                       :fill-pointer 4)))
133
    (loop for j from 0 to 9
sds's avatar
sds committed
134 135
          do (setf (fill-pointer v) j)
          collect (notnot (some #'digit-char-p v))))
136 137 138 139
  (nil nil nil nil nil t t t t t))

(deftest some.22
  (let ((v (make-array '(5) :initial-contents "abcde"
sds's avatar
sds committed
140
                       :element-type 'base-char)))
141 142 143 144 145 146 147 148
    (values
     (some #'digit-char-p v)
     (setf (aref v 2) #\0)
     (notnot (some #'digit-char-p v))))
  nil #\0 t)

(deftest some.23
  (loop for type in '(short-float single-float double-float long-float)
sds's avatar
sds committed
149 150 151 152 153 154
        for v = (make-array '(9)
                            :element-type type
                            :initial-contents
                            (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3)))
        unless (some #'zerop v)
        collect (list type v))
155 156 157 158
  nil)

(deftest some.24
  (loop for type in '(short-float single-float double-float long-float)
sds's avatar
sds committed
159 160 161 162 163 164 165
        for v = (make-array '(9)
                            :element-type type
                            :fill-pointer 6
                            :initial-contents
                            (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3)))
        when (some #'zerop v)
        collect (list type v))
166 167 168 169
  nil)

(deftest some.25
  (loop for type in '(short-float single-float double-float long-float)
sds's avatar
sds committed
170 171 172 173 174 175 176
        for ctype = `(complex ,type)
        for v = (make-array '(6)
                            :element-type ctype
                            :initial-contents
                            (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6)))
        when (some (complement #'complexp) v)
        collect (list type v))
177 178 179 180 181 182
  nil)

;;; Displaced vectors

(deftest some.26
  (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1)))
sds's avatar
sds committed
183 184
         (v2 (make-array '(4) :displaced-to v1
                         :displaced-index-offset 2)))
185 186 187 188 189 190 191
    (values
     (notnot (some #'oddp v1))
     (some #'oddp v2)))
  t nil)

(deftest some.27
  (loop for i from 1 to 40
sds's avatar
sds committed
192 193 194 195 196 197 198 199 200 201
        for type = `(unsigned-byte ,i)
        unless
        (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1)
                               :element-type type))
               (v2 (make-array '(4) :displaced-to v1
                               :displaced-index-offset 2
                               :element-type type)))
          (and (some 'oddp v1))
               (not (some #'oddp v2)))
        collect i)
202 203 204 205
  nil)

(deftest some.28
  (loop for i from 1 to 40
sds's avatar
sds committed
206 207 208 209 210 211 212 213 214 215
        for type = `(signed-byte ,i)
        unless
        (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1)
                               :element-type type))
               (v2 (make-array '(4) :displaced-to v1
                               :displaced-index-offset 2
                               :element-type type)))
          (and (some 'oddp v1)
               (not (some #'oddp v2))))
        collect i)
216 217 218 219 220
  nil)

(deftest some.29
  (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character)))
    (loop for i from 0 to 6
sds's avatar
sds committed
221 222 223 224
          for s2 = (make-array '(2) :element-type 'character
                               :displaced-to s1
                               :displaced-index-offset i)
          collect (notnot (some 'digit-char-p s2))))
225 226 227 228 229
  (t t nil nil t t t))

(deftest some.30
  (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char)))
    (loop for i from 0 to 6
sds's avatar
sds committed
230 231 232 233
          for s2 = (make-array '(2) :element-type 'base-char
                               :displaced-to s1
                               :displaced-index-offset i)
          collect (notnot (some 'digit-char-p s2))))
234 235 236 237
  (t t nil nil t t t))

(deftest some.31
  (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10)
sds's avatar
sds committed
238
                       :adjustable t)))
239 240 241 242 243 244 245 246 247
    (values
     (some #'minusp v)
     (progn
       (adjust-array v '(11) :initial-element -1)
       (notnot (some #'minusp v)))))
  nil t)

(deftest some.32
  (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10)
sds's avatar
sds committed
248 249
                       :fill-pointer 10
                       :adjustable t)))
250 251 252 253 254 255 256
    (values
     (some #'minusp v)
     (progn
       (adjust-array v '(11) :initial-element -1)
       (some #'minusp v))))
  nil nil)

257 258 259 260
(deftest some.order.1
  (let ((i 0) x y)
    (values
     (some (progn (setf x (incf i)) #'null)
sds's avatar
sds committed
261
           (progn (setf y (incf i)) '(a b c d)))
262 263 264 265 266 267 268
     i x y))
  nil 2 1 2)

(deftest some.order.2
  (let ((i 0) x y z)
    (values
     (some (progn (setf x (incf i)) #'eq)
sds's avatar
sds committed
269 270
           (progn (setf y (incf i)) '(a b c d))
           (progn (setf z (incf i)) '(e f g h)))
271 272 273
     i x y z))
  nil 3 1 2 3)

274 275

(deftest some.error.1
276
  (check-type-error #'(lambda (x) (some x '(a b c)))
sds's avatar
sds committed
277
                    (typef '(or symbol function)))
278
  nil)
279

280
(deftest some.error.4
281 282
  (check-type-error #'(lambda (x) (some #'null x)) #'sequencep)
  nil)
283

284
(deftest some.error.7
285 286
  (check-type-error #'(lambda (x) (some #'eql () x)) #'sequencep)
  nil)
287 288

(deftest some.error.8
289 290
  (signals-error (some) program-error)
  t)
291 292

(deftest some.error.9
293 294
  (signals-error (some #'null) program-error)
  t)
295

296
(deftest some.error.10
297 298
  (signals-error (locally (some 1 '(a b c)) t) type-error)
  t)
299 300

(deftest some.error.11
301 302
  (signals-error (some #'cons '(a b c)) program-error)
  t)
303 304

(deftest some.error.12
305 306
  (signals-error (some #'car '(a b c)) type-error)
  t)
307 308

(deftest some.error.13
309 310
  (signals-error (some #'cons '(a b c) '(b c d) '(c d e)) program-error)
  t)
311

312 313 314
(deftest some.error.14
  (signals-error (some #'null '(a b . c)) type-error)
  t)
315