1-- C64103C.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 THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
26-- ON IN OUT ARRAY PARAMETERS.  IN PARTICULAR:
27--   (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
28--       COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
29--       CONSTRAINTS.
30--   (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
31--       AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
32--       OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE
33--       AI-00313 FOR MULTIDIMENSIONAL CASE)
34--   (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
35--       CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
36--       DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
37--   (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
38--       UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
39--       OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
40
41-- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
42-- ***       remove incompatibilities associated with the transition   -- 9X
43-- ***       to Ada 9X.                                                -- 9X
44-- ***                                                                 -- 9X
45
46-- CPP 07/19/84
47-- JBG 06/05/85
48-- EG  10/29/85  FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
49--               AI-00387.
50-- MRM 03/30/93  REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
51-- PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
52
53WITH SYSTEM;
54WITH REPORT;  USE REPORT;
55PROCEDURE C64103C IS
56
57     BEGIN
58     TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
59           "TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS");
60
61     -----------------------------------------------
62
63     DECLARE   -- (A)
64     BEGIN     -- (A)
65
66          DECLARE
67               TYPE SUBINT IS RANGE 0..8;
68               TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
69               A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
70
71               PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS
72               BEGIN
73                    NULL;
74               END P2;
75          BEGIN
76               P2 (ARRAY_TYPE (A0));                  -- OK.
77          EXCEPTION
78               WHEN OTHERS =>
79                    FAILED ("EXCEPTION RAISED -P2 (A)");
80          END;
81
82     END; -- (A)
83
84     -----------------------------------------------
85
86     DECLARE   -- (B1) NON-NULL ACTUAL PARAMETER
87
88          TYPE SUBINT IS RANGE 0..8;
89          TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
90          TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
91          A1 : AR1 (-1..7) := (-1..7 => TRUE);
92          A2 : AR1 (1..9) := (1..9 => TRUE);
93
94          PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
95          BEGIN
96               FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
97          END P1;
98
99     BEGIN     -- (B1)
100
101          BEGIN
102               COMMENT ("CALL TO P1 (B1) ON A1");
103               P1 (ARRAY_TYPE (A1));
104          EXCEPTION
105               WHEN CONSTRAINT_ERROR =>
106                    NULL;
107               WHEN OTHERS =>
108                    FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
109          END;
110
111          BEGIN
112               COMMENT ("CALL TO P1 (B1) ON A2");
113               P1 (ARRAY_TYPE (A2));
114          EXCEPTION
115               WHEN CONSTRAINT_ERROR =>
116                    NULL;
117               WHEN OTHERS =>
118                    FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
119          END;
120
121     END; -- (B1)
122
123     DECLARE   -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL
124
125          TYPE SUBINT IS RANGE 0..8;
126          TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>,
127                                    SUBINT RANGE <>) OF BOOLEAN;
128          TYPE AR1 IS ARRAY (INTEGER RANGE <>,
129                             INTEGER RANGE <>)OF BOOLEAN;
130          A1 : AR1 (IDENT_INT(-1)..7, 5..4) :=
131                                           (OTHERS => (OTHERS => TRUE));
132          A2 : AR1 (5..4, 1..IDENT_INT(9)) :=
133                                           (OTHERS => (OTHERS => TRUE));
134          PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
135          BEGIN
136               FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
137          END P1;
138
139     BEGIN     -- (B2)
140
141          BEGIN
142               COMMENT ("CALL TO P1 (B2) ON A1");
143               P1 (ARRAY_TYPE (A1));
144          EXCEPTION
145               WHEN CONSTRAINT_ERROR =>
146                    NULL;
147               WHEN OTHERS =>
148                    FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
149          END;
150
151          BEGIN
152               COMMENT ("CALL TO P1 (B2) ON A2");
153               P1 (ARRAY_TYPE (A2));
154          EXCEPTION
155               WHEN CONSTRAINT_ERROR =>
156                    NULL;
157               WHEN OTHERS =>
158                    FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
159          END;
160
161     END; -- (B2)
162
163     -----------------------------------------------
164
165     BEGIN     -- (C)
166
167          DECLARE
168               TYPE INDEX1 IS RANGE 1..3;
169               TYPE INDEX2 IS RANGE 1..4;
170               TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
171               A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
172
173               TYPE I1 IS RANGE 1..4;
174               TYPE I2 IS RANGE 1..3;
175               TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
176
177               PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
178               BEGIN
179                    FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
180               END P1;
181          BEGIN
182               P1 (ARRAY_TYPE (A0));
183          EXCEPTION
184               WHEN CONSTRAINT_ERROR =>
185                    NULL;
186               WHEN OTHERS =>
187                    FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
188          END;
189
190     END; -- (C)
191
192     -----------------------------------------------
193
194     DECLARE   -- (D)
195     BEGIN     -- (D)
196
197          DECLARE
198               TYPE SM_INT IS RANGE 0..2;
199               TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT;
200               SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 ..
201                                          SYSTEM.MAX_INT;
202               TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
203               TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
204               A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
205                    (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
206
207               PROCEDURE P1 (X : IN OUT AR_SMALL) IS
208               BEGIN
209                    FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
210               END P1;
211          BEGIN
212               IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
213                    P1 (AR_SMALL (A0));
214               ELSE
215                    COMMENT ("NOT APPLICABLE -P1 (D)");
216               END IF;
217          EXCEPTION
218               WHEN CONSTRAINT_ERROR =>
219                    COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
220               WHEN OTHERS =>
221                    FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
222          END;
223
224     END; -- (D)
225
226     -----------------------------------------------
227
228     RESULT;
229
230END C64103C;
231