1-- C48009E.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-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
26-- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND:
27--   1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE
28--      CORRESPONDING BOUND FOR T;
29--   2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN
30--      THE DECLARATION OF THE ALLOCATOR'S BASE TYPE;
31--   3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS
32--      REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE.
33
34 -- RM  01/08/80
35 -- NL  10/13/81
36 -- SPS 10/26/82
37 -- JBG 03/03/83
38 -- EG  07/05/84
39 -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
40 -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE
41 -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS
42 -- PWN 05/03/96 Enforced Ada 95 sliding rules
43 -- PWN 10/24/96 Adjusted expected results for Ada 95.
44 -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES
45 -- MRM 12/16/96 Removed problem code from withdrawn version of test, and
46 --              implemented a dereference-index check to ensure Ada95
47 --              required behavior.
48 -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does
49 --                  not occur
50 WITH REPORT;
51
52 PROCEDURE  C48009E  IS
53
54      USE REPORT ;
55
56 BEGIN
57
58      TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
59                     "THAT CONSTRAINT_ERROR IS RAISED WHEN "          &
60                     "APPROPRIATE - CONSTRAINED ARRAY TYPES");
61      DECLARE
62
63           TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
64           TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER;
65           TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER;
66           TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER;
67           SUBTYPE CA2_6 IS UA(2 .. 6);
68           SUBTYPE CA1_4 IS UA(1 .. 4);
69           SUBTYPE CA1_6 IS UA(1 .. 6);
70           SUBTYPE CA4_1 IS UA(4 .. 1);
71           SUBTYPE CA4_2 IS UA(4 .. 2);
72
73           TYPE A_CA3_2 IS ACCESS CA3_2;
74           TYPE A_SA1_3 IS ACCESS SA1_3;
75           TYPE A_NA1_3 IS ACCESS NA1_3;
76           TYPE A_CA1_5 IS ACCESS UA(1 .. 5);
77           TYPE A_CA4_2 IS ACCESS CA4_2;
78
79           V_A_CA3_2 : A_CA3_2;
80           V_A_SA1_3 : A_SA1_3;
81           V_A_NA1_3 : A_NA1_3;
82           V_A_CA1_5 : A_CA1_5;
83
84           FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS
85           BEGIN
86                IF EQUAL(1, 1) THEN
87                     RETURN NEW CA2_6'(X);
88                ELSE
89                     RETURN NULL;
90                END IF;
91           END ALLOC1;
92           FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS
93           BEGIN
94                IF EQUAL(1, 1) THEN
95                     RETURN NEW CA4_1'(X);
96                ELSE
97                     RETURN NULL;
98                END IF;
99           END ALLOC2;
100
101      BEGIN
102
103          BEGIN
104               V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2)
105                                       => 5);
106               FAILED ("NO EXCEPTION RAISED - CASE 1A");
107          EXCEPTION
108               WHEN CONSTRAINT_ERROR =>
109                    NULL;
110               WHEN OTHERS =>
111                    FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
112          END;
113
114           BEGIN
115                V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4);
116                FAILED ("NO EXCEPTION RAISED - CASE 1B");
117           EXCEPTION
118                WHEN CONSTRAINT_ERROR =>
119                     NULL;
120                WHEN OTHERS =>
121                     FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
122           END;
123
124           BEGIN
125                -- note that ALLOC1 returns A_CA1_5, so both
126                -- (1) and (5) are valid index references!
127                IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN
128                     FAILED ("Wrong Value Returned - CASE 2A");
129                ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN
130                     FAILED ("Unlikely Index Case - CASE 2A");
131                END IF;
132           EXCEPTION
133                WHEN OTHERS =>
134                     FAILED ("EXCEPTION RAISED - CASE 2A");
135           END;
136
137           BEGIN
138                IF ALLOC2((4 .. 1 => 3)) = NULL THEN
139                     FAILED ("IMPOSSIBLE - CASE 2B");
140                END IF;
141                COMMENT ("ADA 95 SLIDING ASSIGNMENT");
142           EXCEPTION
143                WHEN CONSTRAINT_ERROR =>
144                     FAILED ("ADA 83 NON-SLIDING ASSIGNMENT");
145                WHEN OTHERS =>
146                     FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
147           END;
148
149           BEGIN
150                V_A_SA1_3 := NEW SA1_3'(1, 2);
151                FAILED ("NO EXCEPTION RAISED - CASE 3A");
152           EXCEPTION
153                WHEN CONSTRAINT_ERROR =>
154                     NULL;
155                WHEN OTHERS =>
156                     FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
157           END;
158
159           BEGIN
160                V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6);
161                FAILED ("NO EXCEPTION RAISED - CASE 3B");
162           EXCEPTION
163                WHEN CONSTRAINT_ERROR =>
164                     NULL;
165                WHEN OTHERS =>
166                     FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
167           END;
168
169           BEGIN
170                V_A_NA1_3 := NEW NA1_3'(1, 2);
171                FAILED ("NO EXCEPTION RAISED - CASE 3C");
172           EXCEPTION
173                WHEN CONSTRAINT_ERROR =>
174                     NULL;
175                WHEN OTHERS =>
176                     FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
177           END;
178
179           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
180                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4);
181                FAILED ("NO EXCEPTION RAISED - CASE 3D");
182           EXCEPTION
183                WHEN CONSTRAINT_ERROR =>
184                     NULL;
185                WHEN OTHERS =>
186                     FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
187           END;
188
189           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
190                V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6);
191                FAILED ("NO EXCEPTION RAISED - CASE 3E");
192           EXCEPTION
193                WHEN CONSTRAINT_ERROR =>
194                     NULL;
195                WHEN OTHERS =>
196                     FAILED ("WRONG EXCEPTION RAISED - CASE 3E");
197           END;
198
199           BEGIN -- SATISFIES BASE TYPE BUT NOT T.
200                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5);
201                FAILED ("NO EXCEPTION RAISED - CASE 3F");
202           EXCEPTION
203                WHEN CONSTRAINT_ERROR =>
204                     NULL;
205                WHEN OTHERS =>
206                     FAILED ("WRONG EXCEPTION RAISED - CASE 3F");
207           END;
208
209          BEGIN -- SATISFIES BASE TYPE BUT NOT T.
210               V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5);
211               FAILED ("NO EXCEPTION RAISED - CASE 3G");
212          EXCEPTION
213               WHEN CONSTRAINT_ERROR =>
214                    NULL;
215               WHEN OTHERS =>
216                    FAILED ("WRONG EXCEPTION RAISED - CASE 3G");
217          END;
218
219      END ;
220
221      RESULT ;
222
223 END C48009E ;
224
225