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 ;;; FIXME: Move these into their own file.
20 (test-util:with-test (:name :map)
21 (assertoid (map 'vector #'+ '(1 2 3) '(30 20))
22 :expected-equalp #(31 22))
23 (assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
24 :expected-equal '(201)))
28 (test-util:with-test (:name :map-into)
29 (assertoid (map-into (vector) #'+ '(1 2 3) '(30 20))
31 (assertoid (map-into (vector 99) #'+ '(1 2 3) '(30 20))
32 :expected-equalp #(31))
33 (assertoid (map-into (vector 99 88) #'+ '(1 2 3) '(30 20))
34 :expected-equalp #(31 22))
35 (assertoid (map-into (vector 99 88 77) #'+ '(1 2 3) '(30 20))
36 :expected-equalp #(31 22 77))
38 (assertoid (map-into (list) #'+ '(1 2 3) '(30 20))
40 (assertoid (map-into (list 99) #'+ '(1 2 3) '(30 20))
41 :expected-equalp '(31))
42 (assertoid (map-into (list 99 88) #'+ '(1 2 3) '(30 20))
43 :expected-equalp '(31 22))
44 (assertoid (map-into (list 99 88 77) #'+ '(1 2 3) '(30 20))
45 :expected-equalp '(31 22 77))
47 (assertoid (map-into (vector 99 99 99) (constantly 5))
48 :expected-equalp #(5 5 5))
49 (assertoid (map-into (vector 99 99 99) (let ((x 0)) (lambda () (incf x))))
50 :expected-equalp #(1 2 3))
52 (assertoid (map-into (list 99 99 99) (constantly 5))
53 :expected-equalp '(5 5 5))
54 (assertoid (map-into (list 99 99 99) (let ((x 0)) (lambda () (incf x))))
55 :expected-equalp '(1 2 3))
57 (assertoid (map-into (make-array 0 :element-type 'fixnum)
58 #'+ '(1 2 3) '(30 20))
60 (assertoid (map-into (make-array 1 :element-type 'fixnum :initial-element 99)
61 #'+ '(1 2 3) '(30 20))
62 :expected-equalp #(31))
63 (assertoid (map-into (make-array 2 :element-type 'fixnum :initial-element 99)
64 #'+ '(1 2 3) '(30 20))
65 :expected-equalp #(31 22))
66 (assertoid (map-into (make-array 3 :element-type 'fixnum :initial-element 99)
67 #'+ '(1 2 3) '(30 20))
68 :expected-equalp #(31 22 99))
70 (assertoid (map-into (make-array 0 :fill-pointer 0 :initial-element 99)
71 #'+ '(1 2 3) '(30 20))
73 (assertoid (map-into (make-array 1 :fill-pointer 0 :initial-element 99)
74 #'+ '(1 2 3) '(30 20))
75 :expected-equalp #(31))
76 (assertoid (map-into (make-array 2 :fill-pointer 0 :initial-element 99)
77 #'+ '(1 2 3) '(30 20))
78 :expected-equalp #(31 22))
79 (assertoid (map-into (make-array 3 :fill-pointer 0 :initial-element 99)
80 #'+ '(1 2 3) '(30 20))
81 :expected-equalp #(31 22))
83 (assertoid (map-into (make-array 9 :fill-pointer 9 :initial-element 99)
84 #'+ '(1 2 3) '(30 20))
85 :expected-equalp #(31 22))
86 (assertoid (map-into (make-array 9 :fill-pointer 5 :initial-element 99)
87 #'+ '(1 2 3) '(30 20))
88 :expected-equalp #(31 22)))
90 (defmacro with-mapnil-test-fun (fun-name &body body)
91 `(let ((reversed-result nil))
92 (flet ((,fun-name (&rest rest)
93 (push rest reversed-result)))
95 (nreverse reversed-result))))
97 (test-util:with-test (:name :map-nil)
98 (assertoid (with-mapnil-test-fun fun
100 :expected-equal '((1)))
101 (assertoid (with-mapnil-test-fun fun
102 (map nil #'fun #() '(1 2 3)))
104 (assertoid (with-mapnil-test-fun fun
105 (map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
106 :expected-equal '((a alpha aleph) (b beta beth))))
108 ;;; Exercise MAP repeatedly on the same dataset by providing various
109 ;;; combinations of sequence type arguments, declarations, and so
111 (defvar *list-1* '(1))
112 (defvar *list-2* '(1 2))
113 (defvar *list-3* '(1 2 3))
114 (defvar *list-4* '(1 2 3 4))
115 (defvar *vector-10* #(10))
116 (defvar *vector-20* #(10 20))
117 (defvar *vector-30* #(10 20 30))
118 (defmacro maptest (&key
123 (result-element-types '(t)))
124 (let ((reversed-assertoids nil))
125 (dotimes (arg-type-index (expt 2 (length arg-types)))
126 (labels (;; Arrange for EXPR to be executed.
128 (push expr reversed-assertoids))
129 ;; We toggle the various type declarations on and
130 ;; off depending on the bit pattern in ARG-TYPE-INDEX,
131 ;; so that we get lots of different things to test.
133 (if (and (< i (length arg-types))
134 (plusp (logand (expt 2 i)
138 (args-with-type-decls ()
139 (let ((reversed-result nil))
140 (dotimes (i (length arg-seqs) (nreverse reversed-result))
141 (push `(the ,(eff-arg-type i)
144 (dolist (fun `(',fun-name #',fun-name))
145 (dolist (result-type (cons 'list
148 (simple-array ,et 1)))
149 result-element-types)))
151 `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
152 :expected-equalp (coerce ,result-seq
155 `(assertoid (map-into (fill (copy-seq ,result-seq) 9999)
156 ,fun ,@(args-with-type-decls))
157 :expected-equalp ,result-seq)))
159 `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
160 (with-mapnil-test-fun mtf
162 ;; (It would be nice to test MAP
163 ;; NIL with function names, too,
164 ;; but I can't see any concise way
167 ,@(args-with-type-decls))))
168 :expected-equal (coerce ,result-seq 'list)))))
169 `(progn ,@(nreverse reversed-assertoids))))
171 (test-util:with-test (:name :maptest)
172 (maptest :result-seq '(2 3)
176 (maptest :result-seq '(nil nil nil)
178 :arg-seqs (*vector-30*)
180 (maptest :result-seq '(12 24)
182 :arg-seqs (*list-2* *list-2* *vector-30*)
183 :arg-types (list list vector)))
185 (test-util:with-test (:name :map-into-vector-from-list)
186 (map-into (eval (make-array 10))