Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c6/c64106b.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 -- C64106B.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED RECORD, | |
26 -- PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT CONSTRAINTS | |
27 -- RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE THE | |
28 -- CONSTRAINT OF THE ACTUAL PARAMETER. | |
29 -- SUBTESTS ARE: | |
30 -- (A) RECORD TYPE. | |
31 -- (B) PRIVATE TYPE. | |
32 -- (C) LIMITED PRIVATE TYPE. | |
33 | |
34 -- DAS 1/15/81 | |
35 -- CPP 8/9/84 | |
36 | |
37 WITH REPORT; | |
38 PROCEDURE C64106B IS | |
39 | |
40 USE REPORT; | |
41 | |
42 BEGIN | |
43 | |
44 TEST ("C64106B", "CHECK ASSIGNMENT TO FORMAL PARAMETERS OF " & | |
45 "UNCONSTRAINED TYPE (WITH NO DEFAULT)"); | |
46 | |
47 -------------------------------------------------- | |
48 | |
49 DECLARE -- (A) | |
50 | |
51 PACKAGE PKG IS | |
52 | |
53 TYPE RECTYPE (CONSTRAINT : INTEGER) IS | |
54 RECORD | |
55 INTFIELD : INTEGER; | |
56 STRFIELD : STRING (1..CONSTRAINT); | |
57 END RECORD; | |
58 | |
59 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
60 REC6 : IN OUT RECTYPE); | |
61 END PKG; | |
62 | |
63 REC9 : PKG.RECTYPE(IDENT_INT(9)) := | |
64 (IDENT_INT(9), 9, "123456789"); | |
65 REC6 : PKG.RECTYPE(IDENT_INT(6)) := | |
66 (IDENT_INT(6), 5, "AEIOUY"); | |
67 | |
68 PACKAGE BODY PKG IS | |
69 | |
70 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
71 REC6 : IN OUT RECTYPE) IS | |
72 | |
73 REC4 : CONSTANT RECTYPE(IDENT_INT(4)) := | |
74 (IDENT_INT(4), 4, "OOPS"); | |
75 | |
76 BEGIN | |
77 BEGIN -- (A.1) | |
78 REC9 := REC6; | |
79 FAILED ("CONSTRAINT_ERROR NOT RAISED - A.1"); | |
80 EXCEPTION | |
81 WHEN CONSTRAINT_ERROR => | |
82 NULL; | |
83 WHEN OTHERS => | |
84 FAILED ("WRONG EXCEPTION RAISED - A.1"); | |
85 END; -- (A.1) | |
86 | |
87 BEGIN -- (A.2) | |
88 REC6 := REC4; | |
89 FAILED ("CONSTRAINT_ERROR NOT RAISED - A.2"); | |
90 EXCEPTION | |
91 WHEN CONSTRAINT_ERROR => | |
92 NULL; | |
93 WHEN OTHERS => | |
94 FAILED ("WRONG EXCEPTION RAISED - A.2"); | |
95 END; -- (A.2) | |
96 | |
97 REC9 := (IDENT_INT(9), 9, "987654321"); | |
98 | |
99 END CHK_RECTYPE; | |
100 END PKG; | |
101 | |
102 BEGIN -- (A) | |
103 | |
104 PKG.CHK_RECTYPE (REC9, REC6); | |
105 IF REC9.STRFIELD /= IDENT_STR("987654321") THEN | |
106 FAILED ("ASSIGNMENT TO REC9 FAILED - (A)"); | |
107 END IF; | |
108 | |
109 END; -- (A) | |
110 | |
111 -------------------------------------------------- | |
112 | |
113 DECLARE -- (B) | |
114 | |
115 PACKAGE PKG IS | |
116 | |
117 TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE; | |
118 | |
119 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
120 REC6 : IN OUT RECTYPE); | |
121 PRIVATE | |
122 TYPE RECTYPE (CONSTRAINT : INTEGER) IS | |
123 RECORD | |
124 INTFIELD : INTEGER; | |
125 STRFIELD : STRING (1..CONSTRAINT); | |
126 END RECORD; | |
127 END PKG; | |
128 | |
129 REC9 : PKG.RECTYPE(9); | |
130 REC6 : PKG.RECTYPE(6); | |
131 | |
132 PACKAGE BODY PKG IS | |
133 | |
134 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
135 REC6 : IN OUT RECTYPE) IS | |
136 | |
137 REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); | |
138 | |
139 BEGIN | |
140 BEGIN -- (B.1) | |
141 REC9 := REC6; | |
142 FAILED ("CONSTRAINT_ERROR NOT RAISED - B.1"); | |
143 EXCEPTION | |
144 WHEN CONSTRAINT_ERROR => | |
145 NULL; | |
146 WHEN OTHERS => | |
147 FAILED ("WRONG EXCEPTION RAISED - B.1"); | |
148 END; -- (B.1) | |
149 | |
150 BEGIN -- (B.2) | |
151 REC6 := REC4; | |
152 FAILED ("CONSTRAINT_ERROR NOT RAISED - B.2"); | |
153 EXCEPTION | |
154 WHEN CONSTRAINT_ERROR => | |
155 NULL; | |
156 WHEN OTHERS => | |
157 FAILED ("WRONG EXCEPTION RAISED - B.2"); | |
158 END; -- (B.2) | |
159 END CHK_RECTYPE; | |
160 | |
161 BEGIN | |
162 REC9 := (9, 9, "123456789"); | |
163 REC6 := (6, 5, "AEIOUY"); | |
164 END PKG; | |
165 | |
166 BEGIN -- (B) | |
167 | |
168 PKG.CHK_RECTYPE (REC9, REC6); | |
169 | |
170 END; -- (B) | |
171 | |
172 -------------------------------------------------- | |
173 | |
174 DECLARE -- (C) | |
175 | |
176 PACKAGE PKG IS | |
177 | |
178 TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE; | |
179 | |
180 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
181 REC6 : IN OUT RECTYPE); | |
182 PRIVATE | |
183 TYPE RECTYPE (CONSTRAINT : INTEGER) IS | |
184 RECORD | |
185 INTFIELD : INTEGER; | |
186 STRFIELD : STRING (1..CONSTRAINT); | |
187 END RECORD; | |
188 END PKG; | |
189 | |
190 REC6 : PKG.RECTYPE(IDENT_INT(6)); | |
191 REC9 : PKG.RECTYPE(IDENT_INT(9)); | |
192 | |
193 PACKAGE BODY PKG IS | |
194 | |
195 PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; | |
196 REC6 : IN OUT RECTYPE) IS | |
197 | |
198 REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); | |
199 | |
200 BEGIN | |
201 BEGIN -- (C.1) | |
202 REC9 := REC6; | |
203 FAILED ("CONSTRAINT_ERROR NOT RAISED - C.1"); | |
204 EXCEPTION | |
205 WHEN CONSTRAINT_ERROR => | |
206 NULL; | |
207 WHEN OTHERS => | |
208 FAILED ("WRONG EXCEPTION RAISED - C.1"); | |
209 END; -- (C.1) | |
210 | |
211 BEGIN -- (C.2) | |
212 REC6 := REC4; | |
213 FAILED ("CONSTRAINT_ERROR NOT RAISED - C.2"); | |
214 EXCEPTION | |
215 WHEN CONSTRAINT_ERROR => | |
216 NULL; | |
217 WHEN OTHERS => | |
218 FAILED ("WRONG EXCEPTION RAISED - C.2"); | |
219 END; -- (C.2) | |
220 END CHK_RECTYPE; | |
221 | |
222 BEGIN | |
223 REC6 := (6, 5, "AEIOUY"); | |
224 REC9 := (9, 9, "123456789"); | |
225 END PKG; | |
226 | |
227 BEGIN -- (C) | |
228 | |
229 PKG.CHK_RECTYPE (REC9, REC6); | |
230 | |
231 END; -- (C) | |
232 | |
233 -------------------------------------------------- | |
234 | |
235 RESULT; | |
236 | |
237 END C64106B; |