1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Tue Jan 21 06:20:51 2003 |
---|
4 | ;;;; Contains: Tests for ARRAY-DISPLACEMENT |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | ;;; The tests in make-array.lsp also test array-displacement |
---|
9 | |
---|
10 | ;;; The standard is contradictory about whether arrays created with |
---|
11 | ;;; :displaced-to NIL should return NIL as their primary value or |
---|
12 | ;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) |
---|
13 | ;;; that an implementation is free to implement all arrays as actually |
---|
14 | ;;; displaced. Therefore, I've omitted all the tests of not-expressly |
---|
15 | ;;; displaced arrays. |
---|
16 | |
---|
17 | ;;; Behavior on expressly displaced arrays |
---|
18 | |
---|
19 | (deftest array-displacement.7 |
---|
20 | (let* ((a (make-array '(10))) |
---|
21 | (b (make-array '(10) :displaced-to a))) |
---|
22 | (multiple-value-bind* (dt disp) |
---|
23 | (array-displacement b) |
---|
24 | (and (eqt a dt) |
---|
25 | (eqlt disp 0)))) |
---|
26 | t) |
---|
27 | |
---|
28 | (deftest array-displacement.8 |
---|
29 | (let* ((a (make-array '(10))) |
---|
30 | (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) |
---|
31 | (multiple-value-bind* (dt disp) |
---|
32 | (array-displacement b) |
---|
33 | (and (eqt a dt) |
---|
34 | (eqlt disp 2)))) |
---|
35 | t) |
---|
36 | |
---|
37 | (deftest array-displacement.9 |
---|
38 | (let* ((a (make-array '(10) :element-type 'base-char)) |
---|
39 | (b (make-array '(5) :displaced-to a :displaced-index-offset 2 |
---|
40 | :element-type 'base-char))) |
---|
41 | (multiple-value-bind* (dt disp) |
---|
42 | (array-displacement b) |
---|
43 | (and (eqt a dt) |
---|
44 | (eqlt disp 2)))) |
---|
45 | t) |
---|
46 | |
---|
47 | (deftest array-displacement.10 |
---|
48 | (let* ((a (make-array '(10) :element-type 'base-char)) |
---|
49 | (b (make-array '(5) :displaced-to a |
---|
50 | :element-type 'base-char))) |
---|
51 | (multiple-value-bind* (dt disp) |
---|
52 | (array-displacement b) |
---|
53 | (and (eqt a dt) |
---|
54 | (eqlt disp 0)))) |
---|
55 | t) |
---|
56 | |
---|
57 | (deftest array-displacement.11 |
---|
58 | (let* ((a (make-array '(10) :element-type 'bit)) |
---|
59 | (b (make-array '(5) :displaced-to a :displaced-index-offset 2 |
---|
60 | :element-type 'bit))) |
---|
61 | (multiple-value-bind* (dt disp) |
---|
62 | (array-displacement b) |
---|
63 | (and (eqt a dt) |
---|
64 | (eqlt disp 2)))) |
---|
65 | t) |
---|
66 | |
---|
67 | (deftest array-displacement.12 |
---|
68 | (let* ((a (make-array '(10) :element-type 'bit)) |
---|
69 | (b (make-array '(5) :displaced-to a |
---|
70 | :element-type 'bit))) |
---|
71 | (multiple-value-bind* (dt disp) |
---|
72 | (array-displacement b) |
---|
73 | (and (eqt a dt) |
---|
74 | (eqlt disp 0)))) |
---|
75 | t) |
---|
76 | |
---|
77 | (deftest array-displacement.13 |
---|
78 | (let* ((a (make-array '(10) :element-type '(integer 0 255))) |
---|
79 | (b (make-array '(5) :displaced-to a :displaced-index-offset 2 |
---|
80 | :element-type '(integer 0 255)))) |
---|
81 | (multiple-value-bind* (dt disp) |
---|
82 | (array-displacement b) |
---|
83 | (and (eqt a dt) |
---|
84 | (eqlt disp 2)))) |
---|
85 | t) |
---|
86 | |
---|
87 | (deftest array-displacement.14 |
---|
88 | (let* ((a (make-array '(10) :element-type '(integer 0 255))) |
---|
89 | (b (make-array '(5) :displaced-to a |
---|
90 | :element-type '(integer 0 255)))) |
---|
91 | (multiple-value-bind* (dt disp) |
---|
92 | (array-displacement b) |
---|
93 | (and (eqt a dt) |
---|
94 | (eqlt disp 0)))) |
---|
95 | t) |
---|
96 | |
---|
97 | (deftest array-displacement.15 |
---|
98 | (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) |
---|
99 | (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) |
---|
100 | (macrolet |
---|
101 | ((%m (z) z)) |
---|
102 | (multiple-value-bind |
---|
103 | (x y) |
---|
104 | (array-displacement (expand-in-current-env (%m b))) |
---|
105 | (values (eqlt x a) y)))) |
---|
106 | t 2) |
---|
107 | |
---|
108 | ;;; FIXME: Add tests for other kinds of specialized arrays |
---|
109 | ;;; (character, other integer types, float types, complex types) |
---|
110 | |
---|
111 | (deftest array-displacement.order.1 |
---|
112 | (let* ((a (make-array '(10))) |
---|
113 | (b (make-array '(10) :displaced-to a)) |
---|
114 | (i 0)) |
---|
115 | (multiple-value-bind* (dt disp) |
---|
116 | (array-displacement (progn (incf i) b)) |
---|
117 | (and (eql i 1) |
---|
118 | (eqt a dt) |
---|
119 | (eqlt disp 0)))) |
---|
120 | t) |
---|
121 | |
---|
122 | ;;; Error tests |
---|
123 | |
---|
124 | (deftest array-displacement.error.1 |
---|
125 | (signals-error (array-displacement) program-error) |
---|
126 | t) |
---|
127 | |
---|
128 | (deftest array-displacement.error.2 |
---|
129 | (signals-error (array-displacement #(a b c) nil) program-error) |
---|
130 | t) |
---|
131 | |
---|
132 | (deftest array-displacement.error.3 |
---|
133 | (check-type-error #'array-displacement #'arrayp) |
---|
134 | nil) |
---|
135 | |
---|
136 | (deftest array-displacement.error.4 |
---|
137 | (signals-type-error x nil (array-displacement x)) |
---|
138 | t) |
---|