|
111
|
1 -- C3A0014.A
|
|
|
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 --
|
|
|
26 -- OBJECTIVE:
|
|
|
27 -- Check that if the view defined by an object declaration is aliased,
|
|
|
28 -- and the type of the object has discriminants, then the object is
|
|
|
29 -- constrained by its initial value even if its nominal subtype is
|
|
|
30 -- unconstrained.
|
|
|
31 --
|
|
|
32 -- Check that the attribute A'Constrained returns True if A is a formal
|
|
|
33 -- out or in out parameter, or dereference thereof, and A denotes an
|
|
|
34 -- aliased view of an object.
|
|
|
35 --
|
|
|
36 -- TEST DESCRIPTION:
|
|
|
37 -- These rules apply to objects of a record type with defaulted
|
|
|
38 -- discriminants, which may be unconstrained variables. If such a
|
|
|
39 -- variable is declared to be aliased, then it is constrained by its
|
|
|
40 -- initial value, and the value of the discriminant cannot be changed
|
|
|
41 -- for the life of the variable.
|
|
|
42 --
|
|
|
43 -- The rules do not apply to aliased component types because if such
|
|
|
44 -- types are discriminated they must be constrained.
|
|
|
45 --
|
|
|
46 -- A'Constrained returns True if A denotes a constant, value, or
|
|
|
47 -- constrained variable. Since aliased objects are constrained, it must
|
|
|
48 -- return True if the actual parameter corresponding to a formal
|
|
|
49 -- parameter A is an aliased object. The objective only mentions formal
|
|
|
50 -- parameters of mode out and in out, since parameters of mode in are
|
|
|
51 -- by definition constant, and would result in True anyway.
|
|
|
52 --
|
|
|
53 -- This test declares aliased objects of a nominally unconstrained
|
|
|
54 -- record subtype, both with and without initialization expressions.
|
|
|
55 -- It also declares access values which point to such objects. It then
|
|
|
56 -- checks that Constraint_Error is raised if an attempt is made to
|
|
|
57 -- change the discriminant value of an aliased object, either directly
|
|
|
58 -- or via a dereference of an access value. For aliased objects, this
|
|
|
59 -- check is also performed for subprogram parameters of mode out.
|
|
|
60 --
|
|
|
61 -- The test also passes aliased objects and access values which point
|
|
|
62 -- to such objects as actuals to subprograms and verifies, for parameter
|
|
|
63 -- modes out and in out, that P'Constrained returns true if P is the
|
|
|
64 -- corresponding formal parameter or a dereference thereof.
|
|
|
65 --
|
|
|
66 -- Additionally, the test declares a generic package which declares a
|
|
|
67 -- an aliased object of a formal derived unconstrained type, which is
|
|
|
68 -- is initialized with the value of a formal object of that type.
|
|
|
69 -- procedure declared within the generic assigns a value to the object
|
|
|
70 -- which has the same discriminant value as the formal derived type's
|
|
|
71 -- ancestor type. The generic is instantiated with various actuals
|
|
|
72 -- for the formal object, and the procedure is called. The test verifies
|
|
|
73 -- that Constraint_Error is raised if the discriminant values of the
|
|
|
74 -- actual corresponding to the formal object and the value assigned
|
|
|
75 -- by the procedure are not equal.
|
|
|
76 --
|
|
|
77 --
|
|
|
78 -- CHANGE HISTORY:
|
|
|
79 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
80 -- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors.
|
|
|
81 --
|
|
|
82 --!
|
|
|
83
|
|
|
84 package C3A0014_0 is
|
|
|
85
|
|
|
86 subtype Reasonable is Integer range 1..10;
|
|
|
87 -- Unconstrained (sub)type.
|
|
|
88 type UC (D: Reasonable := 2) is record -- Discriminant default.
|
|
|
89 S: String (1 .. D) := "Hi"; -- Default value.
|
|
|
90 end record;
|
|
|
91
|
|
|
92 type AUC is access all UC;
|
|
|
93
|
|
|
94 -- Nominal subtype is unconstrained for the following:
|
|
|
95
|
|
|
96 Obj0 : UC; -- An unconstrained object.
|
|
|
97
|
|
|
98 Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization,
|
|
|
99 -- an unconstrained object.
|
|
|
100
|
|
|
101 Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization,
|
|
|
102 -- a constrained object.
|
|
|
103
|
|
|
104 Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view),
|
|
|
105 -- a constrained object.
|
|
|
106 Obj4 : aliased UC; -- Aliased without initialization, Obj4
|
|
|
107 -- constrained here to initial value
|
|
|
108 -- taken from default for type.
|
|
|
109
|
|
|
110 Ptr1 : AUC := new UC'(Obj1);
|
|
|
111 Ptr2 : AUC := new UC;
|
|
|
112 Ptr3 : AUC := Obj3'Access;
|
|
|
113 Ptr4 : AUC := Obj4'Access;
|
|
|
114
|
|
|
115
|
|
|
116 procedure NP_Proc (A: out UC);
|
|
|
117 procedure NP_Cons (A: in out UC; B: out Boolean);
|
|
|
118 procedure P_Cons (A: out AUC; B: out Boolean);
|
|
|
119
|
|
|
120
|
|
|
121 generic
|
|
|
122 type FT is new UC;
|
|
|
123 FObj : in out FT;
|
|
|
124 package Gen is
|
|
|
125 F : aliased FT := FObj; -- Constrained if FT has discriminants.
|
|
|
126 procedure Proc;
|
|
|
127 end Gen;
|
|
|
128
|
|
|
129
|
|
|
130 procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
|
|
|
131
|
|
|
132
|
|
|
133 end C3A0014_0;
|
|
|
134
|
|
|
135
|
|
|
136 --=======================================================================--
|
|
|
137
|
|
|
138 with Report;
|
|
|
139
|
|
|
140 package body C3A0014_0 is
|
|
|
141
|
|
|
142 procedure NP_Proc (A: out UC) is
|
|
|
143 begin
|
|
|
144 A := (3, "Bye");
|
|
|
145 end NP_Proc;
|
|
|
146
|
|
|
147 procedure NP_Cons (A: in out UC; B: out Boolean) is
|
|
|
148 begin
|
|
|
149 B := A'Constrained;
|
|
|
150 end NP_Cons;
|
|
|
151
|
|
|
152 procedure P_Cons (A: out AUC; B: out Boolean) is
|
|
|
153 begin
|
|
|
154 B := A.all'Constrained;
|
|
|
155 end P_Cons;
|
|
|
156
|
|
|
157
|
|
|
158 package body Gen is
|
|
|
159
|
|
|
160 procedure Proc is
|
|
|
161 begin
|
|
|
162 F := (2, "Fi");
|
|
|
163 end Proc;
|
|
|
164
|
|
|
165 end Gen;
|
|
|
166
|
|
|
167
|
|
|
168 procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
|
|
|
169 Default : UC := (1, "!"); -- Unique value.
|
|
|
170 begin
|
|
|
171 if P = Default then -- Both If branches can't do the same thing.
|
|
|
172 Report.Failed (Msg & ": Constraint_Error not raised");
|
|
|
173 else -- Subtests should always select this path.
|
|
|
174 Report.Failed ("Constraint_Error not raised " & Msg);
|
|
|
175 end if;
|
|
|
176 end Avoid_Optimization_and_Fail;
|
|
|
177
|
|
|
178
|
|
|
179 end C3A0014_0;
|
|
|
180
|
|
|
181
|
|
|
182 --=======================================================================--
|
|
|
183
|
|
|
184
|
|
|
185 with C3A0014_0; use C3A0014_0;
|
|
|
186 with Report;
|
|
|
187
|
|
|
188 procedure C3A0014 is
|
|
|
189 begin
|
|
|
190
|
|
|
191 Report.Test("C3A0014", "Check that if the view defined by an object " &
|
|
|
192 "declaration is aliased, and the type of the " &
|
|
|
193 "object has discriminants, then the object is " &
|
|
|
194 "constrained by its initial value even if its " &
|
|
|
195 "nominal subtype is unconstrained. Check that " &
|
|
|
196 "the attribute A'Constrained returns True if A " &
|
|
|
197 "is a formal out or in out parameter, or " &
|
|
|
198 "dereference thereof, and A denotes an aliased " &
|
|
|
199 "view of an object");
|
|
|
200
|
|
|
201 Non_Pointer_Block:
|
|
|
202 begin
|
|
|
203
|
|
|
204 begin
|
|
|
205 Obj0 := (3, "Bye"); -- OK: Obj0 not constrained.
|
|
|
206 if Obj0 /= (3, "Bye") then
|
|
|
207 Report.Failed
|
|
|
208 ("Wrong value after aggregate assignment - Subtest 1");
|
|
|
209 end if;
|
|
|
210 exception
|
|
|
211 when others =>
|
|
|
212 Report.Failed ("Unexpected exception raised - Subtest 1");
|
|
|
213 end;
|
|
|
214
|
|
|
215
|
|
|
216 begin
|
|
|
217 Obj1 := (3, "Bye"); -- OK: Obj1 not constrained.
|
|
|
218 if Obj1 /= (3, "Bye") then
|
|
|
219 Report.Failed
|
|
|
220 ("Wrong value after aggregate assignment - Subtest 2");
|
|
|
221 end if;
|
|
|
222 exception
|
|
|
223 when others =>
|
|
|
224 Report.Failed ("Unexpected exception raised - Subtest 2");
|
|
|
225 end;
|
|
|
226
|
|
|
227
|
|
|
228 begin
|
|
|
229 Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5).
|
|
|
230 Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
|
|
|
231 exception
|
|
|
232 when Constraint_Error => null; -- Exception is expected.
|
|
|
233 end;
|
|
|
234
|
|
|
235
|
|
|
236 begin
|
|
|
237 Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5).
|
|
|
238 Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
|
|
|
239 exception
|
|
|
240 when Constraint_Error => null; -- Exception is expected.
|
|
|
241 end;
|
|
|
242
|
|
|
243
|
|
|
244 begin
|
|
|
245 Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2).
|
|
|
246 Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
|
|
|
247 exception
|
|
|
248 when Constraint_Error => null; -- Exception is expected.
|
|
|
249 end;
|
|
|
250
|
|
|
251 exception
|
|
|
252 when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
|
|
|
253 end Non_Pointer_Block;
|
|
|
254
|
|
|
255
|
|
|
256 Pointer_Block:
|
|
|
257 begin
|
|
|
258
|
|
|
259 begin
|
|
|
260 Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5).
|
|
|
261 Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
|
|
|
262 exception
|
|
|
263 when Constraint_Error => null; -- Exception is expected.
|
|
|
264 end;
|
|
|
265
|
|
|
266
|
|
|
267 begin
|
|
|
268 Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2).
|
|
|
269 Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
|
|
|
270 exception
|
|
|
271 when Constraint_Error => null; -- Exception is expected.
|
|
|
272 end;
|
|
|
273
|
|
|
274
|
|
|
275 begin
|
|
|
276 Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5).
|
|
|
277 Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
|
|
|
278 exception
|
|
|
279 when Constraint_Error => null; -- Exception is expected.
|
|
|
280 end;
|
|
|
281
|
|
|
282
|
|
|
283 begin
|
|
|
284 Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2).
|
|
|
285 Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
|
|
|
286 exception
|
|
|
287 when Constraint_Error => null; -- Exception is expected.
|
|
|
288 end;
|
|
|
289
|
|
|
290 exception
|
|
|
291 when others => Report.Failed("Unexpected exception: Pointer_Block");
|
|
|
292 end Pointer_Block;
|
|
|
293
|
|
|
294
|
|
|
295 Subprogram_Block:
|
|
|
296 declare
|
|
|
297 Is_Constrained : Boolean;
|
|
|
298 begin
|
|
|
299
|
|
|
300 begin
|
|
|
301 NP_Proc (Obj0); -- OK: Obj0 not constrained, can
|
|
|
302 if Obj0 /= (3, "Bye") then -- change discriminant value.
|
|
|
303 Report.Failed
|
|
|
304 ("Wrong value after aggregate assignment - Subtest 10");
|
|
|
305 end if;
|
|
|
306 exception
|
|
|
307 when others =>
|
|
|
308 Report.Failed ("Unexpected exception raised - Subtest 10");
|
|
|
309 end;
|
|
|
310
|
|
|
311
|
|
|
312 begin
|
|
|
313 NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5).
|
|
|
314 Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
|
|
|
315 exception
|
|
|
316 when Constraint_Error => null; -- Exception is expected.
|
|
|
317 end;
|
|
|
318
|
|
|
319
|
|
|
320 begin
|
|
|
321 NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5).
|
|
|
322 Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
|
|
|
323 exception
|
|
|
324 when Constraint_Error => null; -- Exception is expected.
|
|
|
325 end;
|
|
|
326
|
|
|
327
|
|
|
328 begin
|
|
|
329 NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2).
|
|
|
330 Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
|
|
|
331 exception
|
|
|
332 when Constraint_Error => null; -- Exception is expected.
|
|
|
333 end;
|
|
|
334
|
|
|
335
|
|
|
336
|
|
|
337 begin
|
|
|
338 Is_Constrained := True;
|
|
|
339 NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1
|
|
|
340 if Is_Constrained then -- is not constrained.
|
|
|
341 Report.Failed ("Wrong result from 'Constrained - Subtest 14");
|
|
|
342 end if;
|
|
|
343 exception
|
|
|
344 when others =>
|
|
|
345 Report.Failed ("Unexpected exception raised - Subtest 14");
|
|
|
346 end;
|
|
|
347
|
|
|
348
|
|
|
349 begin
|
|
|
350 Is_Constrained := False;
|
|
|
351 NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is
|
|
|
352 if not Is_Constrained then -- constrained.
|
|
|
353 Report.Failed ("Wrong result from 'Constrained - Subtest 15");
|
|
|
354 end if;
|
|
|
355 exception
|
|
|
356 when others =>
|
|
|
357 Report.Failed ("Unexpected exception raised - Subtest 15");
|
|
|
358 end;
|
|
|
359
|
|
|
360
|
|
|
361
|
|
|
362
|
|
|
363 begin
|
|
|
364 Is_Constrained := False;
|
|
|
365 P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all
|
|
|
366 if not Is_Constrained then -- is constrained.
|
|
|
367 Report.Failed ("Wrong result from 'Constrained - Subtest 16");
|
|
|
368 end if;
|
|
|
369 exception
|
|
|
370 when others =>
|
|
|
371 Report.Failed ("Unexpected exception raised - Subtest 16");
|
|
|
372 end;
|
|
|
373
|
|
|
374
|
|
|
375 begin
|
|
|
376 Is_Constrained := False;
|
|
|
377 P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all
|
|
|
378 if not Is_Constrained then -- is constrained.
|
|
|
379 Report.Failed ("Wrong result from 'Constrained - Subtest 17");
|
|
|
380 end if;
|
|
|
381 exception
|
|
|
382 when others =>
|
|
|
383 Report.Failed ("Unexpected exception raised - Subtest 17");
|
|
|
384 end;
|
|
|
385
|
|
|
386
|
|
|
387 exception
|
|
|
388 when others => Report.Failed("Exception raised in Subprogram_Block");
|
|
|
389 end Subprogram_Block;
|
|
|
390
|
|
|
391
|
|
|
392 Generic_Block:
|
|
|
393 declare
|
|
|
394
|
|
|
395 type NUC is new UC;
|
|
|
396
|
|
|
397 Obj : NUC;
|
|
|
398
|
|
|
399
|
|
|
400 package Instance_A is new Gen (NUC, Obj);
|
|
|
401 package Instance_B is new Gen (UC, Obj2);
|
|
|
402 package Instance_C is new Gen (UC, Obj3);
|
|
|
403 package Instance_D is new Gen (UC, Obj4);
|
|
|
404
|
|
|
405 begin
|
|
|
406
|
|
|
407 begin
|
|
|
408 Instance_A.Proc; -- OK: Obj.D = 2.
|
|
|
409 if Instance_A.F /= (2, "Fi") then
|
|
|
410 Report.Failed
|
|
|
411 ("Wrong value after aggregate assignment - Subtest 18");
|
|
|
412 end if;
|
|
|
413 exception
|
|
|
414 when others =>
|
|
|
415 Report.Failed ("Unexpected exception raised - Subtest 18");
|
|
|
416 end;
|
|
|
417
|
|
|
418
|
|
|
419 begin
|
|
|
420 Instance_B.Proc; -- C_E: Obj2.D = 5.
|
|
|
421 Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
|
|
|
422 exception
|
|
|
423 when Constraint_Error => null; -- Exception is expected.
|
|
|
424 end;
|
|
|
425
|
|
|
426
|
|
|
427 begin
|
|
|
428 Instance_C.Proc; -- C_E: Obj3.D = 5.
|
|
|
429 Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
|
|
|
430 exception
|
|
|
431 when Constraint_Error => null; -- Exception is expected.
|
|
|
432 end;
|
|
|
433
|
|
|
434
|
|
|
435 begin
|
|
|
436 Instance_D.Proc; -- OK: Obj4.D = 2.
|
|
|
437 if Instance_D.F /= (2, "Fi") then
|
|
|
438 Report.Failed
|
|
|
439 ("Wrong value after aggregate assignment - Subtest 21");
|
|
|
440 end if;
|
|
|
441 exception
|
|
|
442 when others =>
|
|
|
443 Report.Failed ("Unexpected exception raised - Subtest 21");
|
|
|
444 end;
|
|
|
445
|
|
|
446 exception
|
|
|
447 when others => Report.Failed("Exception raised in Generic_Block");
|
|
|
448 end Generic_Block;
|
|
|
449
|
|
|
450
|
|
|
451 Report.Result;
|
|
|
452
|
|
|
453 end C3A0014;
|
