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

   1 -- CA11019.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 parent package may depend on one of its own
  28 --      private generic children.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      A scenario is created that demonstrates the potential of adding a
  32 --      generic private child during code maintenance without distubing a
  33 --      large 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 data collection abstraction in a package. Declare a private
  38 --      generic child of this package which provides parameterized code that
  39 --      have been written once and will be used three times to implement the
  40 --      services of the parent package. In the parent body, instantiate the
  41 --      private child.
  42 --
  43 --      In the main program, check that the operations in the parent,
  44 --      and instance of the private child package perform as expected.
  45 --
  46 --
  47 -- CHANGE HISTORY:
  48 --      06 Dec 94   SAIC    ACVC 2.0
  49 --      17 Nov 95   SAIC    Update and repair for ACVC 2.0.1
  50 --
  51 --!
  52
  53 package CA11019_0 is
  54      -- parent
  55
  56    type Data_Record is tagged private;
  57    type Data_Collection is private;
  58    ---
  59    ---
  60    subtype Data_1 is integer range 0 .. 100;
  61    procedure Add_1 (Data : Data_1; To : in out Data_Collection);
  62    function Statistical_Op_1 (Data : Data_Collection) return Data_1;
  63    ---
  64    subtype Data_2 is integer range -100 .. 1000;
  65    procedure Add_2 (Data : Data_2; To : in out Data_Collection);
  66    function Statistical_Op_2 (Data : Data_Collection) return Data_2;
  67    ---
  68    subtype Data_3 is integer range -10_000 .. 10_000;
  69    procedure Add_3 (Data : Data_3; To : in out Data_Collection);
  70    function Statistical_Op_3 (Data : Data_Collection) return Data_3;
  71    ---
  72
  73 private
  74
  75    type Data_Ptr is access Data_Record'class;
  76    subtype Sequence_Number is positive range 1 .. 512;
  77
  78    type Data_Record is tagged
  79      record
  80         Next  : Data_Ptr := null;
  81         Seq   : Sequence_Number;
  82      end record;
  83    ---
  84    type Data_Collection is
  85      record
  86         First : Data_Ptr := null;
  87         Last  : Data_Ptr := null;
  88      end record;
  89
  90 end CA11019_0;
  91  -- parent
  92
  93     --=================================================================--
  94
  95 -- This generic package provides parameterized code that has been
  96 -- written once and will be used three times to implement the services
  97 -- of the parent package.
  98
  99 private
 100 generic
 101    type Data_Type is range <>;
 102
 103 package CA11019_0.CA11019_1 is
 104      -- parent.child
 105
 106    type Data_Elem is new Data_Record with
 107      record
 108         Value : Data_Type;
 109      end record;
 110
 111    Next_Avail_Seq_No : Sequence_Number := 1;
 112
 113    procedure Sequence (Ptr : Data_Ptr);
 114     -- the child must be private for this procedure to know details of
 115     -- the implementation of data collections
 116
 117    procedure Add (Datum : Data_Type; To : in out Data_Collection);
 118
 119    function  Op  (Data : Data_Collection) return Data_Type;
 120     -- op models a complicated operation that whose code can be
 121     -- used for various data types
 122
 123
 124 end CA11019_0.CA11019_1;
 125  -- parent.child
 126
 127      --=================================================================--
 128
 129
 130 package body CA11019_0.CA11019_1 is
 131           -- parent.child
 132
 133    procedure Sequence (Ptr : Data_Ptr) is
 134    begin
 135       Ptr.Seq := Next_Avail_Seq_No;
 136       Next_Avail_Seq_No := Next_Avail_Seq_No + 1;
 137    end Sequence;
 138
 139    ---------------------------------------------------------
 140
 141    procedure Add (Datum : Data_Type; To : in out Data_Collection) is
 142       Ptr : Data_Ptr;
 143    begin
 144       if To.First = null then
 145          -- assign new record with data value to
 146          -- to.next <- null;
 147          To.First := new Data_Elem'(Next  => null,
 148                                     Value => Datum,
 149                                     Seq   => 1);
 150          Sequence (To.First);
 151          To.Last := To.First;
 152       else
 153          -- chase to end of list
 154          Ptr := To.First;
 155          while Ptr.Next /= null loop
 156             Ptr := Ptr.Next;
 157          end loop;
 158          -- and add element there
 159          Ptr.Next := new Data_Elem'(Next  => null,
 160                                     Value => Datum,
 161                                     Seq   => 1);
 162          Sequence (Ptr.Next);
 163          To.Last := Ptr.Next;
 164       end if;
 165
 166    end Add;
 167
 168    ---------------------------------------------------------
 169
 170    function  Op  (Data : Data_Collection) return Data_Type is
 171       -- for simplicity, just return the maximum of the data set
 172       Max : Data_Type := Data_Elem( Data.First.all ).Value;
 173                               -- assuming non-empty collection
 174       Ptr : Data_Ptr  := Data.First;
 175
 176    begin
 177       -- no error checking
 178       while Ptr.Next /= null loop
 179          if Data_Elem( Ptr.Next.all ).Value > Max then
 180             Max := Data_Elem( Ptr.Next.all ).Value;
 181          end if;
 182          Ptr := Ptr.Next;
 183       end loop;
 184       return Max;
 185    end Op;
 186
 187 end CA11019_0.CA11019_1;
 188  -- parent.child
 189
 190      --=================================================================--
 191
 192 -- parent body depends on private generic child
 193 with CA11019_0.CA11019_1;     -- Private generic child.
 194
 195 pragma Elaborate (CA11019_0.CA11019_1);
 196 package body CA11019_0 is
 197
 198    -- instantiate the generic child with data types needed by the
 199    -- package interface services
 200    package Data_1_Ops is new CA11019_1
 201      (Data_Type => Data_1);
 202
 203    package Data_2_Ops is new CA11019_1
 204      (Data_Type => Data_2);
 205
 206    package Data_3_Ops is new CA11019_1
 207      (Data_Type => Data_3);
 208
 209    ---------------------------------------------------------
 210
 211    procedure Add_1 (Data : Data_1; To : in out Data_Collection) is
 212    begin
 213       -- maybe do other stuff here
 214       Data_1_Ops.Add (Data, To);
 215       -- and here
 216    end;
 217
 218    ---------------------------------------------------------
 219
 220    function Statistical_Op_1 (Data : Data_Collection) return Data_1 is
 221    begin
 222       -- maybe use generic operation(s) in some complicated ways
 223       -- (but simplified out, for the sake of testing)
 224       return Data_1_Ops.Op (Data);
 225    end;
 226
 227    ---------------------------------------------------------
 228
 229    procedure Add_2 (Data : Data_2; To : in out Data_Collection) is
 230    begin
 231       Data_2_Ops.Add (Data, To);
 232    end;
 233
 234    ---------------------------------------------------------
 235
 236    function Statistical_Op_2 (Data : Data_Collection) return Data_2 is
 237    begin
 238       return Data_2_Ops.Op (Data);
 239    end;
 240
 241    ---------------------------------------------------------
 242
 243    procedure Add_3 (Data : Data_3; To : in out Data_Collection) is
 244    begin
 245       Data_3_Ops.Add (Data, To);
 246    end;
 247
 248    ---------------------------------------------------------
 249
 250    function Statistical_Op_3 (Data : Data_Collection) return Data_3 is
 251    begin
 252       return Data_3_Ops.Op (Data);
 253    end;
 254
 255 end CA11019_0;
 256
 257
 258      --=================================================--
 259
 260 with CA11019_0,
 261   -- Main,
 262   -- Main.Child is private
 263      Report;
 264
 265 procedure CA11019 is
 266
 267    package Main renames CA11019_0;
 268
 269    Col_1,
 270    Col_2,
 271    Col_3 : Main.Data_Collection;
 272
 273 begin
 274
 275    Report.Test ("CA11019", "Check that body of a (non-generic) package " &
 276                 "may depend on its private generic child");
 277
 278    -- build a data collection
 279
 280    for I in 1 .. 10 loop
 281       Main.Add_1 ( Main.Data_1(I), Col_1);
 282    end loop;
 283
 284    if Main.Statistical_Op_1 (Col_1) /= 10 then
 285       Report.Failed ("Wrong data_1 value returned");
 286    end if;
 287
 288    for I in reverse 10 .. 20 loop
 289       Main.Add_2 ( Main.Data_2(I * 10), Col_2);
 290    end loop;
 291
 292    if Main.Statistical_Op_2 (Col_2) /= 200 then
 293       Report.Failed ("Wrong data_2 value returned");
 294    end if;
 295
 296    for I in 0 .. 10 loop
 297       Main.Add_3 ( Main.Data_3(I + 5), Col_3);
 298    end loop;
 299
 300    if Main.Statistical_Op_3 (Col_3) /= 15 then
 301       Report.Failed ("Wrong data_3 value returned");
 302    end if;
 303
 304    Report.Result;
 305
 306 end CA11019;