tests/c4/c460014.a

-- C460014.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 ACAA 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.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
-- OBJECTIVES:
--      Check that if the operand type of a type conversion is
--      access-to-class-wide, Constraint_Error is raised if the tag of the
--      object designated by the operand does not identify a specific type
--      that is covered by or descended from the target type.
--
-- TEST DESCRIPTION:
--      Attempt to convert a parameter of a type that designates a class-wide
--      type to an object of a type that designates a specific member of that
--      class, for both an actual with a different tag and an actual with a
--      matching tag.
--
--      This test checks 4.6(42) as required by 4.6(50).
--
-- CHANGE HISTORY:
--      19 Aug 16   JAC     Initial pre-release version.
--      19 Jan 17   RLB     Readied for release: replaced objective, renamed
--                          to appropriate number, added class-wide cases,
--                          eliminated 11.6 problems, added third level of
--                          types, and checks on null.
--
--!
package C460014_1 is
   type Root_Facade_Type is tagged record
      Error_Code : Integer;
   end record;

   type Root_Facade_Ptr_Type is access all Root_Facade_Type;

   type Facade_Class_Ptr_Type is access all Root_Facade_Type'Class;

   type Data_A_Type is
   record
      A : Boolean;
   end record;

   type Facade_A_Type is new Root_Facade_Type with
   record
      Data_A : Data_A_Type;
   end record;

   type Facade_A_Ptr_Type is access all Facade_A_Type;

   type Facade_A_Class_Ptr_Type is access all Facade_A_Type'Class;

   type Facade_B_Type is new Facade_A_Type with
   record
      B : Character;
   end record;

   type Facade_B_Ptr_Type is access all Facade_B_Type;

   type Facade_B_Class_Ptr_Type is access all Facade_B_Type'Class;

   procedure Define_Construct
     (Facade_Class_Ptr : in Facade_Class_Ptr_Type);

   procedure Define_Class_Construct
     (Facade_Class_Ptr : in Facade_Class_Ptr_Type);

   function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type;

   function Init_Facade_A_Ptr     return Facade_A_Ptr_Type;

   function Init_Facade_B_Ptr     return Facade_B_Ptr_Type;

   function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type;

   function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type;

   function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type;

end C460014_1;

with Report;
package body C460014_1 is

   procedure Define_Construct
    (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is

      Facade_A_Ptr : constant Facade_A_Ptr_Type :=
                                         Facade_A_Ptr_Type (Facade_Class_Ptr);

      My_A : Data_A_Type renames Facade_A_Ptr.Data_A;
   begin
      if not My_A.A then
         Report.Comment ("Wrong value"); -- So My_A is not dead by 11.6(5).
      end if;
   end Define_Construct;

   procedure Define_Class_Construct
    (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is

      Facade_Class_A_Ptr : constant Facade_A_Class_Ptr_Type :=
                                  Facade_A_Class_Ptr_Type (Facade_Class_Ptr);

   begin
      if Facade_Class_A_Ptr /= null and then
         (not Facade_Class_A_Ptr.Data_A.A) then
         Report.Comment ("Wrong value"); -- So the ptr is not dead by 11.6(5).
      end if;
   end Define_Class_Construct;

   Dummy_Root_Facade : aliased Root_Facade_Type := (Error_Code => 123);

   function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type is
   begin
      return Dummy_Root_Facade'Access;
   end Init_Root_Facade_Ptr;

   Dummy_Facade_A    : aliased Facade_A_Type := (Error_Code => 123,
                                                 Data_A     => (A => True));

   function Init_Facade_A_Ptr     return Facade_A_Ptr_Type is
   begin
      return Dummy_Facade_A'Access;
   end Init_Facade_A_Ptr;

   Dummy_Facade_B    : aliased Facade_B_Type := (Error_Code => 234,
                                                 Data_A     => (A => True),
                                                 B          => 'P');

   function Init_Facade_B_Ptr     return Facade_B_Ptr_Type is
   begin
      return Dummy_Facade_B'Access;
   end Init_Facade_B_Ptr;

   function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type is
   begin
      return Dummy_Root_Facade'Access;
   end Init_Facade_Class_Ptr_with_Root;

   function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type is
   begin
      return Dummy_Facade_A'Access;
   end Init_Facade_Class_Ptr_with_A;

   function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type is
   begin
      return Dummy_Facade_B'Access;
   end Init_Facade_Class_Ptr_with_B;

end C460014_1;


with C460014_1;
with Report;

procedure C460014 is

   My_Root_Facade_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
                                    C460014_1.Init_Facade_Class_Ptr_with_Root;

   My_Facade_A_Ptr    : constant C460014_1.Facade_Class_Ptr_Type :=
                                    C460014_1.Init_Facade_Class_Ptr_with_A;

   My_Facade_B_Ptr    : constant C460014_1.Facade_Class_Ptr_Type :=
                                    C460014_1.Init_Facade_Class_Ptr_with_B;

   My_Null_Facade_B_Ptr    : constant C460014_1.Facade_B_Ptr_Type := null;

   Constraint_Error_Raised : Boolean;

   procedure Test_Define_Construct
    (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
   begin
      Constraint_Error_Raised := False;
      -- Should fail Tag_Check and therefore raise Constraint_Error if
      -- parameter doesn't designate an object of Facade_A_Type
      -- or Facade_B_Type.
      C460014_1.Define_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
   exception
      when Constraint_Error =>
         Constraint_Error_Raised := True;
   end Test_Define_Construct;


   procedure Test_Define_Class_Construct
    (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
   begin
      Constraint_Error_Raised := False;
      -- Should fail Tag_Check and therefore raise Constraint_Error if
      -- parameter doesn't designate an object of Facade_A_Type
      -- or Facade_B_Type.
      C460014_1.Define_Class_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
   exception
      when Constraint_Error =>
         Constraint_Error_Raised := True;
   end Test_Define_Class_Construct;

begin

   Report.Test
     ("C460014",
      "Check that if the operand type of a type conversion is " &
      "access-to-class-wide, Constraint_Error is raised if the tag of the " &
      "object designated by the operand does not identify a specific type " &
      "that is covered by or descended from the target type");

   Test_Define_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);

   if not Constraint_Error_Raised then
      Report.Failed ("Didn't get expected Constraint_Error (1)");
   end if;

   Test_Define_Construct
     (Facade_Class_Ptr => My_Facade_A_Ptr);

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (2)");
   end if;

   Test_Define_Construct
     (Facade_Class_Ptr => My_Facade_B_Ptr);

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (3)");
   end if;

   Test_Define_Class_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);

   if not Constraint_Error_Raised then
      Report.Failed ("Didn't get expected Constraint_Error (4)");
   end if;

   Test_Define_Class_Construct
     (Facade_Class_Ptr => My_Facade_A_Ptr);

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (5)");
   end if;

   Test_Define_Class_Construct
     (Facade_Class_Ptr => My_Facade_B_Ptr);

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (6)");
   end if;

   -- Check that it is OK to pass null and that does not cause some failure.
   Test_Define_Class_Construct (Facade_Class_Ptr => null);

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (7)");
   end if;

   Test_Define_Class_Construct (Facade_Class_Ptr =>
      C460014_1.Facade_Class_Ptr_Type (My_Null_Facade_B_Ptr));

   if Constraint_Error_Raised then
      Report.Failed ("Unexpected Constraint_Error (8)");
   end if;

   Report.Result;

end C460014;