1 ;;;; side-effectful tests of MAP-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "test-util.lisp")
15 (load "assertoid.lisp")
16 (use-package "ASSERTOID")
19 (with-test (:name
(map :smoke
))
20 (assertoid (map 'vector
#'+ '(1 2 3) '(30 20))
21 :expected-equalp
#(31 22))
22 (assertoid (map 'list
#'+ #(1 2) '(100) #(0) #(100 100))
23 :expected-equal
'(201)))
27 (with-test (:name
(map-into :smoke
))
28 (assertoid (map-into (vector) #'+ '(1 2 3) '(30 20))
30 (assertoid (map-into (vector 99) #'+ '(1 2 3) '(30 20))
31 :expected-equalp
#(31))
32 (assertoid (map-into (vector 99 88) #'+ '(1 2 3) '(30 20))
33 :expected-equalp
#(31 22))
34 (assertoid (map-into (vector 99 88 77) #'+ '(1 2 3) '(30 20))
35 :expected-equalp
#(31 22 77))
37 (assertoid (map-into (list) #'+ '(1 2 3) '(30 20))
39 (assertoid (map-into (list 99) #'+ '(1 2 3) '(30 20))
40 :expected-equalp
'(31))
41 (assertoid (map-into (list 99 88) #'+ '(1 2 3) '(30 20))
42 :expected-equalp
'(31 22))
43 (assertoid (map-into (list 99 88 77) #'+ '(1 2 3) '(30 20))
44 :expected-equalp
'(31 22 77))
46 (assertoid (map-into (vector 99 99 99) (constantly 5))
47 :expected-equalp
#(5 5 5))
48 (assertoid (map-into (vector 99 99 99) (let ((x 0)) (lambda () (incf x
))))
49 :expected-equalp
#(1 2 3))
51 (assertoid (map-into (list 99 99 99) (constantly 5))
52 :expected-equalp
'(5 5 5))
53 (assertoid (map-into (list 99 99 99) (let ((x 0)) (lambda () (incf x
))))
54 :expected-equalp
'(1 2 3))
56 (assertoid (map-into (make-array 0 :element-type
'fixnum
)
57 #'+ '(1 2 3) '(30 20))
59 (assertoid (map-into (make-array 1 :element-type
'fixnum
:initial-element
99)
60 #'+ '(1 2 3) '(30 20))
61 :expected-equalp
#(31))
62 (assertoid (map-into (make-array 2 :element-type
'fixnum
:initial-element
99)
63 #'+ '(1 2 3) '(30 20))
64 :expected-equalp
#(31 22))
65 (assertoid (map-into (make-array 3 :element-type
'fixnum
:initial-element
99)
66 #'+ '(1 2 3) '(30 20))
67 :expected-equalp
#(31 22 99))
69 (assertoid (map-into (make-array 0 :fill-pointer
0 :initial-element
99)
70 #'+ '(1 2 3) '(30 20))
72 (assertoid (map-into (make-array 1 :fill-pointer
0 :initial-element
99)
73 #'+ '(1 2 3) '(30 20))
74 :expected-equalp
#(31))
75 (assertoid (map-into (make-array 2 :fill-pointer
0 :initial-element
99)
76 #'+ '(1 2 3) '(30 20))
77 :expected-equalp
#(31 22))
78 (assertoid (map-into (make-array 3 :fill-pointer
0 :initial-element
99)
79 #'+ '(1 2 3) '(30 20))
80 :expected-equalp
#(31 22))
82 (assertoid (map-into (make-array 9 :fill-pointer
9 :initial-element
99)
83 #'+ '(1 2 3) '(30 20))
84 :expected-equalp
#(31 22))
85 (assertoid (map-into (make-array 9 :fill-pointer
5 :initial-element
99)
86 #'+ '(1 2 3) '(30 20))
87 :expected-equalp
#(31 22)))
89 (defmacro with-mapnil-test-fun
(fun-name &body body
)
90 `(let ((reversed-result nil
))
91 (flet ((,fun-name
(&rest rest
)
92 (push rest reversed-result
)))
94 (nreverse reversed-result
))))
96 (with-test (:name
(map nil
))
97 (assertoid (with-mapnil-test-fun fun
99 :expected-equal
'((1)))
100 (assertoid (with-mapnil-test-fun fun
101 (map nil
#'fun
#() '(1 2 3)))
103 (assertoid (with-mapnil-test-fun fun
104 (map nil
#'fun
#(a b c
) '(alpha beta
) '(aleph beth
)))
105 :expected-equal
'((a alpha aleph
) (b beta beth
))))
107 ;;; Exercise MAP repeatedly on the same dataset by providing various
108 ;;; combinations of sequence type arguments, declarations, and so
110 (defvar *list-1
* '(1))
111 (defvar *list-2
* '(1 2))
112 (defvar *list-3
* '(1 2 3))
113 (defvar *list-4
* '(1 2 3 4))
114 (defvar *vector-10
* #(10))
115 (defvar *vector-20
* #(10 20))
116 (defvar *vector-30
* #(10 20 30))
117 (defmacro maptest
(&key
122 (result-element-types '(t)))
123 (let ((reversed-assertoids nil
))
124 (dotimes (arg-type-index (expt 2 (length arg-types
)))
125 (labels (;; Arrange for EXPR to be executed.
127 (push expr reversed-assertoids
))
128 ;; We toggle the various type declarations on and
129 ;; off depending on the bit pattern in ARG-TYPE-INDEX,
130 ;; so that we get lots of different things to test.
132 (if (and (< i
(length arg-types
))
133 (plusp (logand (expt 2 i
)
137 (args-with-type-decls ()
138 (let ((reversed-result nil
))
139 (dotimes (i (length arg-seqs
) (nreverse reversed-result
))
140 (push `(the ,(eff-arg-type i
)
143 (dolist (fun `(',fun-name
#',fun-name
))
144 (dolist (result-type (cons 'list
147 (simple-array ,et
1)))
148 result-element-types
)))
150 `(assertoid (map ',result-type
,fun
,@(args-with-type-decls))
151 :expected-equalp
(coerce ,result-seq
154 `(assertoid (map-into (fill (copy-seq ,result-seq
) 9999)
155 ,fun
,@(args-with-type-decls))
156 :expected-equalp
,result-seq
)))
158 `(assertoid (mapcar (lambda (args) (apply #',fun-name args
))
159 (with-mapnil-test-fun mtf
161 ;; (It would be nice to test MAP
162 ;; NIL with function names, too,
163 ;; but I can't see any concise way
166 ,@(args-with-type-decls))))
167 :expected-equal
(coerce ,result-seq
'list
)))))
168 `(progn ,@(nreverse reversed-assertoids
))))
170 (with-test (:name
:maptest
)
171 (maptest :result-seq
'(2 3)
175 (maptest :result-seq
'(nil nil nil
)
177 :arg-seqs
(*vector-30
*)
179 (maptest :result-seq
'(12 24)
181 :arg-seqs
(*list-2
* *list-2
* *vector-30
*)
182 :arg-types
(list list vector
)))
184 (with-test (:name
(map-into vector
:from list
))
185 (map-into (eval (make-array 10))
188 (checked-compile-and-assert ()
189 `(lambda (a) (map-into (make-array 3) #'identity a
))
190 (('(1 2 3)) #(1 2 3) :test
#'equalp
)))
192 (with-test (:name
(map-into type-error
))
193 (checked-compile-and-assert (:optimize
:safe
)
195 (map-into (make-array 1 :element-type
'(signed-byte 16)) x
))
196 (((constantly nil
)) (condition 'type-error
)))
197 (checked-compile-and-assert (:optimize
:safe
)
198 `(lambda (array x
) (map-into array x
))
199 (((make-array 1 :element-type
'(signed-byte 16)) (constantly nil
))
200 (condition 'type-error
)))
201 (checked-compile-and-assert (:optimize
:safe
)
202 `(lambda (array x
) (map-into array x
))
203 (((cons 1 2) (constantly nil
)) (condition 'type-error
))))
205 (with-test (:name
(map type-error
))
206 (checked-compile-and-assert (:optimize
:safe
)
207 `(lambda (x) (map '(vector (signed-byte 16) 1) #'identity x
))
208 (('(1.0
)) (condition 'type-error
)))
209 (checked-compile-and-assert (:optimize
:safe
)
210 `(lambda (type x
) (map type
#'identity x
))
211 (('(vector (signed-byte 16) 1) '(1.0
)) (condition 'type-error
))))
213 (with-test (:name
(map :out-of-line
))
214 (flet ((test (map args expected
)
215 (let ((fun (checked-compile `(lambda (&rest args
)
216 (declare (notinline ,map
))
217 (apply #',map args
)))))
218 (assert (equal (apply fun args
) expected
)))))
219 (test 'mapcar
(list #'+ '(1 2 3) '(3 2 1)) '(4 4 4))
220 (test 'maplist
(list #'cons
'(1 2 3) '(3 2 1))
221 '(((1 2 3) 3 2 1) ((2 3) 2 1) ((3) 1)))
222 (test 'mapcan
(list #'cons
'(1 2 3) '(3 2 1)) '(1 2 3 .
1))
223 (test 'mapcon
(list #'list
'(1 2 3) '(3 2 1))
224 '((1 2 3) (3 2 1) (2 3) (2 1) (3) (1)))
225 (test 'mapcan
(list #'identity
'((3 4 .
5) nil
(1 .
5)))
227 (test 'mapcar
(list #'list
'(1 2 3) '(4 5 6) '(7 8 9))
228 '((1 4 7) (2 5 8) (3 6 9)))
229 (test 'mapcan
(list #'identity
'(1)) 1)))