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

   1 -- CA11D02.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 --      child of a child package.  Check that it can be renamed in the
  29 --      child of the child package and raised with the correct effect.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare a package which defines complex number abstraction with
  33 --      user-defined exceptions (foundation code).
  34 --
  35 --      Add a public child package to the above package. Declare two
  36 --      subprograms for the parent type.
  37 --
  38 --      Add a public grandchild package to the foundation package.  Declare
  39 --      subprograms to raise exceptions.
  40 --
  41 --      In the main program, "with" the grandchild package, then check that
  42 --      the exceptions are raised and handled as expected.  Ensure that
  43 --      exceptions are:
  44 --         1) raised in the public grandchild package and handled/reraised to
  45 --            be handled by the main program.
  46 --         2) raised and handled locally by the "others" handler in the
  47 --            public grandchild package.
  48 --         3) raised in the public grandchild and propagated to the main
  49 --            program.
  50 --
  51 -- TEST FILES:
  52 --      This test depends on the following foundation code:
  53 --
  54 --         FA11D00.A
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --
  60 --!
  61
  62 -- Child package of FA11D00.
  63
  64 package FA11D00.CA11D02_0 is     -- Basic_Complex
  65
  66    function "+" (Left, Right : Complex_Type)
  67      return Complex_Type;                   -- Add two complex numbers.
  68
  69    function "*" (Left, Right : Complex_Type)
  70      return Complex_Type;                   -- Multiply two complex numbers.
  71
  72 end FA11D00.CA11D02_0;     -- Basic_Complex
  73
  74 --=======================================================================--
  75
  76 package body FA11D00.CA11D02_0 is     -- Basic_Complex
  77
  78    function "+" (Left, Right : Complex_Type) return Complex_Type is
  79    begin
  80       return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
  81    end "+";
  82    --------------------------------------------------------------
  83    function "*" (Left, Right : Complex_Type) return Complex_Type is
  84    begin
  85       return ( Real => (Left.Real * Right.Real),
  86                Imag => (Left.Imag * Right.Imag) );
  87    end "*";
  88
  89 end FA11D00.CA11D02_0;     -- Basic_Complex
  90
  91 --=======================================================================--
  92
  93 -- Child package of FA11D00.CA11D02_0.
  94 -- Grandchild package of FA11D00.
  95
  96 package FA11D00.CA11D02_0.CA11D02_1 is     -- Array_Complex
  97
  98    Inverse_Error : exception renames Divide_Error;   -- Reference to exception
  99                                                      -- in grandparent package.
 100    Array_Size    : constant := 2;
 101
 102    type Complex_Array_Type is
 103       array (1 .. Array_Size) of Complex_Type;       -- Reference to type
 104                                                      -- in parent package.
 105
 106    function Multiply (Left  : Complex_Array_Type;    -- Multiply two complex
 107                       Right : Complex_Array_Type)    -- arrays.
 108      return Complex_Array_Type;
 109
 110    function Add (Left, Right : Complex_Array_Type)   -- Add two complex
 111      return Complex_Array_Type;                      -- arrays.
 112
 113    procedure Inverse (Right : in     Complex_Array_Type;  -- Invert a complex
 114                       Left  : in out Complex_Array_Type); -- array.
 115
 116 end FA11D00.CA11D02_0.CA11D02_1;     -- Array_Complex
 117
 118 --=======================================================================--
 119
 120 with Report;
 121
 122
 123 package body FA11D00.CA11D02_0.CA11D02_1 is     -- Array_Complex
 124
 125    function Multiply (Left  : Complex_Array_Type;
 126                       Right : Complex_Array_Type)
 127      return Complex_Array_Type is
 128
 129    -- This procedure will raise an exception depending on the input
 130    -- parameter.  The exception will be handled locally by the
 131    -- "others" handler.
 132
 133       Result : Complex_Array_Type := (others => Zero);
 134
 135       subtype Vector_Size is Positive range Left'Range;
 136
 137    begin
 138       if Left = Result or else Right = Result then -- Do not multiply zero.
 139          raise Multiply_Error;                     -- Refence to exception in
 140                                                    -- grandparent package.
 141          Report.Failed ("Program control not transferred by raise");
 142       else
 143          for I in Vector_Size loop
 144            Result(I) := ( Left(I) * Right(I) );    -- Basic_Complex."*".
 145          end loop;
 146       end if;
 147       return (Result);
 148
 149    exception
 150       when others =>
 151          Report.Comment ("Exception is handled by others in Multiplication");
 152          TC_Handled_In_Grandchild_Pkg_Func := true;
 153          return (Zero, Zero);
 154
 155    end Multiply;
 156    --------------------------------------------------------------
 157    function Add (Left, Right : Complex_Array_Type)
 158      return Complex_Array_Type is
 159
 160    -- This function will raise an exception depending on the input
 161    -- parameter.  The exception will be propagated and handled
 162    -- by the caller.
 163
 164       Result : Complex_Array_Type := (others => Zero);
 165
 166       subtype Vector_Size is Positive range Left'Range;
 167
 168    begin
 169       if Left = Result or Right = Result then     -- Do not add zero.
 170          raise Add_Error;                         -- Refence to exception in
 171                                                   -- grandparent package.
 172          Report.Failed ("Program control not transferred by raise");
 173       else
 174          for I in Vector_Size loop
 175            Result(I) := ( Left(I) + Right(I) );   -- Basic_Complex."+".
 176          end loop;
 177       end if;
 178       return (Result);
 179
 180    end Add;
 181    --------------------------------------------------------------
 182    procedure Inverse (Right : in     Complex_Array_Type;
 183                       Left  : in out Complex_Array_Type) is
 184
 185    -- This function will raise an exception depending on the input
 186    -- parameter.  The exception will be handled/reraised to be
 187    -- handled by the caller.
 188
 189       Result : Complex_Array_Type := (others => Zero);
 190
 191       Array_With_Zero : boolean := false;
 192
 193    begin
 194       for I in 1 .. Right'Length loop
 195         if Right(I) = Zero then      -- Check for zero.
 196           Array_With_Zero := true;
 197         end if;
 198       end loop;
 199
 200       If Array_With_Zero then
 201          raise Inverse_Error;      -- Do not inverse zero.
 202          Report.Failed ("Program control not transferred by raise");
 203       else
 204          for I in 1 .. Array_Size loop
 205            Left(I).Real := - Right(I).Real;
 206            Left(I).Imag := - Right(I).Imag;
 207         end loop;
 208       end if;
 209
 210    exception
 211       when Inverse_Error  =>
 212          TC_Handled_In_Grandchild_Pkg_Proc := true;
 213          Left := Result;
 214          raise;     -- Reraise the Inverse_Error exception in the subtest.
 215          Report.Failed ("Exception not reraised in handler");
 216
 217       when others =>
 218          Report.Failed ("Unexpected exception in procedure Inverse");
 219    end Inverse;
 220
 221 end FA11D00.CA11D02_0.CA11D02_1;     -- Array_Complex
 222
 223 --=======================================================================--
 224
 225 with FA11D00.CA11D02_0.CA11D02_1;    -- Array_Complex,
 226                                      -- implicitly with Basic_Complex.
 227 with Report;
 228
 229 procedure CA11D02 is
 230
 231    package Complex_Pkg renames FA11D00;
 232    package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1;
 233
 234    use Complex_Pkg;
 235    use Array_Complex_Pkg;
 236
 237 begin
 238
 239    Report.Test ("CA11D02", "Check that an exception declared in a package " &
 240                 "can be raised by a child of a child package");
 241
 242    Multiply_Complex_Subtest:
 243    declare
 244       Operand_1  : Complex_Array_Type
 245                  := ( Complex (Int_Type (Report.Ident_Int (3)),
 246                       Int_Type (Report.Ident_Int (5))),
 247                       Complex (Int_Type (Report.Ident_Int (2)),
 248                       Int_Type (Report.Ident_Int (8))) );
 249       Operand_2  : Complex_Array_Type
 250                  := ( Complex (Int_Type (Report.Ident_Int (1)),
 251                       Int_Type (Report.Ident_Int (2))),
 252                       Complex (Int_Type (Report.Ident_Int (3)),
 253                       Int_Type (Report.Ident_Int (6))) );
 254       Operand_3  : Complex_Array_Type := ( Zero, Zero);
 255       Mul_Result : Complex_Array_Type
 256                  := ( Complex (Int_Type (Report.Ident_Int (3)),
 257                       Int_Type (Report.Ident_Int (10))),
 258                       Complex (Int_Type (Report.Ident_Int (6)),
 259                       Int_Type (Report.Ident_Int (48))) );
 260       Complex_No : Complex_Array_Type := (others => Zero);
 261
 262    begin
 263       If (Multiply (Operand_1, Operand_2) /= Mul_Result) then
 264          Report.Failed ("Incorrect results from multiplication");
 265       end if;
 266
 267       -- Error is raised and exception will be handled in grandchild package.
 268
 269       Complex_No := Multiply (Operand_1, Operand_3);
 270
 271       if Complex_No /= (Zero, Zero) then
 272          Report.Failed ("Exception was not raised in multiplication");
 273       end if;
 274
 275    exception
 276       when Multiply_Error     =>
 277          Report.Failed ("Exception raised in multiplication and " &
 278                         "propagated to caller");
 279          TC_Handled_In_Grandchild_Pkg_Func := false;
 280               -- Improper exception handling in caller.
 281
 282       when others =>
 283          Report.Failed ("Unexpected exception in multiplication");
 284          TC_Handled_In_Grandchild_Pkg_Func := false;
 285               -- Improper exception handling in caller.
 286
 287    end Multiply_Complex_Subtest;
 288
 289
 290    Add_Complex_Subtest:
 291    declare
 292       Operand_1  : Complex_Array_Type
 293                  := ( Complex (Int_Type (Report.Ident_Int (2)),
 294                       Int_Type (Report.Ident_Int (7))),
 295                       Complex (Int_Type (Report.Ident_Int (5)),
 296                       Int_Type (Report.Ident_Int (8))) );
 297       Operand_2  : Complex_Array_Type
 298                  := ( Complex (Int_Type (Report.Ident_Int (4)),
 299                       Int_Type (Report.Ident_Int (1))),
 300                       Complex (Int_Type (Report.Ident_Int (2)),
 301                       Int_Type (Report.Ident_Int (3))) );
 302       Operand_3  : Complex_Array_Type := ( Zero, Zero);
 303       Add_Result : Complex_Array_Type
 304                  := ( Complex (Int_Type (Report.Ident_Int (6)),
 305                       Int_Type (Report.Ident_Int (8))),
 306                       Complex (Int_Type (Report.Ident_Int (7)),
 307                       Int_Type (Report.Ident_Int (11))) );
 308       Complex_No : Complex_Array_Type := (others => Zero);
 309
 310    begin
 311       Complex_No := Add (Operand_1, Operand_2);
 312
 313       If (Complex_No /= Add_Result) then
 314          Report.Failed ("Incorrect results from addition");
 315       end if;
 316
 317       -- Error is raised in grandchild package and exception
 318       -- will be propagated to caller.
 319
 320       Complex_No := Add (Operand_1, Operand_3);
 321
 322       if Complex_No = Add_Result then
 323          Report.Failed ("Exception was not raised in addition");
 324       end if;
 325
 326    exception
 327       when Add_Error =>
 328          TC_Propagated_To_Caller := true;  -- Exception is propagated.
 329
 330       when others =>
 331          Report.Failed ("Unexpected exception in addition subtest");
 332          TC_Propagated_To_Caller := false;  -- Improper exception handling
 333                                             -- in caller.
 334    end Add_Complex_Subtest;
 335
 336    Inverse_Complex_Subtest:
 337    declare
 338       Operand_1  : Complex_Array_Type
 339                  := ( Complex (Int_Type (Report.Ident_Int (1)),
 340                       Int_Type (Report.Ident_Int (5))),
 341                       Complex (Int_Type (Report.Ident_Int (3)),
 342                       Int_Type (Report.Ident_Int (11))) );
 343       Operand_3  : Complex_Array_Type
 344                  := ( Zero, Complex (Int_Type (Report.Ident_Int (3)),
 345                       Int_Type (Report.Ident_Int (6))) );
 346       Inv_Result : Complex_Array_Type
 347                  := ( Complex (Int_Type (Report.Ident_Int (-1)),
 348                       Int_Type (Report.Ident_Int (-5))),
 349                       Complex (Int_Type (Report.Ident_Int (-3)),
 350                       Int_Type (Report.Ident_Int (-11))) );
 351       Complex_No : Complex_Array_Type := (others => Zero);
 352
 353    begin
 354       Inverse (Operand_1, Complex_No);
 355
 356       if (Complex_No /= Inv_Result) then
 357          Report.Failed ("Incorrect results from inverse");
 358       end if;
 359
 360       -- Error is raised in grandchild package and exception
 361       -- will be handled/reraised to caller.
 362
 363       Inverse (Operand_3, Complex_No);
 364
 365       Report.Failed ("Exception was not handled in inverse");
 366
 367    exception
 368       when Inverse_Error =>
 369          if not TC_Handled_In_Grandchild_Pkg_Proc then
 370             Report.Failed ("Exception was not raised in inverse");
 371          else
 372             TC_Handled_In_Caller := true;  -- Exception is reraised from
 373                                            -- child package.
 374          end if;
 375
 376       when others =>
 377          Report.Failed ("Unexpected exception in inverse");
 378          TC_Handled_In_Caller := false;
 379                 -- Improper exception handling in caller.
 380
 381    end Inverse_Complex_Subtest;
 382
 383    if not (TC_Handled_In_Caller               and   -- Check to see that all
 384            TC_Handled_In_Grandchild_Pkg_Proc  and   -- exceptions were handled
 385            TC_Handled_In_Grandchild_Pkg_Func  and   -- in proper location.
 386            TC_Propagated_To_Caller)
 387    then
 388       Report.Failed ("Exceptions handled in incorrect locations");
 389    end if;
 390
 391    Report.Result;
 392
 393 end CA11D02;