gcc/testsuite/ada/acats/tests/c4/c460012.a

   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 --!
  37 with Ada.Exceptions;
  38 use Ada.Exceptions;
  39 with Report;
  40 use Report;
  41 procedure 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
  79 begin
  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;
  92 end C460012;
  93