gcc/testsuite/ada/acats/tests/ca/ca11d03.a

   1 -- CA11D03.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     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 an exception declared in a package can be raised by a
  28 --      client of a child of the package.  Check that it can be renamed in
  29 --      the client of the child of the package and raised with the correct
  30 --      effect.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      Declare a package which defines complex number abstraction with
  34 --      user-defined exceptions (foundation code).
  35 --
  36 --      Add a public child package to the above package. Declare two
  37 --      subprograms for the parent type.
  38 --
  39 --      In the main program, "with" the child package, then check that
  40 --      an exception can be raised and handled as expected.
  41 --
  42 -- TEST FILES:
  43 --      This test depends on the following foundation code:
  44 --
  45 --         FA11D00.A
  46 --
  47 --
  48 -- CHANGE HISTORY:
  49 --      06 Dec 94   SAIC    ACVC 2.0
  50 --
  51 --!
  52
  53 -- Child package of FA11D00.
  54 package FA11D00.CA11D03_0 is     -- Basic_Complex
  55
  56    function "+" (Left, Right : Complex_Type)
  57      return Complex_Type;                   -- Add two complex numbers.
  58
  59    function "*" (Left, Right : Complex_Type)
  60      return Complex_Type;                   -- Multiply two complex numbers.
  61
  62 end FA11D00.CA11D03_0;     -- Basic_Complex
  63
  64 --=======================================================================--
  65
  66 package body FA11D00.CA11D03_0 is     -- Basic_Complex
  67
  68    function "+" (Left, Right : Complex_Type) return Complex_Type is
  69    begin
  70       return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
  71    end "+";
  72    --------------------------------------------------------------
  73    function "*" (Left, Right : Complex_Type) return Complex_Type is
  74    begin
  75       return ( Real => (Left.Real * Right.Real),
  76                Imag => (Left.Imag * Right.Imag) );
  77    end "*";
  78
  79 end FA11D00.CA11D03_0;     -- Basic_Complex
  80
  81 --=======================================================================--
  82
  83 with FA11D00.CA11D03_0;    -- Basic_Complex,
  84                            -- implicitly with Complex_Definition.
  85 with Report;
  86
  87 procedure CA11D03 is
  88
  89    package Complex_Pkg renames FA11D00;     -- Complex_Definition_Pkg
  90    package Basic_Complex_Pkg renames FA11D00.CA11D03_0;   -- Basic_Complex
  91
  92    use Complex_Pkg;
  93    use Basic_Complex_Pkg;
  94
  95    TC_Handled_In_Subtest_1,
  96    TC_Handled_In_Subtest_2 : boolean := false;
  97
  98 begin
  99
 100    Report.Test ("CA11D03", "Check that an exception declared in a package " &
 101                 "can be raised by a client of a child of the package");
 102
 103    Multiply_Complex_Subtest:
 104    declare
 105       Operand_1  : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
 106                                    Int_Type (Report.Ident_Int (2)));
 107                                    -- Referenced to function in parent package.
 108       Operand_2  : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)),
 109                                    Int_Type (Report.Ident_Int (8)));
 110       Mul_Res    : Complex_type := Complex (Int_Type (Report.Ident_Int (30)),
 111                                    Int_Type (Report.Ident_Int (16)));
 112       Complex_No : Complex_Type := Zero;  -- Zero is declared in parent package.
 113    begin
 114       Complex_No := Operand_1 * Operand_2;   -- Basic_Complex."*".
 115       if Complex_No /= Mul_Res then
 116          Report.Failed ("Incorrect results from multiplication");
 117       end if;
 118
 119       -- Error is raised and exception will be handled.
 120       if Complex_No = Mul_Res then
 121          raise Multiply_Error;             -- Reference to exception in
 122       end if;                              -- parent package.
 123
 124    exception
 125       when Multiply_Error =>
 126          TC_Handled_In_Subtest_1 := true;
 127       when others =>
 128          TC_Handled_In_Subtest_1 := false;  -- Improper exception handling.
 129
 130    end Multiply_Complex_Subtest;
 131
 132    Add_Complex_Subtest:
 133    declare
 134       Error_In_Client : exception renames Add_Error;
 135                         -- Reference to exception in parent package.
 136       Operand_1  : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
 137                                    Int_Type (Report.Ident_Int (7)));
 138       Operand_2  : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)),
 139                                    Int_Type (Report.Ident_Int (1)));
 140       Add_Res    : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)),
 141                                    Int_Type (Report.Ident_Int (8)));
 142       Complex_No : Complex_Type := One;   -- One is declared in parent
 143                                           -- package.
 144    begin
 145       Complex_No := Operand_1 + Operand_2;   -- Basic_Complex."+".
 146
 147       if Complex_No /= Add_Res then
 148          Report.Failed ("Incorrect results from multiplication");
 149       end if;
 150
 151       -- Error is raised and exception will be handled.
 152       if Complex_No = Add_Res then
 153          raise Error_In_Client;
 154       end if;
 155
 156    exception
 157       when Error_In_Client =>
 158          TC_Handled_In_Subtest_2 := true;
 159
 160       when others =>
 161          TC_Handled_In_Subtest_2 := false;  -- Improper exception handling.
 162
 163    end Add_Complex_Subtest;
 164
 165    if not (TC_Handled_In_Subtest_1           and   -- Check to see that all
 166            TC_Handled_In_Subtest_2)                -- exceptions were handled
 167                                                    -- in the proper location.
 168    then
 169       Report.Failed ("Exceptions handled in incorrect locations");
 170    end if;
 171
 172    Report.Result;
 173
 174 end CA11D03;