Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c3/c34006f.ada @ 111:04ced10e8804
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 -- C34006F.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 -- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED | |
27 -- COMPONENT TYPES: | |
28 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR | |
29 -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS | |
30 -- CONSTRAINED. | |
31 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO | |
32 -- IMPOSED ON THE DERIVED SUBTYPE. | |
33 | |
34 -- HISTORY: | |
35 -- JRK 9/22/86 CREATED ORIGINAL TEST. | |
36 | |
37 WITH REPORT; USE REPORT; | |
38 | |
39 PROCEDURE C34006F IS | |
40 | |
41 SUBTYPE COMPONENT IS INTEGER; | |
42 | |
43 PACKAGE PKG IS | |
44 | |
45 MAX_LEN : CONSTANT := 10; | |
46 | |
47 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; | |
48 | |
49 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS | |
50 RECORD | |
51 I : INTEGER; | |
52 CASE B IS | |
53 WHEN TRUE => | |
54 S : STRING (1 .. L); | |
55 C : COMPONENT; | |
56 WHEN FALSE => | |
57 F : FLOAT := 5.0; | |
58 END CASE; | |
59 END RECORD; | |
60 | |
61 FUNCTION CREATE ( B : BOOLEAN; | |
62 L : LENGTH; | |
63 I : INTEGER; | |
64 S : STRING; | |
65 C : COMPONENT; | |
66 F : FLOAT; | |
67 X : PARENT -- TO RESOLVE OVERLOADING. | |
68 ) RETURN PARENT; | |
69 | |
70 END PKG; | |
71 | |
72 USE PKG; | |
73 | |
74 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); | |
75 | |
76 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); | |
77 | |
78 TYPE S IS NEW SUBPARENT; | |
79 | |
80 X : T := (TRUE, 3, 2, "AAA", 2); | |
81 Y : S := (TRUE, 3, 2, "AAA", 2); | |
82 | |
83 PACKAGE BODY PKG IS | |
84 | |
85 FUNCTION CREATE | |
86 ( B : BOOLEAN; | |
87 L : LENGTH; | |
88 I : INTEGER; | |
89 S : STRING; | |
90 C : COMPONENT; | |
91 F : FLOAT; | |
92 X : PARENT | |
93 ) RETURN PARENT | |
94 IS | |
95 BEGIN | |
96 CASE B IS | |
97 WHEN TRUE => | |
98 RETURN (TRUE, L, I, S, C); | |
99 WHEN FALSE => | |
100 RETURN (FALSE, L, I, F); | |
101 END CASE; | |
102 END CREATE; | |
103 | |
104 END PKG; | |
105 | |
106 BEGIN | |
107 TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & | |
108 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & | |
109 "WHEN THE DERIVED TYPE DEFINITION IS " & | |
110 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & | |
111 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & | |
112 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & | |
113 "RECORD TYPES WITH DISCRIMINANTS AND WITH " & | |
114 "NON-LIMITED COMPONENT TYPES"); | |
115 | |
116 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. | |
117 | |
118 BEGIN | |
119 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= | |
120 (FALSE, 2, 3, 6.0) OR | |
121 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= | |
122 (FALSE, 2, 3, 6.0) THEN | |
123 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & | |
124 "SUBTYPE"); | |
125 END IF; | |
126 EXCEPTION | |
127 WHEN CONSTRAINT_ERROR => | |
128 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); | |
129 WHEN OTHERS => | |
130 FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); | |
131 END; | |
132 | |
133 BEGIN | |
134 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR | |
135 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN | |
136 FAILED ("INCORRECT ""IN"""); | |
137 END IF; | |
138 EXCEPTION | |
139 WHEN CONSTRAINT_ERROR => | |
140 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); | |
141 WHEN OTHERS => | |
142 FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); | |
143 END; | |
144 | |
145 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. | |
146 | |
147 IF X.B /= TRUE OR X.L /= 3 OR | |
148 Y.B /= TRUE OR Y.L /= 3 THEN | |
149 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); | |
150 END IF; | |
151 | |
152 IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN | |
153 FAILED ("INCORRECT 'CONSTRAINED"); | |
154 END IF; | |
155 | |
156 BEGIN | |
157 X := (TRUE, 3, 1, "ABC", 4); | |
158 Y := (TRUE, 3, 1, "ABC", 4); | |
159 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. | |
160 FAILED ("INCORRECT CONVERSION TO PARENT"); | |
161 END IF; | |
162 EXCEPTION | |
163 WHEN OTHERS => | |
164 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); | |
165 END; | |
166 | |
167 BEGIN | |
168 X := (FALSE, 3, 2, 6.0); | |
169 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & | |
170 "X := (FALSE, 3, 2, 6.0)"); | |
171 IF X = (FALSE, 3, 2, 6.0) THEN -- USE X. | |
172 COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)"); | |
173 END IF; | |
174 EXCEPTION | |
175 WHEN CONSTRAINT_ERROR => | |
176 NULL; | |
177 WHEN OTHERS => | |
178 FAILED ("WRONG EXCEPTION RAISED -- " & | |
179 "X := (FALSE, 3, 2, 6.0)"); | |
180 END; | |
181 | |
182 BEGIN | |
183 X := (TRUE, 4, 2, "ZZZZ", 6); | |
184 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & | |
185 "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
186 IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. | |
187 COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
188 END IF; | |
189 EXCEPTION | |
190 WHEN CONSTRAINT_ERROR => | |
191 NULL; | |
192 WHEN OTHERS => | |
193 FAILED ("WRONG EXCEPTION RAISED -- " & | |
194 "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
195 END; | |
196 | |
197 BEGIN | |
198 Y := (FALSE, 3, 2, 6.0); | |
199 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & | |
200 "Y := (FALSE, 3, 2, 6.0)"); | |
201 IF Y = (FALSE, 3, 2, 6.0) THEN -- USE Y. | |
202 COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)"); | |
203 END IF; | |
204 EXCEPTION | |
205 WHEN CONSTRAINT_ERROR => | |
206 NULL; | |
207 WHEN OTHERS => | |
208 FAILED ("WRONG EXCEPTION RAISED -- " & | |
209 "Y := (FALSE, 3, 2, 6.0)"); | |
210 END; | |
211 | |
212 BEGIN | |
213 Y := (TRUE, 4, 2, "ZZZZ", 6); | |
214 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & | |
215 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
216 IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. | |
217 COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
218 END IF; | |
219 EXCEPTION | |
220 WHEN CONSTRAINT_ERROR => | |
221 NULL; | |
222 WHEN OTHERS => | |
223 FAILED ("WRONG EXCEPTION RAISED -- " & | |
224 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); | |
225 END; | |
226 | |
227 RESULT; | |
228 END C34006F; |