Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c5/c52104x.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C52104X.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
26 -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
27 -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
28 -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
29 -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
30 -- ARE TREATED ELSEWHERE.)
31
32 -- THIS IS A SPECIAL CASE IN
33
34 -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
35 -- STATICALLY
36
37 -- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST .
38 -- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH
39 -- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE
40 -- CONSTRAINT_ERROR TO BE RAISED.
41
42 -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
43 -- *** remove incompatibilities associated with the transition -- 9X
44 -- *** to Ada 9X. -- 9X
45 -- *** -- 9X
46
47 -- RM 07/31/81
48 -- SPS 02/07/83
49 -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
50 -- AI-00387.
51 -- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR.
52 -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X INCOMPATIBILITY
53
54 WITH REPORT;
55 PROCEDURE C52104X IS
56
57 USE REPORT ;
58
59 BEGIN
60
61 TEST( "C52104X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " &
62 "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " &
63 "CHECK WHETHER CONSTRAINT_ERROR " &
64 "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS");
65
66 -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
67 -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
68 --
69 -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
70 -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
71
72
73 -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
74 -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
75 -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
76 -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
77 -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
78 -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
79 -- INTEGER , CHARACTER , BOOLEAN .)
80
81
82 -------------------------------------------------------------------
83
84 -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
85 -- WERE DEFINED USING THE "BOX" SYMBOL
86 -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
87 -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
88
89 CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR
90 -- FOR THE SUBTYPE DECLARATION.
91 BEGIN
92
93 DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY SUBTYPE.
94
95 TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
96 PRAGMA PACK (TABOX5);
97
98 SUBTYPE TABOX51 IS TABOX5
99 (IDENT_INT(-6)..IDENT_INT(INTEGER'LAST-4));
100 -- CONSTRAINT_ERROR MAY BE RAISED BY THIS
101 -- SUBTYPE DECLARATION.
102
103 BEGIN
104
105 COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " &
106 "WITH 'LENGTH = INTEGER'LAST + 3");
107
108 OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT
109 -- HAVE INTEGER'LAST + 3 COMPONENTS;
110 -- STORAGE_ERROR MAY BE RAISED.
111 ARRX51 : TABOX51 ;
112 ARRX52 : TABOX5
113 (IDENT_INT(-2)..IDENT_INT( INTEGER'LAST));
114
115 BEGIN
116
117 COMMENT ("NO STORAGE_ERROR OR " &
118 "CONSTRAINT_ERROR RAISED WHEN ALLOCATING TWO " &
119 "BIG BOOLEAN ARRAYS");
120
121 -- INITIALIZATION OF LHS ARRAY:
122
123 NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR IN THIS BLOCK
124 FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP
125 ARRX52( I ) := FALSE ;
126 END LOOP;
127
128
129 -- INITIALIZATION OF RHS ARRAY:
130
131 -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED,
132 -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG
133 -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH
134 -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED.
135
136 FOR I IN IDENT_INT(-6)..IDENT_INT(5) LOOP
137 ARRX51( I ) := TRUE ;
138 END LOOP;
139
140 EXCEPTION
141
142 WHEN CONSTRAINT_ERROR =>
143 FAILED ("CONSTRAINT_ERROR RAISED WHEN " &
144 "ASSIGNING TO ARRAY COMPONENTS");
145 WHEN OTHERS =>
146 FAILED ("OTHER EXCEPTION RAISED - 1");
147
148 END NO_EXCP;
149
150 DO_SLICE: BEGIN
151 -- SLICE ASSIGNMENT:
152
153 ARRX52( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) :=
154 ARRX51(
155 IDENT_INT(-4)..IDENT_INT(INTEGER'LAST-4) ) ;
156 FAILED( "EXCEPTION NOT RAISED (12)" );
157
158 EXCEPTION
159
160 WHEN CONSTRAINT_ERROR =>
161
162 COMMENT ("CONSTRAINT_ERROR RAISED DURING " &
163 "CHECK FOR SLICE ASSIGNMENT");
164
165 -- CHECKING THE VALUES AFTER THE SLICE
166 -- ASSIGNMENT:
167
168 FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP
169
170 IF ARRX52( I ) /= FALSE
171 THEN
172 FAILED( "LHS ARRAY ALTERED (12A)");
173 END IF;
174
175 END LOOP;
176
177
178 WHEN STORAGE_ERROR =>
179 COMMENT ("STORAGE_ERROR RAISED DURING CHECK " &
180 "FOR SLICE ASSIGNMENT");
181
182 WHEN OTHERS =>
183 FAILED ("SOME EXCEPTION RAISED DURING SLICE");
184
185 END DO_SLICE;
186
187 END OBJ_DCL;
188
189 EXCEPTION
190
191 WHEN STORAGE_ERROR =>
192 COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " &
193 "TWO PACKED BOOLEAN ARRAYS WITH " &
194 "INTEGER'LAST + 3 COMPONENTS");
195 WHEN CONSTRAINT_ERROR =>
196 COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " &
197 "TWO PACKED BOOLEAN ARRAYS WITH " &
198 "INTEGER'LAST + 3 COMPONENTS");
199 WHEN OTHERS =>
200 FAILED ("SOME EXCEPTION RAISED - 3");
201
202 END DCL_ARR;
203
204 EXCEPTION
205
206
207 WHEN CONSTRAINT_ERROR =>
208 COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " &
209 "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " &
210 "COMPONENTS");
211
212 WHEN STORAGE_ERROR =>
213 FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION");
214
215 WHEN OTHERS =>
216 FAILED ("OTHER EXCEPTION RAISED - 4");
217
218 END CONSTR_ERR;
219
220 RESULT ;
221
222 END C52104X;