tests/map-tests.impure.lisp

   1 ;;;; side-effectful tests of MAP-related stuff
   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 (load "test-util.lisp")
  15 (load "assertoid.lisp")
  16 (use-package "ASSERTOID")
  17
  18 ;;; tests of MAP
  19 (with-test (:name :map)
  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)))
  24
  25 ;;; tests of MAP-INTO
  26
  27 (with-test (:name :map-into)
  28   (assertoid (map-into (vector) #'+ '(1 2 3) '(30 20))
  29              :expected-equalp #())
  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))
  36
  37   (assertoid (map-into (list) #'+ '(1 2 3) '(30 20))
  38              :expected-equalp '())
  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))
  45
  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))
  50
  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))
  55
  56   (assertoid (map-into (make-array 0 :element-type 'fixnum)
  57                        #'+ '(1 2 3) '(30 20))
  58              :expected-equalp #())
  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))
  68
  69   (assertoid (map-into (make-array 0 :fill-pointer 0 :initial-element 99)
  70                        #'+ '(1 2 3) '(30 20))
  71              :expected-equalp #())
  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))
  81
  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)))
  88
  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)))
  93        ,@body
  94        (nreverse reversed-result))))
  95
  96 (with-test (:name :map-nil)
  97   (assertoid (with-mapnil-test-fun fun
  98                (map nil #'fun #(1)))
  99              :expected-equal '((1)))
 100   (assertoid (with-mapnil-test-fun fun
 101                (map nil #'fun #() '(1 2 3)))
 102              :expected-equal '())
 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))))
 106
 107 ;;; Exercise MAP repeatedly on the same dataset by providing various
 108 ;;; combinations of sequence type arguments, declarations, and so
 109 ;;; forth.
 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
 118                    result-seq
 119                    fun-name
 120                    arg-seqs
 121                    arg-types
 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.
 126                (arrange (expr)
 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.
 131                (eff-arg-type (i)
 132                  (if (and (< i (length arg-types))
 133                           (plusp (logand (expt 2 i)
 134                                          arg-type-index)))
 135                      (nth i arg-types)
 136                      t))
 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)
 141                               ,(nth i arg-seqs))
 142                            reversed-result)))))
 143         (dolist (fun `(',fun-name #',fun-name))
 144           (dolist (result-type (cons 'list
 145                                      (mapcan (lambda (et)
 146                                                `((vector ,et)
 147                                                  (simple-array ,et 1)))
 148                                              result-element-types)))
 149             (arrange
 150              `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
 151                          :expected-equalp (coerce ,result-seq
 152                                                   ',result-type))))
 153           (arrange
 154            `(assertoid (map-into (fill (copy-seq ,result-seq) 9999)
 155                                  ,fun ,@(args-with-type-decls))
 156                        :expected-equalp ,result-seq)))
 157         (arrange
 158          `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
 159                              (with-mapnil-test-fun mtf
 160                                (map nil
 161                                     ;; (It would be nice to test MAP
 162                                     ;; NIL with function names, too,
 163                                     ;; but I can't see any concise way
 164                                     ;; to do it..)
 165                                     #'mtf
 166                                     ,@(args-with-type-decls))))
 167                      :expected-equal (coerce ,result-seq 'list)))))
 168     `(progn ,@(nreverse reversed-assertoids))))
 169
 170 (with-test (:name :maptest)
 171   (maptest :result-seq '(2 3)
 172            :fun-name 1+
 173            :arg-seqs (*list-2*)
 174            :arg-types (list))
 175   (maptest :result-seq '(nil nil nil)
 176            :fun-name oddp
 177            :arg-seqs (*vector-30*)
 178            :arg-types (vector))
 179   (maptest :result-seq '(12 24)
 180            :fun-name +
 181            :arg-seqs (*list-2* *list-2* *vector-30*)
 182            :arg-types (list list vector)))
 183
 184 (with-test (:name :map-into-vector-from-list)
 185   (map-into (eval (make-array 10))
 186             #'list
 187             (make-list 10))
 188   (assert (equalp (funcall (compile nil
 189                                    `(lambda (a)
 190                                       (map-into (make-array 3) #'identity a)))
 191                           '(1 2 3))
 192                  #(1 2 3))))
 193
 194 (with-test (:name :map-into-type-mismatch)
 195   (assert-error
 196    (funcall
 197     (compile nil
 198              `(lambda (x)
 199                 (map-into (make-array 1 :element-type '(signed-byte 16)) x)))
 200     (constantly nil))
 201    type-error)
 202   (assert-error
 203    (funcall
 204     (compile nil
 205              `(lambda (array x)
 206                 (map-into array x)))
 207     (make-array 1 :element-type '(signed-byte 16)) (constantly nil))
 208    type-error)
 209   (assert-error
 210    (funcall
 211     (compile nil
 212              `(lambda (array x)
 213                 (map-into array x)))
 214     (cons 1 2) (constantly nil))
 215    type-error))
 216
 217 (with-test (:name :map-type-mismatch)
 218   (assert-error
 219    (funcall
 220     (compile nil
 221              `(lambda (x) (map '(vector (signed-byte 16) 1) #'identity x)))
 222     '(1.0))
 223    type-error)
 224   (assert-error
 225    (funcall
 226     (compile nil
 227              `(lambda (type x) (map type #'identity x)))
 228     '(vector (signed-byte 16) 1) '(1.0))
 229    type-error))
 230
 231 (with-test (:name :map-out-of-line)
 232   (flet ((call (map &rest args)
 233            (apply (compile nil `(lambda (&rest args)
 234                                   (declare (notinline ,map))
 235                                   (apply #',map args)))
 236                   args)))
 237     (assert (equal (call 'mapcar #'+ '(1 2 3) '(3 2 1))
 238                    '(4 4 4)))
 239     (assert (equal (call 'maplist #'cons '(1 2 3) '(3 2 1))
 240                    '(((1 2 3) 3 2 1) ((2 3) 2 1) ((3) 1))))
 241     (assert (equal (call 'mapcan #'cons '(1 2 3) '(3 2 1))
 242                    '(1 2 3 . 1)))
 243     (assert (equal (call 'mapcon #'list '(1 2 3) '(3 2 1))
 244                    '((1 2 3) (3 2 1) (2 3) (2 1) (3) (1))))
 245     (assert (equal (call 'mapcan #'identity
 246                          '((3 4 . 5) nil (1 . 5)))
 247                    '(3 4 1 . 5)))
 248     (assert (equal (call 'mapcar #'list '(1 2 3) '(4 5 6) '(7 8 9))
 249                    '((1 4 7) (2 5 8) (3 6 9))))
 250     (assert (equal (call 'mapcan #'identity '(1)) 1))))