1-- CC3224A.ADA
2
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--     CHECK THAT A FORMAL ARRAY TYPE DENOTES ITS ACTUAL
26--     PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE
27--     IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
28
29-- HISTORY:
30--     DHH 09/19/88  CREATED ORIGINAL TEST.
31--     EDWARD V. BERARD, 14 AUGUST 1990  ADDED CHECKS FOR MULTI-
32--                                       DIMENSIONAL ARRAYS
33--     PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
34
35WITH REPORT ;
36
37PROCEDURE CC3224A IS
38
39    SUBTYPE INT IS INTEGER RANGE 1 .. 3;
40    TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
41    TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN;
42
43    Q : ARR;
44    R : B_ARR;
45
46    GENERIC
47        TYPE T IS ARRAY(INT) OF INTEGER;
48    PACKAGE P IS
49        SUBTYPE SUB_T IS T;
50        X : SUB_T := (1, 2, 3);
51    END P;
52
53    GENERIC
54        TYPE T IS ARRAY(INT) OF BOOLEAN;
55    PACKAGE BOOL IS
56        SUBTYPE SUB_T IS T;
57    END BOOL;
58
59    SHORT_START : CONSTANT := -100 ;
60    SHORT_END   : CONSTANT := 100 ;
61    TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
62
63    SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
64
65    TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
66                        SEP, OCT, NOV, DEC) ;
67
68    SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
69
70    TYPE DAY_TYPE IS RANGE 1 .. 31 ;
71    TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
72    TYPE DATE IS RECORD
73      MONTH : MONTH_TYPE ;
74      DAY   : DAY_TYPE ;
75      YEAR  : YEAR_TYPE ;
76    END RECORD ;
77
78    TODAY         : DATE := (MONTH => AUG,
79                             DAY   => 8,
80                             YEAR  => 1990) ;
81
82    FIRST_DATE    : DATE := (DAY   => 6,
83                             MONTH => JUN,
84                             YEAR  => 1967) ;
85
86    WALL_DATE     : DATE := (MONTH => NOV,
87                             DAY   => 9,
88                             YEAR  => 1989) ;
89
90    SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
91
92    TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
93                                     FIRST_HALF,
94                                     FIRST_FIVE) OF DATE ;
95
96    TD_ARRAY        : THREE_DIMENSIONAL ;
97    SECOND_TD_ARRAY : THREE_DIMENSIONAL ;
98
99    GENERIC
100
101        TYPE CUBE IS ARRAY (REALLY_SHORT,
102                            FIRST_HALF,
103                            FIRST_FIVE) OF DATE ;
104
105    PACKAGE TD_ARRAY_PACKAGE IS
106
107        SUBTYPE SUB_CUBE IS CUBE ;
108        TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE =>
109                                    (THREE_DIMENSIONAL'RANGE (2) =>
110                                    (THREE_DIMENSIONAL'RANGE (3) =>
111                                     TODAY))) ;
112
113    END TD_ARRAY_PACKAGE ;
114
115
116BEGIN  -- CC3224A
117
118    REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " &
119                 "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " &
120                 "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " &
121                 "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");
122
123    ONE_DIMENSIONAL:
124
125    DECLARE
126
127        PACKAGE P1 IS NEW P (ARR);
128
129        TYPE NEW_T IS NEW P1.SUB_T;
130        OBJ_NEWT : NEW_T;
131
132    BEGIN  -- ONE_DIMENSIONAL
133
134        IF NEW_T'FIRST /= ARR'FIRST THEN
135            REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED");
136        END IF;
137
138        IF NEW_T'LAST /= ARR'LAST THEN
139            REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED");
140        END IF;
141
142        IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN
143            REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED");
144        END IF;
145
146        IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN
147            REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED");
148        END IF;
149
150        IF 2 NOT IN NEW_T'RANGE THEN
151            REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED");
152        END IF;
153
154        IF 3 NOT IN NEW_T'RANGE(1) THEN
155            REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED");
156        END IF;
157
158        IF NEW_T'LENGTH /= ARR'LENGTH THEN
159            REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED");
160        END IF;
161
162        IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN
163            REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED");
164         END IF;
165
166        OBJ_NEWT := (1, 2, 3);
167        IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN
168            REPORT.FAILED("ASSIGNMENT REPORT.FAILED");
169        END IF;
170
171        IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN
172            REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED");
173        END IF;
174
175        Q := (1, 2, 3);
176        IF NEW_T(Q) /= OBJ_NEWT THEN
177            REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED");
178        END IF;
179
180        IF Q(1) /= OBJ_NEWT(1) THEN
181            REPORT.FAILED("INDEXING REPORT.FAILED");
182        END IF;
183
184        IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN
185            REPORT.FAILED("SLICE REPORT.FAILED");
186        END IF;
187
188        IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN
189            REPORT.FAILED("CATENATION REPORT.FAILED");
190        END IF;
191
192        IF NOT (P1.X IN ARR) THEN
193            REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL");
194        END IF;
195
196    END ONE_DIMENSIONAL ;
197
198    BOOLEAN_ONE_DIMENSIONAL:
199
200    DECLARE
201
202        PACKAGE B1 IS NEW BOOL (B_ARR);
203
204        TYPE NEW_T IS NEW B1.SUB_T;
205        OBJ_NEWT : NEW_T;
206
207    BEGIN  -- BOOLEAN_ONE_DIMENSIONAL
208
209        OBJ_NEWT := (TRUE, TRUE, TRUE);
210        R := (TRUE, TRUE, TRUE);
211
212        IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /=
213           NEW_T'((FALSE, FALSE, FALSE)) THEN
214            REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ;
215        END IF;
216
217        IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /=
218           NEW_T'((FALSE, FALSE, TRUE)) THEN
219            REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ;
220        END IF;
221
222        IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /=
223           NEW_T'((TRUE, TRUE, TRUE)) THEN
224            REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ;
225        END IF ;
226
227    END BOOLEAN_ONE_DIMENSIONAL ;
228
229    THREE_DIMENSIONAL_TEST:
230
231    DECLARE
232
233         PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ;
234
235        TYPE NEW_CUBE IS NEW TD.SUB_CUBE ;
236        NEW_CUBE_OBJECT : NEW_CUBE ;
237
238    BEGIN  -- THREE_DIMENSIONAL_TEST
239
240        IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR
241           (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR
242           (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR
243           (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN
244            REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" &
245                           "DIMENSIONAL ARRAYS.") ;
246        END IF ;
247
248        IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR
249           (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR
250           (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR
251           (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN
252            REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" &
253                           "DIMENSIONAL ARRAYS.") ;
254        END IF ;
255
256        IF (-5 NOT IN NEW_CUBE'RANGE) OR
257           (-3 NOT IN NEW_CUBE'RANGE (1)) OR
258           (FEB NOT IN NEW_CUBE'RANGE (2)) OR
259           ('C' NOT IN NEW_CUBE'RANGE (3)) THEN
260            REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" &
261                           "DIMENSIONAL ARRAYS.") ;
262        END IF ;
263
264        IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR
265           (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR
266           (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR
267           (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN
268            REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" &
269                           "DIMENSIONAL ARRAYS.") ;
270        END IF ;
271
272        NEW_CUBE_OBJECT := (NEW_CUBE'RANGE =>
273                           (NEW_CUBE'RANGE (2) =>
274                           (NEW_CUBE'RANGE (3) =>
275                            FIRST_DATE))) ;
276        IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN
277            REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " &
278                           "ARRAYS FAILED.") ;
279        END IF ;
280
281        IF NEW_CUBE'(NEW_CUBE'RANGE =>
282                    (NEW_CUBE'RANGE (2) =>
283                    (NEW_CUBE'RANGE (3) =>
284                     WALL_DATE))) NOT IN NEW_CUBE THEN
285            REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" &
286                           "DIMENSIONAL ARRAYS FAILED.") ;
287        END IF ;
288
289        SECOND_TD_ARRAY := (NEW_CUBE'RANGE =>
290                           (NEW_CUBE'RANGE (2) =>
291                           (NEW_CUBE'RANGE (3) =>
292                            FIRST_DATE))) ;
293        IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN
294            REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" &
295                           "DIMENSIONAL ARRAYS FAILED.") ;
296        END IF ;
297
298        IF SECOND_TD_ARRAY (-2, FEB, 'B')
299            /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN
300            REPORT.FAILED ("INDEXING FOR MULTI-" &
301                           "DIMENSIONAL ARRAYS FAILED.") ;
302        END IF ;
303
304        IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN
305            REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " &
306                           "DOES NOT DENOTE ACTUAL.") ;
307        END IF ;
308
309    END THREE_DIMENSIONAL_TEST ;
310
311    REPORT.RESULT ;
312
313END CC3224A ;
314