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

   1 -- CA11C03.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 when a child unit is "withed", visibility is obtained to
  28 --      all ancestor units named in the expanded name of the "withed" child
  29 --      unit.  Check that when the parent unit is "used", the simple name of
  30 --      a "withed" child unit is made directly visible.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      To satisfy the first part of the objective, various references are
  34 --      made to types and functions declared in the ancestor packages of the
  35 --      foundation code package hierarchy.  Since the grandchild library unit
  36 --      package has been "withed" by this test, the visibility of these
  37 --      components demonstrates that visibility of the ancestor package names
  38 --      is provided when the expanded name of a child library unit is "withed".
  39 --
  40 --      The declare block in the test program includes a "use" clause of the
  41 --      parent package (FA11C00_0.FA11C00_1) of the "withed" child package.
  42 --      As a result, the simple name of the child package (FA11C00_2) is
  43 --      directly visible.  The type and function declared in the child
  44 --      package are now visible when qualified with the simple name of the
  45 --      "withed" package (FA11C00_2).
  46 --
  47 --      This test simulates the formatting of data strings, based on the
  48 --      component fields of a "doubly-extended" tagged record type.
  49 --
  50 -- TEST FILES:
  51 --      This test depends on the following foundation code:
  52 --
  53 --         FA11C00.A
  54 --
  55 --
  56 -- CHANGE HISTORY:
  57 --      06 Dec 94   SAIC    ACVC 2.0
  58 --
  59 --!
  60
  61 with FA11C00_0.FA11C00_1.FA11C00_2;  -- "with" of child library package
  62                                      -- Animal.Mammal.Primate.
  63                                      -- This will be used in conjunction with
  64                                      -- a "use" of FA11C00_0.FA11C00_1 below
  65                                      -- to verify a portion of the objective.
  66 with Report;
  67
  68 procedure CA11C03 is
  69
  70    Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' ');
  71                                      -- Visibility of grandparent package.
  72                                      -- The package FA11C00_0 is visible since
  73                                      -- it is an ancestor that is mentioned in
  74                                      -- the expanded name of its "withed"
  75                                      -- grandchild package.
  76
  77    Blank_Hair_Color :
  78      String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' ');
  79                                      -- Visibility of parent package.
  80                                      -- The package FA11C00_0.FA11C00_1 is
  81                                      -- visible due to the "with" of its
  82                                      -- child package.
  83
  84    subtype Data_String_Type is String (1 .. 60);
  85
  86    TC_Result_String : Data_String_Type := (others => ' ');
  87
  88    --
  89
  90    function Format_Primate_Data (Name : String := Blank_Name_String;
  91                                  Hair : String := Blank_Hair_Color)
  92      return Data_String_Type is
  93
  94       Pos                        : Integer := 1;
  95       Hair_Color_Field_Separator : constant String := " Hair Color: ";
  96
  97       Result_String              : Data_String_Type := (others => ' ');
  98
  99    begin
 100       Result_String (Pos .. Name'Length) := Name;    -- Enter name at start
 101                                                      -- of string.
 102       Pos := Pos + Name'Length;                      -- Increment counter to
 103                                                      -- next blank position.
 104       Result_String
 105         (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) :=
 106         Hair_Color_Field_Separator & Hair;           -- Include hair color data
 107                                                      -- in result string.
 108       return (Result_String);
 109    end Format_Primate_Data;
 110
 111
 112 begin
 113
 114    Report.Test ("CA11C03", "Check that when a child unit is WITHED, "        &
 115                            "visibility is obtained to all ancestor units "   &
 116                            "named in the expanded name of the WITHED child " &
 117                            "unit. Check that when the parent unit is USED, " &
 118                            "the simple name of a WITHED child unit is made " &
 119                            "directly visible" );
 120
 121    declare
 122       use FA11C00_0.FA11C00_1;    -- This "use" clause will allow direct
 123                                   -- visibility to the simple name of
 124                                   -- package FA11C00_0.FA11C00_1.FA11C00_2,
 125                                   -- since this child package was "withed" by
 126                                   -- the main program.
 127
 128       Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ",
 129                                       Weight      => 7,
 130                                       Hair_Color  => Brown,
 131                                       Habitat     => FA11C00_2.Arboreal);
 132
 133                                   -- Demonstrates visibility of package
 134                                   -- FA11C00_0.FA11C00_1.FA11C00_2.
 135                                   --
 136                                   -- Type Primate referenced with the simple
 137                                   -- name of package FA11C00_2 only.
 138                                   --
 139                                   -- Simple name of package FA11C00_2 is
 140                                   -- directly visible through "use" of parent.
 141
 142    begin
 143
 144       -- Verify that the Format_Primate_Data function will return a blank
 145       -- filled string when no parameters are provided in the call.
 146
 147       TC_Result_String := Format_Primate_Data;
 148
 149       if (TC_Result_String (1 .. 20)  /= Blank_Name_String) then
 150          Report.Failed ("Incorrect initialization value from function");
 151       end if;
 152
 153
 154       -- Use function Format_Primate_Data to return a formatted data string.
 155
 156       TC_Result_String :=
 157         Format_Primate_Data
 158          (Name => FA11C00_2.Image (Tarsier),
 159                                   -- Function returns a 37 character string
 160                                   -- value.
 161           Hair => Hair_Color_Type'Image(Tarsier.Hair_Color));
 162                                   -- The Hair_Color_Type is referenced
 163                                   -- directly, without package
 164                                   -- FA11C00_0.FA11C00_1 qualifier.
 165                                   -- No qualification of Hair_Color_Type is
 166                                   -- needed due to "use" clause.
 167
 168                                   -- Note that the result of calling 'Image
 169                                   -- with an enumeration type argument
 170                                   -- results in an upper-case string.
 171                                   -- (See conditional statement below.)
 172
 173       -- Verify the results of the function call.
 174
 175       if not  (TC_Result_String (1 .. 37) =
 176                 "Primate Species: East-Indian Tarsier " and then
 177               TC_Result_String (38 .. 55) =
 178                 " Hair Color: BROWN") then
 179         Report.Failed ("Incorrect result returned from function call");
 180       end if;
 181
 182    end;
 183
 184    Report.Result;
 185
 186 end CA11C03;