gcc/testsuite/ada/acats/tests/c3/c390011.a

   1 -- C390011.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 tagged types declared within generic package declarations
  28 --     generate distinct tags for each instance of the generic.
  29 --
  30 -- TEST DESCRIPTION:
  31 --     This test defines a very simple generic package (with the expectation
  32 --     that it should be easily be shared), and a few instances of that
  33 --     package.  In true user-like fashion, two of the instances are identical
  34 --     (to wit: IIO is new Integer_IO(Integer)).  The tags generated for each
  35 --     of them are placed into a list.  The last action of the test is to
  36 --     check that everything in the list is unique.
  37 --
  38 --     Almost as an aside, this test defines functions that return T'Base and
  39 --     T'Class, and then exercises these functions.
  40 --
  41 --     (JPR) persistent objects really need a function like:
  42 --        function Get_Object return T'class;
  43 --
  44 --
  45 -- CHANGE HISTORY:
  46 --      20 OCT 95   SAIC   Initial version
  47 --      23 APR 96   SAIC   Commentary Corrections 2.1
  48 --
  49 --!
  50
  51 ----------------------------------------------------------------- C390011_0
  52
  53 with Ada.Tags;
  54 package C390011_0 is
  55
  56   procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String );
  57
  58   procedure Check_List_For_Duplicates;
  59
  60 end C390011_0;
  61
  62 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  63
  64 with Report;
  65 package body C390011_0 is
  66
  67   use type Ada.Tags.Tag;
  68   type SP is access String;
  69
  70   type List_Item;
  71   type List_P is access List_Item;
  72   type List_Item is record
  73     The_Tag  : Ada.Tags.Tag;
  74     Exp_Name : SP;
  75     Ext_Tag  : SP;
  76     Next : List_P;
  77   end record;
  78
  79   The_List : List_P;
  80
  81   procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is
  82   begin  -- prepend the tag information to the list
  83     The_List := new List_Item'( The_Tag  => T,
  84                                 Exp_Name => new String'(X_Name),
  85                                 Ext_Tag  => new String'(X_Tag),
  86                                 Next     => The_List );
  87   end Add_Tag_To_List;
  88
  89   procedure Check_List_For_Duplicates is
  90     Finger : List_P;
  91     Thumb  : List_P := The_List;
  92   begin  --
  93     while Thumb /= null loop
  94       Finger := Thumb.Next;
  95       while Finger /= null loop
  96         -- Check that the tag is unique
  97         if Finger.The_Tag = Thumb.The_Tag then
  98           Report.Failed("Duplicate Tag");
  99         end if;
 100
 101         -- Check that the Expanded name is unique
 102         if Finger.Exp_Name.all = Thumb.Exp_Name.all then
 103           Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats");
 104         end if;
 105
 106         -- Check that the External Tag is unique
 107
 108         if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then
 109           Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats");
 110         end if;
 111         Finger := Finger.Next;
 112       end loop;
 113       Thumb  := Thumb.Next;
 114    end loop;
 115   end Check_List_For_Duplicates;
 116
 117 begin
 118   -- some things I just don't trust...
 119   if The_List /= null then
 120     Report.Failed("Implicit default for The_List not null");
 121   end if;
 122 end C390011_0;
 123
 124 ----------------------------------------------------------------- C390011_1
 125
 126 generic
 127   type Index is (<>);
 128   type Item is private;
 129 package C390011_1 is
 130
 131   type List is array(Index range <>) of Item;
 132   type ListP is access all List;
 133
 134   type Table is tagged record
 135     Data: ListP;
 136   end record;
 137
 138   function Sort( T: in Table'Class ) return Table'Class;
 139
 140   function Stable_Table return Table'Class;
 141
 142   function Table_End( T: Table ) return Index'Base;
 143
 144 end C390011_1;
 145
 146 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 147
 148 package body C390011_1 is
 149
 150     -- In a user program this package would DO something
 151
 152   function Sort( T: in Table'Class ) return Table'Class is
 153   begin
 154    return T;
 155   end Sort;
 156
 157   Empty : Table'Class := Table'( Data => null );
 158
 159   function Stable_Table return Table'Class is
 160   begin
 161     return Empty;
 162   end Stable_Table;
 163
 164   function Table_End( T: Table ) return Index'Base is
 165   begin
 166     return Index'Base( T.Data.all'Last );
 167   end Table_End;
 168
 169 end C390011_1;
 170
 171 ----------------------------------------------------------------- C390011_2
 172
 173 with C390011_1;
 174 package C390011_2 is new C390011_1( Index => Character, Item => Float );
 175
 176 ----------------------------------------------------------------- C390011_3
 177
 178 with C390011_1;
 179 package C390011_3 is new C390011_1( Index => Character, Item => Float );
 180
 181 ----------------------------------------------------------------- C390011_4
 182
 183 with C390011_1;
 184 package C390011_4 is new C390011_1( Index => Integer, Item => Character );
 185
 186 ----------------------------------------------------------------- C390011_5
 187
 188 with C390011_3;
 189 with C390011_4;
 190 package C390011_5 is
 191
 192   type Table_3 is new C390011_3.Table with record
 193     Serial_Number : Integer;
 194   end record;
 195
 196   type Table_4 is new C390011_4.Table with record
 197     Serial_Number : Integer;
 198   end record;
 199
 200 end C390011_5;
 201
 202 -- no package body C390011_5 required
 203
 204 ------------------------------------------------------------------- C390011
 205
 206 with Report;
 207 with C390011_0;
 208 with C390011_2;
 209 with C390011_3;
 210 with C390011_4;
 211 with C390011_5;
 212 with Ada.Tags;
 213 procedure C390011 is
 214
 215 begin  -- Main test procedure.
 216
 217   Report.Test ("C390011", "Check that tagged types declared within " &
 218                           "generic package declarations generate distinct " &
 219                           "tags for each instance of the generic. " &
 220                           "Check that 'Base may be used as a subtype mark. " &
 221                           "Check that T'Base and T'Class are allowed as " &
 222                           "the subtype mark in a function result" );
 223
 224   -- build the tag information table
 225   C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag,
 226                        X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag),
 227                        X_Tag  => Ada.Tags.External_Tag(C390011_2.Table'Tag) );
 228
 229   C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag,
 230                        X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag),
 231                        X_Tag  => Ada.Tags.External_Tag(C390011_3.Table'Tag) );
 232
 233   C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag,
 234                        X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag),
 235                        X_Tag  => Ada.Tags.External_Tag(C390011_4.Table'Tag) );
 236
 237   C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag,
 238                      X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag),
 239                      X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) );
 240
 241   C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag,
 242                      X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag),
 243                      X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) );
 244
 245   -- preform the check for distinct tags
 246   C390011_0.Check_List_For_Duplicates;
 247
 248   Report.Result;
 249
 250 end C390011;