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