source: trunk/source/tests/ansi-tests/array-displacement.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.8 KB
Line 
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)
Note: See TracBrowser for help on using the repository browser.