tests/map-tests.impure.lisp

   1 (cl:in-package :cl-user)
   2
   3 (load "assertoid.lisp")
   4
   5 ;;; tests of MAP
   6 ;;; FIXME: Move these into their own file.
   7 (assertoid (map 'vector #'+ '(1 2 3) '(30 20))
   8            :expected-equalp #(31 22))
   9 (assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
  10            :expected-equal '(201))
  11
  12 (defmacro with-mapnil-test-fun (fun-name &body body)
  13   `(let ((reversed-result nil))
  14      (flet ((,fun-name (&rest rest)
  15               (push rest reversed-result)))
  16        ,@body
  17        (nreverse reversed-result))))
  18 (assertoid (with-mapnil-test-fun fun
  19              (map nil #'fun #(1)))
  20            :expected-equal '((1)))
  21 (assertoid (with-mapnil-test-fun fun
  22              (map nil #'fun #() '(1 2 3)))
  23            :expected-equal '())
  24 (assertoid (with-mapnil-test-fun fun
  25              (map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
  26            :expected-equal '((a alpha aleph) (b beta beth)))
  27
  28 ;;; Exercise MAP repeatedly on the same dataset by providing various
  29 ;;; combinations of sequence type arguments, declarations, and so
  30 ;;; forth.
  31 (defvar *list-1* '(1))
  32 (defvar *list-2* '(1 2))
  33 (defvar *list-3* '(1 2 3))
  34 (defvar *list-4* '(1 2 3 4))
  35 (defvar *vector-10* #(10))
  36 (defvar *vector-20* #(10 20))
  37 (defvar *vector-30* #(10 20 30))
  38 (defmacro maptest (&key
  39                    result-seq
  40                    fun-name
  41                    arg-seqs
  42                    arg-types
  43                    (result-element-types '(t)))
  44   (let ((reversed-assertoids nil))
  45     (dotimes (arg-type-index (expt 2 (length arg-types)))
  46       (labels (;; Arrange for EXPR to be executed.
  47                (arrange (expr)
  48                  (push expr reversed-assertoids))
  49                ;; We toggle the various type declarations on and
  50                ;; off depending on the bit pattern in ARG-TYPE-INDEX,
  51                ;; so that we get lots of different things to test.
  52                (eff-arg-type (i)
  53                  (if (and (< i (length arg-types))
  54                           (plusp (logand (expt 2 i)
  55                                          arg-type-index)))
  56                      (nth i arg-types)
  57                      t))
  58                (args-with-type-decls ()
  59                  (let ((reversed-result nil))
  60                    (dotimes (i (length arg-seqs) (nreverse reversed-result))
  61                      (push `(the ,(eff-arg-type i)
  62                               ,(nth i arg-seqs))
  63                            reversed-result)))))
  64         (dolist (fun `(',fun-name #',fun-name))
  65           (dolist (result-type (cons 'list
  66                                      (mapcan (lambda (et)
  67                                                `((vector ,et)
  68                                                  (simple-array ,et 1)))
  69                                              result-element-types)))
  70             (arrange
  71              `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
  72                          :expected-equalp (coerce ,result-seq
  73                                                   ',result-type)))))
  74         (arrange
  75          `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
  76                              (with-mapnil-test-fun mtf
  77                                (map nil
  78                                     ;; (It would be nice to test MAP
  79                                     ;; NIL with function names, too,
  80                                     ;; but I can't see any concise way
  81                                     ;; to do it..)
  82                                     #'mtf
  83                                     ,@(args-with-type-decls))))
  84                      :expected-equal (coerce ,result-seq 'list)))))
  85     `(progn ,@(nreverse reversed-assertoids))))
  86 (maptest :result-seq '(2 3)
  87          :fun-name 1+
  88          :arg-seqs (*list-2*)
  89          :arg-types (list))
  90 (maptest :result-seq '(nil nil nil)
  91          :fun-name oddp
  92          :arg-seqs (*vector-30*)
  93          :arg-types (vector))
  94 (maptest :result-seq '(12 24)
  95          :fun-name +
  96          :arg-seqs (*list-2* *list-2* *vector-30*)
  97          :arg-types (list list vector))
  98
  99 ;;; success
 100 (quit :unix-status 104)