Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c43004c.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 -- C43004C.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 -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A
27 -- DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES
28 -- NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE
29 -- COMPONENT'S SUBTYPE.
30
31 -- HISTORY:
32 -- BCB 07/19/88 CREATED ORIGINAL TEST.
33
34 WITH REPORT; USE REPORT;
35
36 PROCEDURE C43004C IS
37
38 ZERO : INTEGER := 0;
39
40 TYPE REC (D : INTEGER := 0) IS RECORD
41 COMP1 : INTEGER;
42 END RECORD;
43
44 TYPE DREC (DD : INTEGER := ZERO) IS RECORD
45 DCOMP1 : INTEGER;
46 END RECORD;
47
48 TYPE REC1 IS RECORD
49 A : REC(0);
50 END RECORD;
51
52 TYPE REC2 IS RECORD
53 B : DREC(ZERO);
54 END RECORD;
55
56 TYPE REC3 (D3 : INTEGER := 0) IS RECORD
57 C : REC(D3);
58 END RECORD;
59
60 V : REC1;
61 W : REC2;
62 X : REC3;
63
64 PACKAGE P IS
65 TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE;
66 TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE;
67 FUNCTION INIT (I : INTEGER) RETURN PRIV1;
68 PRIVATE
69 TYPE PRIV1 (D : INTEGER := 0) IS RECORD
70 NULL;
71 END RECORD;
72
73 TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD
74 NULL;
75 END RECORD;
76 END P;
77
78 TYPE REC7 IS RECORD
79 H : P.PRIV1 (0);
80 END RECORD;
81
82 Y : REC7;
83
84 GENERIC
85 TYPE GP IS PRIVATE;
86 FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN;
87
88 FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS
89 BEGIN
90 RETURN X = Y;
91 END GEN_EQUAL;
92
93 PACKAGE BODY P IS
94 TYPE REC4 IS RECORD
95 E : PRIV1(0);
96 END RECORD;
97
98 TYPE REC5 IS RECORD
99 F : PRIV2(ZERO);
100 END RECORD;
101
102 TYPE REC6 (D6 : INTEGER := 0) IS RECORD
103 G : PRIV1(D6);
104 END RECORD;
105
106 VV : REC4;
107 WW : REC5;
108 XX : REC6;
109
110 FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4);
111 FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5);
112 FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6);
113
114 FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS
115 VAR : PRIV1;
116 BEGIN
117 VAR := (D => I);
118 RETURN VAR;
119 END INIT;
120 BEGIN
121 TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
122 "IF THE VALUE OF A DISCRIMINANT OF A " &
123 "CONSTRAINED COMPONENT OF AN AGGREGATE " &
124 "DOES NOT EQUAL THE CORRESPONDING " &
125 "DISCRIMINANT VALUE FOR THECOMPONENT'S " &
126 "SUBTYPE");
127
128 BEGIN
129 VV := (E => (D => 1));
130 FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
131 IF REC4_EQUAL (VV,VV) THEN
132 COMMENT ("DON'T OPTIMIZE VV");
133 END IF;
134 EXCEPTION
135 WHEN CONSTRAINT_ERROR =>
136 NULL;
137 WHEN OTHERS =>
138 FAILED ("OTHER EXCEPTION RAISED - 1");
139 END;
140
141 BEGIN
142 WW := (F => (DD => 1));
143 FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
144 IF REC5_EQUAL (WW,WW) THEN
145 COMMENT ("DON'T OPTIMIZE WW");
146 END IF;
147 EXCEPTION
148 WHEN CONSTRAINT_ERROR =>
149 NULL;
150 WHEN OTHERS =>
151 FAILED ("OTHER EXCEPTION RAISED - 2");
152 END;
153
154 BEGIN
155 XX := (D6 => 1, G => (D => 5));
156 FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
157 IF REC6_EQUAL (XX,XX) THEN
158 COMMENT ("DON'T OPTIMIZE XX");
159 END IF;
160 EXCEPTION
161 WHEN CONSTRAINT_ERROR =>
162 NULL;
163 WHEN OTHERS =>
164 FAILED ("OTHER EXCEPTION RAISED - 3");
165 END;
166 END P;
167
168 USE P;
169
170 FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
171 FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2);
172 FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3);
173 FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7);
174
175 BEGIN
176
177 BEGIN
178 V := (A => (D => 1, COMP1 => 2));
179 FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
180 IF REC1_EQUAL (V,V) THEN
181 COMMENT ("DON'T OPTIMIZE V");
182 END IF;
183 EXCEPTION
184 WHEN CONSTRAINT_ERROR =>
185 NULL;
186 WHEN OTHERS =>
187 FAILED ("OTHER EXCEPTION RAISED - 4");
188 END;
189
190 BEGIN
191 W := (B => (DD => 1, DCOMP1 => 2));
192 FAILED ("CONSTRAINT_ERROR NOT RAISED - 5");
193 IF REC2_EQUAL (W,W) THEN
194 COMMENT ("DON'T OPTIMIZE W");
195 END IF;
196 EXCEPTION
197 WHEN CONSTRAINT_ERROR =>
198 NULL;
199 WHEN OTHERS =>
200 FAILED ("OTHER EXCEPTION RAISED - 5");
201 END;
202
203 BEGIN
204 X := (D3 => 1, C => (D => 5, COMP1 => 2));
205 FAILED ("CONSTRAINT_ERROR NOT RAISED - 6");
206 IF REC3_EQUAL (X,X) THEN
207 COMMENT ("DON'T OPTIMIZE X");
208 END IF;
209 EXCEPTION
210 WHEN CONSTRAINT_ERROR =>
211 NULL;
212 WHEN OTHERS =>
213 FAILED ("OTHER EXCEPTION RAISED - 6");
214 END;
215
216 BEGIN
217 Y := (H => INIT (1));
218 FAILED ("CONSTRAINT_ERROR NOT RAISED - 7");
219 IF REC7_EQUAL (Y,Y) THEN
220 COMMENT ("DON'T OPTIMIZE Y");
221 END IF;
222 EXCEPTION
223 WHEN CONSTRAINT_ERROR =>
224 NULL;
225 WHEN OTHERS =>
226 FAILED ("OTHER EXCEPTION RAISED - 7");
227 END;
228
229 RESULT;
230 END C43004C;