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
53with Ada.Tags;
54package 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
60end C390011_0;
61
62-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
63
64with Report;
65package 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
117begin
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;
122end C390011_0;
123
124----------------------------------------------------------------- C390011_1
125
126generic
127  type Index is (<>);
128  type Item is private;
129package 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
144end C390011_1;
145
146-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
147
148package 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
169end C390011_1;
170
171----------------------------------------------------------------- C390011_2
172
173with C390011_1;
174package C390011_2 is new C390011_1( Index => Character, Item => Float );
175
176----------------------------------------------------------------- C390011_3
177
178with C390011_1;
179package C390011_3 is new C390011_1( Index => Character, Item => Float );
180
181----------------------------------------------------------------- C390011_4
182
183with C390011_1;
184package C390011_4 is new C390011_1( Index => Integer, Item => Character );
185
186----------------------------------------------------------------- C390011_5
187
188with C390011_3;
189with C390011_4;
190package 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
200end C390011_5;
201
202-- no package body C390011_5 required
203
204------------------------------------------------------------------- C390011
205
206with Report;
207with C390011_0;
208with C390011_2;
209with C390011_3;
210with C390011_4;
211with C390011_5;
212with Ada.Tags;
213procedure C390011 is
214
215begin  -- 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
250end C390011;
251