Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c37402a.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 -- C37402A.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 WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR
26 -- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT
27 -- HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN APPLIED TO FORMAL
28 -- PARAMETERS OF MODE IN AND HAS THE VALUE OF THE ACTUAL PARAMETER
29 -- FOR THE OTHER MODES.
30
31 -- R.WILLIAMS 9/1/86
32
33 WITH REPORT; USE REPORT;
34 PROCEDURE C37402A IS
35
36 BEGIN
37 TEST ( "C37402A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &
38 "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &
39 "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &
40 "HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN " &
41 "APPLIED TO FORMAL PARAMETERS OF MODE IN " &
42 "AND HAS THE VALUE OF THE ACTUAL PARAMETER " &
43 "FOR THE OTHER MODES" );
44
45
46 DECLARE
47
48 SUBTYPE INT IS INTEGER RANGE 1 .. 5;
49
50 TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)
51 OF INTEGER;
52
53 TYPE SQUARE (SIDE : INT := 1) IS
54 RECORD
55 MAT : MATRIX (1 .. SIDE, 1 .. SIDE);
56 END RECORD;
57
58 SC : CONSTANT SQUARE := (2, ((0, 0), (0, 0)));
59
60 AC : SQUARE (2) := (2, ((1, 2), (3, 4)));
61 AU : SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));
62
63 BC : SQUARE (2) := AC;
64 BU : SQUARE := AU;
65
66 CC : SQUARE (2);
67 CU : SQUARE;
68
69 PROCEDURE P (CON, IN_CON : IN SQUARE;
70 INOUT_CON : IN OUT SQUARE;
71 OUT_CON : OUT SQUARE;
72 IN_UNC : IN SQUARE;
73 INOUT_UNC : IN OUT SQUARE;
74 OUT_UNC : OUT SQUARE) IS
75
76 BEGIN
77 IF CON'CONSTRAINED THEN
78 NULL;
79 ELSE
80 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
81 "OF IN MODE - 1" );
82 END IF;
83
84 IF IN_CON'CONSTRAINED THEN
85 NULL;
86 ELSE
87 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
88 "OF IN MODE - 2" );
89 END IF;
90
91 IF IN_UNC'CONSTRAINED THEN
92 NULL;
93 ELSE
94 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
95 "OF IN MODE - 3" );
96 END IF;
97
98 IF INOUT_CON'CONSTRAINED THEN
99 NULL;
100 ELSE
101 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
102 "CONSTRAINED OBJECT OF IN OUT MODE - 1" );
103 END IF;
104
105 IF OUT_CON'CONSTRAINED THEN
106 NULL;
107 ELSE
108 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
109 "CONSTRAINED OBJECT OF OUT MODE - 1" );
110 END IF;
111
112 IF INOUT_UNC'CONSTRAINED THEN
113 FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
114 "UNCONSTRAINED OBJECT OF IN OUT MODE " &
115 "- 1" );
116 END IF;
117
118 IF OUT_UNC'CONSTRAINED THEN
119 FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
120 "UNCONSTRAINED OBJECT OF OUT MODE - 1" );
121 END IF;
122
123 OUT_CON := (2, ((1, 2), (3, 4)));
124 OUT_UNC := (2, ((1, 2), (3, 4)));
125 END P;
126
127 TASK T IS
128 ENTRY Q (CON, IN_CON : IN SQUARE;
129 INOUT_CON : IN OUT SQUARE;
130 OUT_CON : OUT SQUARE;
131 IN_UNC : IN SQUARE;
132 INOUT_UNC : IN OUT SQUARE;
133 OUT_UNC : OUT SQUARE);
134 END T;
135
136 TASK BODY T IS
137 BEGIN
138 ACCEPT Q (CON, IN_CON : IN SQUARE;
139 INOUT_CON : IN OUT SQUARE;
140 OUT_CON : OUT SQUARE;
141 IN_UNC : IN SQUARE;
142 INOUT_UNC : IN OUT SQUARE;
143 OUT_UNC : OUT SQUARE) DO
144 BEGIN
145 IF CON'CONSTRAINED THEN
146 NULL;
147 ELSE
148 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
149 "OBJECT OF IN MODE - 4" );
150 END IF;
151
152 IF IN_CON'CONSTRAINED THEN
153 NULL;
154 ELSE
155 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
156 "OBJECT OF IN MODE - 5" );
157 END IF;
158
159 IF IN_UNC'CONSTRAINED THEN
160 NULL;
161 ELSE
162 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
163 "OBJECT OF IN MODE - 6" );
164 END IF;
165
166 IF INOUT_CON'CONSTRAINED THEN
167 NULL;
168 ELSE
169 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
170 "CONSTRAINED OBJECT OF " &
171 "IN OUT MODE - 2" );
172 END IF;
173
174 IF OUT_CON'CONSTRAINED THEN
175 NULL;
176 ELSE
177 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
178 "CONSTRAINED OBJECT OF " &
179 "OUT MODE - 2" );
180 END IF;
181
182 IF INOUT_UNC'CONSTRAINED THEN
183 FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
184 "UNCONSTRAINED OBJECT OF " &
185 "IN OUT MODE - 2" );
186 END IF;
187
188 IF OUT_UNC'CONSTRAINED THEN
189 FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
190 "UNCONSTRAINED OBJECT OF " &
191 "OUT MODE - 2" );
192 END IF;
193
194 OUT_CON := (2, ((1, 2), (3, 4)));
195 OUT_UNC := (2, ((1, 2), (3, 4)));
196 END;
197 END Q;
198 END T;
199
200 GENERIC
201 CON, IN_CON : IN SQUARE;
202 INOUT_CON : IN OUT SQUARE;
203 IN_UNC : IN SQUARE;
204 INOUT_UNC : IN OUT SQUARE;
205 PACKAGE R IS END R;
206
207 PACKAGE BODY R IS
208 BEGIN
209 IF CON'CONSTRAINED THEN
210 NULL;
211 ELSE
212 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
213 "OF IN MODE - 7" );
214 END IF;
215
216 IF IN_CON'CONSTRAINED THEN
217 NULL;
218 ELSE
219 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
220 "OF IN MODE - 8" );
221 END IF;
222
223 IF IN_UNC'CONSTRAINED THEN
224 NULL;
225 ELSE
226 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
227 "OF IN MODE - 9" );
228 END IF;
229
230 IF INOUT_CON'CONSTRAINED THEN
231 NULL;
232 ELSE
233 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
234 "CONSTRAINED OBJECT OF IN OUT MODE - 3" );
235 END IF;
236
237 IF INOUT_UNC'CONSTRAINED THEN
238 FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
239 "UNCONSTRAINED OBJECT OF IN OUT MODE " &
240 "- 3" );
241 END IF;
242
243 END R;
244
245 PACKAGE S IS NEW R (SC, AC, BC, AU, BU);
246
247 BEGIN
248 P (SC, AC, BC, CC, AU, BU, CU);
249 T.Q (SC, AC, BC, CC, AU, BU, CU);
250 END;
251
252 RESULT;
253 END C37402A;