1-- CC51D02.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, in an instance, each implicit declaration of a user-defined 28-- subprogram of a formal private extension declares a view of the 29-- corresponding primitive subprogram of the ancestor, and that if the 30-- tag in a call is statically determined to be that of the formal type, 31-- the body executed will be that corresponding to the actual type. 32-- 33-- Check subprograms declared within a generic formal package. Check for 34-- the case where the actual type passed to the formal private extension 35-- is a class-wide type. Check for several types in the same class. 36-- 37-- 38-- TEST DESCRIPTION: 39-- Declare a list abstraction in a generic package which manages lists of 40-- elements of any nonlimited type (foundation code). Declare a package 41-- which declares a tagged type and a derivative. Declare an operation 42-- for the root tagged type and override it for the derivative. Declare 43-- a generic subprogram which operates on lists of elements of tagged 44-- types. Provide the generic subprogram with two formal parameters: (1) 45-- a formal derived tagged type which represents a list element type, and 46-- (2) a generic formal package with the list abstraction package as 47-- template. Use the formal derived type as the generic formal actual 48-- part for the formal package. Within the generic subprogram, call the 49-- operation of the root tagged type. In the main program, instantiate 50-- the generic list package and the generic subprogram with the class-wide 51-- type for the root tagged type. 52-- 53-- TEST FILES: 54-- The following files comprise this test: 55-- 56-- FC51D00.A 57-- -> CC51D02.A 58-- 59-- 60-- CHANGE HISTORY: 61-- 06 Dec 94 SAIC ACVC 2.0 62-- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2 63-- from specific to class-wide. Eliminated (illegal) 64-- assignment step prior to comparison of 65-- TC_Expected_X with item on stack. 66-- 67--! 68 69package CC51D02_0 is -- This package simulates support for a personnel 70 -- database. 71 72 type SSN_Type is new String (1 .. 9); 73 74 type Blind_ID_Type is tagged record -- Root type of 75 SSN : SSN_Type; -- class. 76 -- ... Other components. 77 end record; 78 79 procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. 80 81 -- ... Other operations. 82 83 84 type Name_Type is new String (1 .. 9); 85 86 type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative 87 Name : Name_Type := "Doe "; -- of root type. 88 -- ... Other components. 89 end record; 90 91 -- Inherits Update_ID from parent. 92 93 procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's 94 -- implementation. 95 96end CC51D02_0; 97 98 99 --==================================================================-- 100 101 102package body CC51D02_0 is 103 104 -- The implementations of Update_ID are purely artificial; the validity of 105 -- their implementations in the context of the abstraction is irrelevant to 106 -- the feature being tested. 107 108 procedure Update_ID (Item : in out Blind_ID_Type) is 109 begin 110 Item.SSN := "111223333"; 111 end Update_ID; 112 113 114 procedure Update_ID (Item : in out Named_ID_Type) is 115 begin 116 Item.SSN := "444556666"; 117 -- ... Other stuff. 118 end Update_ID; 119 120end CC51D02_0; 121 122 123 --==================================================================-- 124 125 126-- -- 127-- Formal package used here. -- 128-- -- 129 130with FC51D00; -- Generic list abstraction. 131with CC51D02_0; -- Tagged type declarations. 132generic -- This procedure simulates a generic operation for types 133 -- in the class rooted at Blind_ID_Type. 134 type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private; 135 with package List_Mgr is new FC51D00 (Elem_Type); 136procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); 137 138 139 --==================================================================-- 140 141 142-- The implementation of CC51D02_1 is purely artificial; the validity 143-- of its implementation in the context of the abstraction is irrelevant 144-- to the feature being tested. 145-- 146-- The expected behavior here is as follows: for each actual type corresponding 147-- to Elem_Type, the call to Update_ID should invoke the actual type's 148-- implementation (based on the tag of the actual), which updates the object's 149-- SSN field. Write_Element then adds the object to the list. 150 151procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is 152 Element : Elem_Type := E; -- Can't update IN parameter. 153 -- Initialization of unconstrained variable. 154begin 155 Update_ID (Element); -- Executes actual type's version 156 -- (for this test, this will be a 157 -- dispatching call). 158 List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version 159 -- (for this test, this will be a 160 -- class-wide operation). 161end CC51D02_1; 162 163 164 --==================================================================-- 165 166 167with FC51D00; -- Generic list abstraction. 168with CC51D02_0; -- Tagged type declarations. 169with CC51D02_1; -- Generic operation. 170 171with Report; 172procedure CC51D02 is 173 174 use CC51D02_0; -- All types & ops 175 -- directly visible. 176 177 -- Begin test code declarations: ----------------------- 178 179 TC_Expected_1 : Blind_ID_Type'Class := 180 Blind_ID_Type'(SSN => "111223333"); 181 TC_Expected_2 : Blind_ID_Type'Class := 182 Named_ID_Type'("444556666", "Doe "); 183 184 185 TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); 186 TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); 187 TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2; 188 189 -- End test code declarations. ------------------------- 190 191 192 package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class); 193 194 procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class, 195 ID_Class_Lists); 196 197 Blind_List : ID_Class_Lists.List_Type; 198 Named_List : ID_Class_Lists.List_Type; 199 Maimed_List : ID_Class_Lists.List_Type; 200 201 202begin 203 Report.Test ("CC51D02", "Formal private extension, class-wide actual: " & 204 "body of primitive subprogram executed is that of actual " & 205 "type. Check for subprograms declared in formal package"); 206 207 208 Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual. 209 210 if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then 211 Report.Failed ("Result for root type actual is not in proper class"); 212 elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then 213 Report.Failed ("Wrong result for root type actual"); 214 end if; 215 216 217 Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual. 218 219 if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then 220 Report.Failed ("Result for derived type actual is not in proper class"); 221 elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then 222 Report.Failed ("Wrong result for derived type actual"); 223 end if; 224 225 226 -- In the subtest below, an object of a class-wide type (TC_Initial_3) is 227 -- passed to Update_and_Write. It has been initialized with an object of 228 -- type Named_ID_Type, so the result should be identical to 229 -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that 230 -- a new list of Named IDs is used (Maimed_List). This is to assure test 231 -- validity, since Named_List has already been updated by a previous 232 -- subtest. 233 234 Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual. 235 236 if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then 237 Report.Failed ("Result for class-wide actual is not in proper class"); 238 elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then 239 Report.Failed ("Wrong result for class-wide actual"); 240 end if; 241 242 243 Report.Result; 244end CC51D02; 245