llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/ca/ca11d03.a

-- CA11D03.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     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 an exception declared in a package can be raised by a 
--      client of a child of the package.  Check that it can be renamed in 
--      the client of the child of the package and raised with the correct 
--      effect.
--
-- TEST DESCRIPTION:
--      Declare a package which defines complex number abstraction with
--      user-defined exceptions (foundation code).
--
--      Add a public child package to the above package. Declare two 
--      subprograms for the parent type.  
--
--      In the main program, "with" the child package, then check that
--      an exception can be raised and handled as expected.  
--
-- TEST FILES:
--      This test depends on the following foundation code:
--
--         FA11D00.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

-- Child package of FA11D00.
package FA11D00.CA11D03_0 is     -- Basic_Complex

   function "+" (Left, Right : Complex_Type) 
     return Complex_Type;                   -- Add two complex numbers.

   function "*" (Left, Right : Complex_Type) 
     return Complex_Type;                   -- Multiply two complex numbers.

end FA11D00.CA11D03_0;     -- Basic_Complex

--=======================================================================--

package body FA11D00.CA11D03_0 is     -- Basic_Complex

   function "+" (Left, Right : Complex_Type) return Complex_Type is
   begin
      return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
   end "+";
   --------------------------------------------------------------
   function "*" (Left, Right : Complex_Type) return Complex_Type is
   begin
      return ( Real => (Left.Real * Right.Real),
               Imag => (Left.Imag * Right.Imag) );
   end "*";

end FA11D00.CA11D03_0;     -- Basic_Complex

--=======================================================================--

with FA11D00.CA11D03_0;    -- Basic_Complex,
                           -- implicitly with Complex_Definition.
with Report;

procedure CA11D03 is

   package Complex_Pkg renames FA11D00;     -- Complex_Definition_Pkg
   package Basic_Complex_Pkg renames FA11D00.CA11D03_0;   -- Basic_Complex

   use Complex_Pkg;                            
   use Basic_Complex_Pkg;           
           
   TC_Handled_In_Subtest_1,
   TC_Handled_In_Subtest_2 : boolean := false;

begin

   Report.Test ("CA11D03", "Check that an exception declared in a package " &
                "can be raised by a client of a child of the package");

   Multiply_Complex_Subtest:
   declare
      Operand_1  : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), 
                                   Int_Type (Report.Ident_Int (2)));  
                                   -- Referenced to function in parent package.
      Operand_2  : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)), 
                                   Int_Type (Report.Ident_Int (8)));  
      Mul_Res    : Complex_type := Complex (Int_Type (Report.Ident_Int (30)), 
                                   Int_Type (Report.Ident_Int (16)));  
      Complex_No : Complex_Type := Zero;  -- Zero is declared in parent package.
   begin
      Complex_No := Operand_1 * Operand_2;   -- Basic_Complex."*".
      if Complex_No /= Mul_Res then
         Report.Failed ("Incorrect results from multiplication");
      end if;

      -- Error is raised and exception will be handled.
      if Complex_No = Mul_Res then
         raise Multiply_Error;             -- Reference to exception in
      end if;                              -- parent package.

   exception
      when Multiply_Error => 
         TC_Handled_In_Subtest_1 := true;
      when others => 
         TC_Handled_In_Subtest_1 := false;  -- Improper exception handling.

   end Multiply_Complex_Subtest;

   Add_Complex_Subtest:
   declare
      Error_In_Client : exception renames Add_Error;  
                        -- Reference to exception in parent package.
      Operand_1  : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), 
                                   Int_Type (Report.Ident_Int (7)));  
      Operand_2  : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)), 
                                   Int_Type (Report.Ident_Int (1)));  
      Add_Res    : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)), 
                                   Int_Type (Report.Ident_Int (8)));  
      Complex_No : Complex_Type := One;   -- One is declared in parent 
                                          -- package.
   begin
      Complex_No := Operand_1 + Operand_2;   -- Basic_Complex."+".

      if Complex_No /= Add_Res then
         Report.Failed ("Incorrect results from multiplication");
      end if;

      -- Error is raised and exception will be handled.
      if Complex_No = Add_Res then
         raise Error_In_Client;
      end if;

   exception
      when Error_In_Client => 
         TC_Handled_In_Subtest_2 := true;

      when others => 
         TC_Handled_In_Subtest_2 := false;  -- Improper exception handling.

   end Add_Complex_Subtest;

   if not (TC_Handled_In_Subtest_1           and   -- Check to see that all 
           TC_Handled_In_Subtest_2)                -- exceptions were handled
                                                   -- in the proper location.
   then
      Report.Failed ("Exceptions handled in incorrect locations");
   end if;

   Report.Result;

end CA11D03;