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