Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c47009a.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 -- C47009A.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 -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A
27 -- CONSTRAINED ACCESS TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED
28 -- WHEN THE VALUE OF THE OPERAND IS NOT NULL AND THE DESIGNATED
29 -- OBJECT HAS INDEX BOUNDS OR DISCRIMINANT VALUES THAT DO NOT EQUAL
30 -- THOSE SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT.
31
32 -- HISTORY:
33 -- RJW 7/23/86
34 -- DWC 07/24/87 REVISED TO MAKE THE ACCESS TYPE UNCONSTRAINED
35 -- AND TO PREVENT DEAD VARIABLE OPTIMIZATION.
36
37 WITH REPORT; USE REPORT;
38 PROCEDURE C47009A IS
39
40 BEGIN
41
42 TEST( "C47009A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
43 "DENOTES A CONSTRAINED ACCESS TYPE, CHECK " &
44 "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " &
45 "VALUE OF THE OPERAND IS NOT NULL AND THE " &
46 "DESIGNATED OBJECT HAS INDEX BOUNDS OR " &
47 "DISCRIMINANT VALUES THAT DO NOT EQUAL THOSE " &
48 "SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT" );
49
50 DECLARE
51
52 TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
53 TYPE ACC1 IS ACCESS ARR;
54 SUBTYPE ACC1S IS ACC1 (IDENT_INT (1) .. IDENT_INT (5));
55 A : ACC1;
56 B : ARR (IDENT_INT (2) .. IDENT_INT (6));
57
58 BEGIN
59 A := ACC1S'(NEW ARR'(B'FIRST .. B'LAST => 0));
60 IF A'FIRST = 1 THEN
61 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
62 "DIFFERENT FROM THOSE OF TYPE ACC1 - 1" );
63 ELSE
64 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
65 "DIFFERENT FROM THOSE OF TYPE ACC1 - 2" );
66 END IF;
67 EXCEPTION
68 WHEN CONSTRAINT_ERROR =>
69 NULL;
70 WHEN OTHERS =>
71 FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
72 "DIFFERENT FROM THOSE OF TYPE ACC1" );
73 END;
74
75 DECLARE
76
77 TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
78 OF INTEGER;
79 TYPE ACC2 IS ACCESS ARR;
80 SUBTYPE ACC2S IS ACC2 (IDENT_INT (1) .. IDENT_INT (5),
81 IDENT_INT (1) .. IDENT_INT (1));
82 A : ACC2;
83 B : ARR (IDENT_INT (1) .. IDENT_INT (5),
84 IDENT_INT (2) .. IDENT_INT (2));
85
86 BEGIN
87 A := ACC2S'(NEW ARR'(B'RANGE => (B'RANGE (2) => 0)));
88 IF A'FIRST = 1 THEN
89 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
90 "DIFFERENT FROM THOSE OF TYPE ACC2 - 1" );
91 ELSE
92 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
93 "DIFFERENT FROM THOSE OF TYPE ACC2 - 2" );
94 END IF;
95 EXCEPTION
96 WHEN CONSTRAINT_ERROR =>
97 NULL;
98 WHEN OTHERS =>
99 FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
100 "DIFFERENT FROM THOSE OF TYPE ACC2" );
101 END;
102
103 DECLARE
104
105 TYPE REC (D : INTEGER) IS
106 RECORD
107 NULL;
108 END RECORD;
109
110 TYPE ACC3 IS ACCESS REC;
111 SUBTYPE ACC3S IS ACC3 (IDENT_INT (3));
112 A : ACC3;
113 B : REC (IDENT_INT (5)) := (D => (IDENT_INT (5)));
114
115 BEGIN
116 A := ACC3S'(NEW REC'(B));
117 IF A = NULL THEN
118 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
119 "DIFFERENT FROM THOSE OF TYPE ACC3 - 1" );
120 ELSE
121 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
122 "DIFFERENT FROM THOSE OF TYPE ACC3 - 2" );
123 END IF;
124 EXCEPTION
125 WHEN CONSTRAINT_ERROR =>
126 NULL;
127 WHEN OTHERS =>
128 FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
129 "DIFFERENT FROM THOSE OF TYPE ACC3" );
130 END;
131
132 DECLARE
133
134 TYPE REC (D1,D2 : INTEGER) IS
135 RECORD
136 NULL;
137 END RECORD;
138
139 TYPE ACC4 IS ACCESS REC;
140 SUBTYPE ACC4S IS ACC4 (IDENT_INT (4), IDENT_INT (5));
141 A : ACC4;
142 B : REC (IDENT_INT (5), IDENT_INT (4)) :=
143 (D1 => (IDENT_INT (5)), D2 => (IDENT_INT (4)));
144
145 BEGIN
146 A := ACC4S'(NEW REC'(B));
147 IF A = NULL THEN
148 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
149 "DIFFERENT FROM THOSE OF TYPE ACC4 - 1" );
150 ELSE
151 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
152 "DIFFERENT FROM THOSE OF TYPE ACC4 - 2" );
153 END IF;
154 EXCEPTION
155 WHEN CONSTRAINT_ERROR =>
156 NULL;
157 WHEN OTHERS =>
158 FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " &
159 "DIFFERENT FROM THOSE OF TYPE ACC4" );
160 END;
161
162 DECLARE
163
164 PACKAGE PKG IS
165 TYPE REC (D : INTEGER) IS PRIVATE;
166
167 B : CONSTANT REC;
168 PRIVATE
169 TYPE REC (D : INTEGER) IS
170 RECORD
171 NULL;
172 END RECORD;
173
174 B : CONSTANT REC := (D => (IDENT_INT (4)));
175 END PKG;
176
177 USE PKG;
178
179 TYPE ACC5 IS ACCESS REC;
180 SUBTYPE ACC5S IS ACC5 (IDENT_INT (3));
181 A : ACC5;
182
183 BEGIN
184 A := ACC5S'(NEW REC'(B));
185 IF A = NULL THEN
186 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
187 "DIFFERENT FROM THOSE OF TYPE ACC5 - 1" );
188 ELSE
189 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
190 "DIFFERENT FROM THOSE OF TYPE ACC5 - 2" );
191 END IF;
192 EXCEPTION
193 WHEN CONSTRAINT_ERROR =>
194 NULL;
195 WHEN OTHERS =>
196 FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " &
197 "DIFFERENT FROM THOSE OF TYPE ACC5" );
198 END;
199
200 DECLARE
201
202 PACKAGE PKG1 IS
203 TYPE REC (D : INTEGER) IS LIMITED PRIVATE;
204 TYPE ACC6 IS ACCESS REC;
205 SUBTYPE ACC6S IS ACC6 (IDENT_INT (6));
206
207 FUNCTION F RETURN ACC6;
208 PRIVATE
209 TYPE REC (D : INTEGER) IS
210 RECORD
211 NULL;
212 END RECORD;
213 END PKG1;
214
215 PACKAGE BODY PKG1 IS
216
217 FUNCTION F RETURN ACC6 IS
218 BEGIN
219 RETURN NEW REC'(D => IDENT_INT (5));
220 END F;
221
222 END PKG1;
223
224 PACKAGE PKG2 IS END PKG2;
225
226 PACKAGE BODY PKG2 IS
227 USE PKG1;
228
229 A : ACC6;
230
231 BEGIN
232 A := ACC6S'(F);
233 IF A = NULL THEN
234 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
235 "DIFFERENT FROM THOSE OF TYPE ACC6 - 1" );
236 ELSE
237 FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
238 "DIFFERENT FROM THOSE OF TYPE ACC6 - 2" );
239 END IF;
240 EXCEPTION
241 WHEN CONSTRAINT_ERROR =>
242 NULL;
243 WHEN OTHERS =>
244 FAILED ( "WRONG EXCEPTION RAISED FOR DISC " &
245 "VALUES DIFFERENT FROM THOSE OF TYPE " &
246 "ACC6" );
247 END PKG2;
248
249 BEGIN
250 NULL;
251 END;
252
253 RESULT;
254 END C47009A;