gomp-20050608-branch/gcc/testsuite/ada/acats/tests/ca/ca11001.a

   1 -- CA11001.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 a child unit can be used to provide an alternate view and
  28 --      operations on a private type in its parent package.  Check that a
  29 --      child unit can be a package.  Check that a WITH of a child unit
  30 --      includes an implicit WITH of its ancestor unit.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      Declare a private type in a package specification. Declare
  34 --      subprograms for the type.
  35 --
  36 --      Add a public child to the above package.  Within the body of this
  37 --      package, access the private type. Declare operations to read and
  38 --      write to its parent private type.
  39 --
  40 --      In the main program, "with" the child.  Declare objects of the
  41 --      parent private type.  Access the subprograms from both parent and
  42 --      child packages.
  43 --
  44 --
  45 -- CHANGE HISTORY:
  46 --      06 Dec 94   SAIC    ACVC 2.0
  47 --
  48 --!
  49
  50 package CA11001_0 is   -- Cartesian_Complex
  51 --  This package represents a Cartesian view of a complex number.  It contains
  52 --  a private type plus subprograms to construct and decompose a complex
  53 --  number.
  54
  55    type Complex_Int is range 0 .. 100;
  56
  57    type Complex_Type is private;
  58
  59    Constant_Complex : constant Complex_Type;
  60
  61    Complex_Error : exception;
  62
  63    procedure Cartesian_Assign   (R, I : in     Complex_Int;
  64                                  C    :    out Complex_Type);
  65
  66    function Cartesian_Real_Part (C : Complex_Type)
  67      return Complex_Int;
  68
  69    function Cartesian_Imag_Part (C : Complex_Type)
  70      return Complex_Int;
  71
  72    function Complex (Real, Imaginary : Complex_Int)
  73      return Complex_Type;
  74
  75 private
  76    type Complex_Type is                      -- Parent private type
  77       record
  78          Real, Imaginary : Complex_Int;
  79       end record;
  80
  81    Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0);
  82
  83 end CA11001_0;       -- Cartesian_Complex
  84
  85 --=======================================================================--
  86
  87 package body CA11001_0 is  -- Cartesian_Complex
  88
  89    procedure Cartesian_Assign (R, I : in     Complex_Int;
  90                                C    :    out Complex_Type) is
  91    begin
  92       C.Real      := R;
  93       C.Imaginary := I;
  94    end Cartesian_Assign;
  95    -------------------------------------------------------------
  96    function Cartesian_Real_Part (C : Complex_Type)
  97      return Complex_Int is
  98    begin
  99       return C.Real;
 100    end Cartesian_Real_Part;
 101    -------------------------------------------------------------
 102    function Cartesian_Imag_Part (C : Complex_Type)
 103      return Complex_Int is
 104    begin
 105       return C.Imaginary;
 106    end Cartesian_Imag_Part;
 107    -------------------------------------------------------------
 108    function Complex (Real, Imaginary : Complex_Int)
 109      return Complex_Type is
 110    begin
 111       return (Real, Imaginary);
 112    end Complex;
 113
 114 end CA11001_0;      -- Cartesian_Complex
 115
 116 --=======================================================================--
 117
 118 package CA11001_0.CA11001_1 is    -- Polar_Complex
 119 --  This public child provides a different view of the private type from its
 120 --  parent.  It provides a polar view by the provision of subprograms which
 121 --  construct and decompose a complex number.
 122
 123    procedure Polar_Assign (R, Theta : in     Complex_Int;
 124                            C        :    out Complex_Type);
 125                                              -- Complex_Type is a
 126                                              -- record of CA11001_0
 127
 128    function Polar_Real_Part (C: Complex_Type) return Complex_Int;
 129
 130    function Polar_Imag_Part (C: Complex_Type) return Complex_Int;
 131
 132    function Equals_Const (Num : Complex_Type) return Boolean;
 133
 134 end CA11001_0.CA11001_1;    -- Polar_Complex
 135
 136 --=======================================================================--
 137
 138 package body CA11001_0.CA11001_1 is   -- Polar_Complex
 139
 140    function Cos (Angle : Complex_Int) return Complex_Int is
 141       Num : constant Complex_Int := 2;
 142    begin
 143       return (Angle * Num);   -- not true Cosine function
 144    end Cos;
 145    -------------------------------------------------------------
 146    function Sine (Angle : Complex_Int) return Complex_Int is
 147    begin
 148       return 1;     -- not true Sine function
 149    end Sine;
 150    -------------------------------------------------------------
 151    function Sqrt (Num : Complex_Int)
 152      return Complex_Int is
 153    begin
 154      return (Num);     -- not true Square root function
 155    end Sqrt;
 156    -------------------------------------------------------------
 157    function Tan  (Angle : Complex_Int) return Complex_Int is
 158    begin
 159      return Angle;     -- not true Tangent function
 160    end Tan;
 161    -------------------------------------------------------------
 162    procedure Polar_Assign (R, Theta : in     Complex_Int;
 163                            C        :    out Complex_Type) is
 164    begin
 165       if R = 0 and Theta = 0 then
 166          raise Complex_Error;
 167       end if;
 168       C.Real := R * Cos (Theta);
 169       C.Imaginary := R * Sine (Theta);
 170    end Polar_Assign;
 171    -------------------------------------------------------------
 172    function Polar_Real_Part (C: Complex_Type) return Complex_Int is
 173    begin
 174       return Sqrt ((Cartesian_Imag_Part (C)) ** 2 +
 175                    (Cartesian_Real_Part (C)) ** 2);
 176    end Polar_Real_Part;
 177    -------------------------------------------------------------
 178    function Polar_Imag_Part (C: Complex_Type) return Complex_Int is
 179    begin
 180       return (Tan (Cartesian_Imag_Part (C) /
 181               Cartesian_Real_Part (C)));
 182    end Polar_Imag_Part;
 183    -------------------------------------------------------------
 184    function Equals_Const (Num : Complex_Type) return Boolean is
 185    begin
 186       return Num.Real = Constant_Complex.Real and
 187          Num.Imaginary = Constant_Complex.Imaginary;
 188    end Equals_Const;
 189
 190 end CA11001_0.CA11001_1;     -- Polar_Complex
 191
 192 --=======================================================================--
 193
 194 with CA11001_0.CA11001_1;        -- Polar_Complex
 195 with Report;
 196
 197 procedure CA11001 is
 198
 199    Complex_No  : CA11001_0.Complex_Type;    -- Complex_Type is a
 200                                             -- record of CA11001_0
 201
 202    Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2);
 203
 204    Int_2       :  CA11001_0.Complex_Int
 205                := CA11001_0.Complex_Int (Report.Ident_Int (2));
 206
 207 begin
 208
 209    Report.Test ("CA11001", "Check that a child unit can be used " &
 210                 "to provide an alternate view and operations " &
 211                 "on a private type in its parent package");
 212
 213    Basic_View_Subtest:
 214
 215    begin
 216       -- Assign using Cartesian coordinates.
 217       CA11001_0.Cartesian_Assign
 218         (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No);
 219
 220       -- Read back in Polar coordinates.
 221       -- Polar values are surrogates used in checking for correct
 222       -- subprogram calls.
 223       if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No),
 224         CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/="
 225           (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No),
 226             CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then
 227            Report.Failed ("Incorrect Cartesian result");
 228       end if;
 229
 230    end Basic_View_Subtest;
 231    -------------------------------------------------------------
 232    Alternate_View_Subtest:
 233    begin
 234       -- Assign using Polar coordinates.
 235       CA11001_0.CA11001_1.Polar_Assign
 236         (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No);
 237
 238       -- Read back in Cartesian coordinates.
 239       if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part
 240         (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or
 241           CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2)
 242       then
 243          Report.Failed ("Incorrect Polar result");
 244       end if;
 245    end Alternate_View_Subtest;
 246    -------------------------------------------------------------
 247    Other_Subtest:
 248    begin
 249       -- Assign using Polar coordinates.
 250       CA11001_0.CA11001_1.Polar_Assign
 251         (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No);
 252
 253       -- Compare with Complex_Num in CA11001_0.
 254       if not CA11001_0.CA11001_1.Equals_Const (Complex_No)
 255         then
 256          Report.Failed ("Incorrect result");
 257       end if;
 258    end Other_Subtest;
 259    -------------------------------------------------------------
 260    Exception_Subtest:
 261    begin
 262       -- Raised parent's exception.
 263       CA11001_0.CA11001_1.Polar_Assign
 264         (CA11001_0.Complex_Int (Report.Ident_Int (0)),
 265            CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No);
 266       Report.Failed ("Exception was not raised");
 267    exception
 268       when CA11001_0.Complex_Error =>
 269          null;
 270       when others                  =>
 271          Report.Failed ("Unexpected exception raised in test");
 272    end Exception_Subtest;
 273
 274    Report.Result;
 275
 276 end CA11001;