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