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