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 ;;; 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)))
  25
  26 ;;; tests of MAP-INTO
  27
  28 (test-util:with-test (:name :map-into)
  29   (assertoid (map-into (vector) #'+ '(1 2 3) '(30 20))
  30              :expected-equalp #())
  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))
  37
  38   (assertoid (map-into (list) #'+ '(1 2 3) '(30 20))
  39              :expected-equalp '())
  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))
  46
  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))
  51
  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))
  56
  57   (assertoid (map-into (make-array 0 :element-type 'fixnum)
  58                        #'+ '(1 2 3) '(30 20))
  59              :expected-equalp #())
  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))
  69
  70   (assertoid (map-into (make-array 0 :fill-pointer 0 :initial-element 99)
  71                        #'+ '(1 2 3) '(30 20))
  72              :expected-equalp #())
  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))
  82
  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)))
  89
  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)))
  94        ,@body
  95        (nreverse reversed-result))))
  96
  97 (test-util:with-test (:name :map-nil)
  98   (assertoid (with-mapnil-test-fun fun
  99                (map nil #'fun #(1)))
 100              :expected-equal '((1)))
 101   (assertoid (with-mapnil-test-fun fun
 102                (map nil #'fun #() '(1 2 3)))
 103              :expected-equal '())
 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))))
 107
 108 ;;; Exercise MAP repeatedly on the same dataset by providing various
 109 ;;; combinations of sequence type arguments, declarations, and so
 110 ;;; forth.
 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
 119                    result-seq
 120                    fun-name
 121                    arg-seqs
 122                    arg-types
 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.
 127                (arrange (expr)
 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.
 132                (eff-arg-type (i)
 133                  (if (and (< i (length arg-types))
 134                           (plusp (logand (expt 2 i)
 135                                          arg-type-index)))
 136                      (nth i arg-types)
 137                      t))
 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)
 142                               ,(nth i arg-seqs))
 143                            reversed-result)))))
 144         (dolist (fun `(',fun-name #',fun-name))
 145           (dolist (result-type (cons 'list
 146                                      (mapcan (lambda (et)
 147                                                `((vector ,et)
 148                                                  (simple-array ,et 1)))
 149                                              result-element-types)))
 150             (arrange
 151              `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
 152                          :expected-equalp (coerce ,result-seq
 153                                                   ',result-type))))
 154           (arrange
 155            `(assertoid (map-into (fill (copy-seq ,result-seq) 9999)
 156                                  ,fun ,@(args-with-type-decls))
 157                        :expected-equalp ,result-seq)))
 158         (arrange
 159          `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
 160                              (with-mapnil-test-fun mtf
 161                                (map nil
 162                                     ;; (It would be nice to test MAP
 163                                     ;; NIL with function names, too,
 164                                     ;; but I can't see any concise way
 165                                     ;; to do it..)
 166                                     #'mtf
 167                                     ,@(args-with-type-decls))))
 168                      :expected-equal (coerce ,result-seq 'list)))))
 169     `(progn ,@(nreverse reversed-assertoids))))
 170
 171 (test-util:with-test (:name :maptest)
 172   (maptest :result-seq '(2 3)
 173            :fun-name 1+
 174            :arg-seqs (*list-2*)
 175            :arg-types (list))
 176   (maptest :result-seq '(nil nil nil)
 177            :fun-name oddp
 178            :arg-seqs (*vector-30*)
 179            :arg-types (vector))
 180   (maptest :result-seq '(12 24)
 181            :fun-name +
 182            :arg-seqs (*list-2* *list-2* *vector-30*)
 183            :arg-types (list list vector)))
 184
 185 (test-util:with-test (:name :map-into-vector-from-list)
 186   (map-into (eval (make-array 10))
 187             #'list
 188             (make-list 10)))
 189
 190 ;;; success