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

   1 -- CA11020.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 body of the generic parent package can depend on one of
  28 --      its own public generic children.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      A scenario is created that demonstrates the potential of adding a
  32 --      public generic child during code maintenance without distubing a large
  33 --      subsystem.  After child is added to the subsystem, a maintainer
  34 --      decides to take advantage of the new functionality and rewrites
  35 --      the parent's body.
  36 --
  37 --      Declare a bag abstraction in a generic package. Declare a public
  38 --      generic child of this package which adds a generic procedure to the
  39 --      original subsystem.  In the parent body, instantiate the public
  40 --      child.  Then instantiate the procedure as a child instance of the
  41 --      public child instance.
  42 --
  43 --      In the main program, declare an instance of parent.  Check that the
  44 --      operations in both parent and child packages perform as expected.
  45 --
  46 --
  47 -- CHANGE HISTORY:
  48 --      06 Dec 94   SAIC    ACVC 2.0
  49 --
  50 --!
  51
  52 -- Simulates bag application.
  53
  54 generic
  55    type Element is private;
  56    with function Image (E : Element) return String;
  57
  58 package CA11020_0 is
  59
  60    type Bag is limited private;
  61
  62    procedure Add (E : in Element; To_The_Bag : in out Bag);
  63
  64    function Bag_Image (B : Bag) return string;
  65
  66 private
  67    type Node_Type;
  68    type Bag is access Node_Type;
  69
  70    type Node_Type is
  71       record
  72          The_Element : Element;
  73
  74          -- Other components in real application, i.e.,
  75          -- The_Count   : positive;
  76
  77          Next        : Bag;
  78       end record;
  79
  80 end CA11020_0;
  81
  82      --==================================================================--
  83
  84 -- More operations on Bag.
  85
  86 generic
  87
  88 -- Parameters go here.
  89
  90 package CA11020_0.CA11020_1 is
  91
  92    -- ... Other declarations.
  93
  94    generic                            -- Generic iterator procedure.
  95       with procedure Use_Element (E : in Element);
  96
  97    procedure Iterate (B : in Bag);    -- Called once per element in the bag.
  98
  99    -- ... Various other operations.
 100
 101 end CA11020_0.CA11020_1;
 102
 103      --==================================================================--
 104
 105 package body CA11020_0.CA11020_1 is
 106
 107    procedure Iterate (B : in Bag) is
 108
 109    -- Traverse each element in the bag.
 110
 111       Elem : Bag := B;
 112
 113    begin
 114       while Elem /= null loop
 115          Use_Element (Elem.The_Element);
 116          Elem := Elem.Next;
 117       end loop;
 118
 119    end Iterate;
 120
 121 end CA11020_0.CA11020_1;
 122
 123      --==================================================================--
 124
 125 with CA11020_0.CA11020_1;    -- Public generic child package.
 126
 127 package body CA11020_0 is
 128
 129    ----------------------------------------------------
 130    -- Parent's body depends on public generic child. --
 131    ----------------------------------------------------
 132
 133    -- Instantiate the public child.
 134
 135    package MS is new CA11020_1;
 136
 137    function Bag_Image (B : Bag) return string is
 138
 139       Buffer : String (1 .. 10_000);
 140       Last   : Integer := 0;
 141
 142       -----------------------------------------------------
 143
 144       -- Will be called by the iterator.
 145
 146       procedure Append_Image (E : in Element) is
 147          Im : constant String := Image (E);
 148
 149       begin  -- Append_Image
 150          if Last /= 0 then        -- Insert a comma.
 151             Last := Last + 1;
 152             Buffer (Last) := ',';
 153          end if;
 154
 155          Buffer (Last + 1 .. Last + Im'Length) := Im;
 156          Last := Last + Im'Length;
 157
 158       end Append_Image;
 159
 160       -----------------------------------------------------
 161
 162       -- Instantiate procedure Iterate as a child of instance MS.
 163
 164       procedure Append_All is new MS.Iterate (Use_Element => Append_Image);
 165
 166    begin  -- Bag_Image
 167
 168       Append_All (B);
 169
 170       return Buffer (1 .. Last);
 171
 172    end Bag_Image;
 173
 174            -----------------------------------------------------
 175
 176    procedure Add (E : in Element; To_The_Bag : in out Bag) is
 177
 178       -- Not a real bag addition.
 179
 180       Index : Bag := To_The_Bag;
 181
 182    begin
 183       -- ... Error-checking code omitted for brevity.
 184
 185       if Index = null then
 186          To_The_Bag := new Node_Type' (The_Element => E,
 187                                        Next        => null);
 188       else
 189          -- Goto the end of the list.
 190
 191          while Index.Next /= null loop
 192             Index := Index.Next;
 193          end loop;
 194
 195          -- Add element to the end of the list.
 196
 197          Index.Next := new Node_Type' (The_Element => E,
 198                                        Next        => null);
 199       end if;
 200
 201    end Add;
 202
 203 end CA11020_0;
 204
 205      --==================================================================--
 206
 207 with CA11020_0;               -- Bag application.
 208
 209 with Report;
 210
 211 procedure CA11020 is
 212
 213     -- Instantiate the bag application for integer type and attribute
 214     -- Image.
 215
 216     package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);
 217
 218     My_Bag : Bag_Of_Integers.Bag;
 219
 220 begin
 221
 222    Report.Test ("CA11020", "Check that body of the generic parent package " &
 223                 "can depend on one of its own public generic children");
 224
 225    -- Add 10 consecutive integers to the bag.
 226
 227    for I in 1 .. 10 loop
 228       Bag_Of_Integers.Add (I, My_Bag);
 229    end loop;
 230
 231    if Bag_Of_Integers.Bag_Image (My_Bag)
 232       /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then
 233          Report.Failed ("Incorrect results");
 234    end if;
 235
 236    Report.Result;
 237
 238 end CA11020;