1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
-- C460012.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. These rights include rights to use, duplicate,
-- release or disclose the released technical data and computer software
-- in whole or in part, in any manner and for any purpose whatsoever, and
-- to have or permit others to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the view created by a view conversion is constrained if the
-- target subtype is indefinite. (Defect Report 8652/0017, Technical
-- Corrigendum 4.6(54/1)).
--
-- CHANGE HISTORY:
-- 25 JAN 2001 PHL Initial version.
-- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking.
-- 02 JUL 2001 RLB Fixed discriminant reference.
--
--!
with Ada.Exceptions;
use Ada.Exceptions;
with Report;
use Report;
procedure C460012 is
subtype Index is Positive range 1 .. 10;
type Definite_Parent (D1 : Index := 6) is
record
F : String (1 .. D1) := (others => 'a');
end record;
type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2);
Y : Definite_Parent;
procedure P (X : in out Indefinite_Child) is
C : Character renames X.F (3);
begin
X := (1, "a");
if C /= 'a' then
Failed ("No exception raised when changing the " &
"discriminant of a view conversion, value of C changed");
elsif X.D2 /= 1 then
Failed ("No exception raised when changing the " &
"discriminant of a view conversion, discriminant not " &
"changed");
-- This check primarily exists to prevent X from being optimized by
-- 11.6 permissions, or the Failed call being made before the assignment.
else
Failed ("No exception raised when changing the " &
"discriminant of a view conversion, discriminant changed");
end if;
exception
when Constraint_Error =>
null;
when E: others =>
Failed ("Wrong exception " & Exception_Name (E) & " raised - " &
Exception_Message (E));
end P;
begin
Test ("C460012",
"Check that the view created by a view conversion " &
"is constrained if the target subtype is indefinite");
P (Indefinite_Child (Y));
if Y.D1 /= Ident_Int(6) then
Failed ("Discriminant of indefinite view changed");
-- This check exists mainly to prevent Y from being optimized away.
end if;
Result;
end C460012;
|
