1-- C34005O.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-- OBJECTIVE:
26--     FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE
27--     IS A NON-LIMITED TYPE:
28--     CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29--     THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30--     CONSTRAINED.
31--     CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32--     IMPOSED ON THE DERIVED SUBTYPE.
33
34-- HISTORY:
35--     JRK 9/17/86  CREATED ORIGINAL TEST.
36
37WITH REPORT; USE REPORT;
38
39PROCEDURE C34005O IS
40
41     SUBTYPE COMPONENT IS INTEGER;
42
43     PACKAGE PKG IS
44
45          FIRST : CONSTANT := 0;
46          LAST  : CONSTANT := 10;
47
48          SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
49
50          TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
51                               COMPONENT;
52
53          FUNCTION CREATE ( F1, L1 : INDEX;
54                            F2, L2 : INDEX;
55                            C      : COMPONENT;
56                            DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
57                          ) RETURN PARENT;
58
59     END PKG;
60
61     USE PKG;
62
63     TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
64                           IDENT_INT (6) .. IDENT_INT (8));
65
66     SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
67
68     TYPE S IS NEW SUBPARENT;
69
70     X : T := (OTHERS => (OTHERS => 2));
71     Y : S := (OTHERS => (OTHERS => 2));
72
73     PACKAGE BODY PKG IS
74
75          FUNCTION CREATE
76             ( F1, L1 : INDEX;
77               F2, L2 : INDEX;
78               C      : COMPONENT;
79               DUMMY  : PARENT
80             ) RETURN PARENT
81          IS
82               A : PARENT (F1 .. L1, F2 .. L2);
83               B : COMPONENT := C;
84          BEGIN
85               FOR I IN F1 .. L1 LOOP
86                    FOR J IN F2 .. L2 LOOP
87                         A (I, J) := B;
88                         B := B + 1;
89                    END LOOP;
90               END LOOP;
91               RETURN A;
92          END CREATE;
93
94     END PKG;
95
96BEGIN
97     TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
98                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
99                      "WHEN THE DERIVED TYPE DEFINITION IS " &
100                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
101                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
102                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
103                      "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
104                      "TYPE IS A NON-LIMITED TYPE");
105
106     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
107
108     BEGIN
109          IF CREATE (6, 9, 2, 3, 1, X) /=
110             ((1, 2), (3, 4), (5, 6), (7, 8)) OR
111             CREATE (6, 9, 2, 3, 1, Y) /=
112             ((1, 2), (3, 4), (5, 6), (7, 8)) THEN
113               FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
114                       "SUBTYPE");
115          END IF;
116     EXCEPTION
117          WHEN CONSTRAINT_ERROR =>
118               FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
119          WHEN OTHERS =>
120               FAILED ("CALL TO CREATE RAISED EXCEPTION");
121     END;
122
123     IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR
124        ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN
125          FAILED ("INCORRECT ""IN""");
126     END IF;
127
128     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
129
130     IF T'FIRST /= 4 OR T'LAST /= 5 OR
131        S'FIRST /= 4 OR S'LAST /= 5 OR
132        T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR
133        S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN
134          FAILED ("INCORRECT 'FIRST OR 'LAST");
135     END IF;
136
137     BEGIN
138          X := ((1, 2, 3), (4, 5, 6));
139          Y := ((1, 2, 3), (4, 5, 6));
140          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
141               FAILED ("INCORRECT CONVERSION TO PARENT");
142          END IF;
143     EXCEPTION
144          WHEN OTHERS =>
145               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
146     END;
147
148     BEGIN
149          X := (4 => (6 .. 8 => 0));
150          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
151                  "X := (4 => (6 .. 8 => 0))");
152          IF X = (4 => (6 .. 8 => 0)) THEN  -- USE X.
153               COMMENT ("X ALTERED -- " &
154                        "X := (4 => (6 .. 8 => 0))");
155          END IF;
156     EXCEPTION
157          WHEN CONSTRAINT_ERROR =>
158               NULL;
159          WHEN OTHERS =>
160               FAILED ("WRONG EXCEPTION RAISED -- " &
161                       "X := (4 => (6 .. 8 => 0))");
162     END;
163
164     BEGIN
165          X := (4 .. 6 => (6 .. 8 => 0));
166          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
167                  "X := (4 .. 6 => (6 .. 8 => 0))");
168          IF X = (4 .. 6 => (6 .. 8 => 0)) THEN  -- USE X.
169               COMMENT ("X ALTERED -- " &
170                        "X := (4 .. 6 => (6 .. 8 => 0))");
171          END IF;
172     EXCEPTION
173          WHEN CONSTRAINT_ERROR =>
174               NULL;
175          WHEN OTHERS =>
176               FAILED ("WRONG EXCEPTION RAISED -- " &
177                       "X := (4 .. 6 => (6 .. 8 => 0))");
178     END;
179
180     BEGIN
181          X := (4 .. 5 => (6 .. 7 => 0));
182          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
183                  "X := (4 .. 5 => (6 .. 7 => 0))");
184          IF X = (4 .. 5 => (6 .. 7 => 0)) THEN  -- USE X.
185               COMMENT ("X ALTERED -- " &
186                        "X := (4 .. 5 => (6 .. 7 => 0))");
187          END IF;
188     EXCEPTION
189          WHEN CONSTRAINT_ERROR =>
190               NULL;
191          WHEN OTHERS =>
192               FAILED ("WRONG EXCEPTION RAISED -- " &
193                       "X := (4 .. 5 => (6 .. 7 => 0))");
194     END;
195
196     BEGIN
197          X := (4 .. 5 => (6 .. 9 => 0));
198          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
199                  "X := (4 .. 5 => (6 .. 9 => 0))");
200          IF X = (4 .. 5 => (6 .. 9 => 0)) THEN  -- USE X.
201               COMMENT ("X ALTERED -- " &
202                        "X := (4 .. 5 => (6 .. 9 => 0))");
203          END IF;
204     EXCEPTION
205          WHEN CONSTRAINT_ERROR =>
206               NULL;
207          WHEN OTHERS =>
208               FAILED ("WRONG EXCEPTION RAISED -- " &
209                       "X := (4 .. 5 => (6 .. 9 => 0))");
210     END;
211
212     BEGIN
213          Y := (4 => (6 .. 8 => 0));
214          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
215                  "Y := (4 => (6 .. 8 => 0))");
216          IF Y = (4 => (6 .. 8 => 0)) THEN  -- USE Y.
217               COMMENT ("Y ALTERED -- " &
218                        "Y := (4 => (6 .. 8 => 0))");
219          END IF;
220     EXCEPTION
221          WHEN CONSTRAINT_ERROR =>
222               NULL;
223          WHEN OTHERS =>
224               FAILED ("WRONG EXCEPTION RAISED -- " &
225                       "Y := (4 => (6 .. 8 => 0))");
226     END;
227
228     BEGIN
229          Y := (4 .. 6 => (6 .. 8 => 0));
230          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
231                  "Y := (4 .. 6 => (6 .. 8 => 0))");
232          IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN  -- USE Y.
233               COMMENT ("Y ALTERED -- " &
234                        "Y := (4 .. 6 => (6 .. 8 => 0))");
235          END IF;
236     EXCEPTION
237          WHEN CONSTRAINT_ERROR =>
238               NULL;
239          WHEN OTHERS =>
240               FAILED ("WRONG EXCEPTION RAISED -- " &
241                       "Y := (4 .. 6 => (6 .. 8 => 0))");
242     END;
243
244     BEGIN
245          Y := (4 .. 5 => (6 .. 7 => 0));
246          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
247                  "Y := (4 .. 5 => (6 .. 7 => 0))");
248          IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN  -- USE Y.
249               COMMENT ("Y ALTERED -- " &
250                        "Y := (4 .. 5 => (6 .. 7 => 0))");
251          END IF;
252     EXCEPTION
253          WHEN CONSTRAINT_ERROR =>
254               NULL;
255          WHEN OTHERS =>
256               FAILED ("WRONG EXCEPTION RAISED -- " &
257                       "Y := (4 .. 5 => (6 .. 7 => 0))");
258     END;
259
260     BEGIN
261          Y := (4 .. 5 => (6 .. 9 => 0));
262          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
263                  "Y := (4 .. 5 => (6 .. 9 => 0))");
264          IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN  -- USE Y.
265               COMMENT ("Y ALTERED -- " &
266                        "Y := (4 .. 5 => (6 .. 9 => 0))");
267          END IF;
268     EXCEPTION
269          WHEN CONSTRAINT_ERROR =>
270               NULL;
271          WHEN OTHERS =>
272               FAILED ("WRONG EXCEPTION RAISED -- " &
273                       "Y := (4 .. 5 => (6 .. 9 => 0))");
274     END;
275
276     RESULT;
277END C34005O;
278