1-- C390007.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 the tag of an object of a tagged type is preserved by 28-- type conversion and parameter passing. 29-- 30-- TEST DESCRIPTION: 31-- The fact that the tag of an object is not changed is verified by 32-- making dispatching calls to primitive operations, and confirming that 33-- the proper body is executed. Objects of both specific and class-wide 34-- types are checked. 35-- 36-- The dispatching calls are made in two contexts. The first is a 37-- straightforward dispatching call made from within a class-wide 38-- operation. The second is a redispatch from within a primitive 39-- operation. 40-- 41-- For the parameter passing case, the initial class-wide and specific 42-- objects are passed directly in calls to the class-wide and primitive 43-- operations. The redispatch is accomplished by initializing a local 44-- class-wide object in the primitive operation to the value of the 45-- formal parameter, and using the local object as the actual in the 46-- (re)dispatching call. 47-- 48-- For the type conversion case, the initial class-wide object is assigned 49-- a view conversion of an object of a specific type: 50-- 51-- type T is tagged ... 52-- type DT is new T with ... 53-- 54-- A : DT; 55-- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT. 56-- 57-- The class-wide object is then passed directly in calls to the 58-- class-wide and primitive operations. For the initial object of a 59-- specific type, however, a view conversion of the object is passed, 60-- forcing a non-dispatching call in the primitive operation case. Within 61-- the primitive operation, a view conversion of the formal parameter to 62-- a class-wide type is then used to force a (re)dispatching call. 63-- 64-- For the type conversion and parameter passing case, a combining of 65-- view conversion and parameter passing of initial specific objects are 66-- called directly to the class-wide and primitive operations. 67-- 68-- 69-- CHANGE HISTORY: 70-- 28 Jun 95 SAIC Initial prerelease version. 71-- 23 Apr 96 SAIC Added use C390007_0 in the main. 72-- 73--! 74 75package C390007_0 is 76 77 type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, 78 Derived_Outer, Derived_Inner); 79 80 type Root_Type is abstract tagged null record; 81 82 procedure Outer_Proc (X : in out Root_Type) is abstract; 83 procedure Inner_Proc (X : in out Root_Type) is abstract; 84 85 procedure ClassWide_Proc (X : in out Root_Type'Class); 86 87end C390007_0; 88 89 90 --==================================================================-- 91 92 93package body C390007_0 is 94 95 procedure ClassWide_Proc (X : in out Root_Type'Class) is 96 begin 97 Inner_Proc (X); 98 end ClassWide_Proc; 99 100end C390007_0; 101 102 103 --==================================================================-- 104 105 106package C390007_0.C390007_1 is 107 108 type Param_Parent_Type is new Root_Type with record 109 Last_Call : Call_ID_Kind := None; 110 end record; 111 112 procedure Outer_Proc (X : in out Param_Parent_Type); 113 procedure Inner_Proc (X : in out Param_Parent_Type); 114 115end C390007_0.C390007_1; 116 117 118 --==================================================================-- 119 120 121package body C390007_0.C390007_1 is 122 123 procedure Outer_Proc (X : in out Param_Parent_Type) is 124 begin 125 X.Last_Call := Parent_Outer; 126 end Outer_Proc; 127 128 procedure Inner_Proc (X : in out Param_Parent_Type) is 129 begin 130 X.Last_Call := Parent_Inner; 131 end Inner_Proc; 132 133end C390007_0.C390007_1; 134 135 136 --==================================================================-- 137 138 139package C390007_0.C390007_1.C390007_2 is 140 141 type Param_Derived_Type is new Param_Parent_Type with null record; 142 143 procedure Outer_Proc (X : in out Param_Derived_Type); 144 procedure Inner_Proc (X : in out Param_Derived_Type); 145 146end C390007_0.C390007_1.C390007_2; 147 148 149 --==================================================================-- 150 151 152package body C390007_0.C390007_1.C390007_2 is 153 154 procedure Outer_Proc (X : in out Param_Derived_Type) is 155 Y : Root_Type'Class := X; 156 begin 157 Inner_Proc (Y); -- Redispatch. 158 Root_Type'Class (X) := Y; 159 end Outer_Proc; 160 161 procedure Inner_Proc (X : in out Param_Derived_Type) is 162 begin 163 X.Last_Call := Derived_Inner; 164 end Inner_Proc; 165 166end C390007_0.C390007_1.C390007_2; 167 168 169 --==================================================================-- 170 171 172package C390007_0.C390007_3 is 173 174 type Convert_Parent_Type is new Root_Type with record 175 First_Call : Call_ID_Kind := None; 176 Second_Call : Call_ID_Kind := None; 177 end record; 178 179 procedure Outer_Proc (X : in out Convert_Parent_Type); 180 procedure Inner_Proc (X : in out Convert_Parent_Type); 181 182end C390007_0.C390007_3; 183 184 185 --==================================================================-- 186 187 188package body C390007_0.C390007_3 is 189 190 procedure Outer_Proc (X : in out Convert_Parent_Type) is 191 begin 192 X.First_Call := Parent_Outer; 193 Inner_Proc (Root_Type'Class(X)); -- Redispatch. 194 end Outer_Proc; 195 196 procedure Inner_Proc (X : in out Convert_Parent_Type) is 197 begin 198 X.Second_Call := Parent_Inner; 199 end Inner_Proc; 200 201end C390007_0.C390007_3; 202 203 204 --==================================================================-- 205 206 207package C390007_0.C390007_3.C390007_4 is 208 209 type Convert_Derived_Type is new Convert_Parent_Type with null record; 210 211 procedure Outer_Proc (X : in out Convert_Derived_Type); 212 procedure Inner_Proc (X : in out Convert_Derived_Type); 213 214end C390007_0.C390007_3.C390007_4; 215 216 217 --==================================================================-- 218 219 220package body C390007_0.C390007_3.C390007_4 is 221 222 procedure Outer_Proc (X : in out Convert_Derived_Type) is 223 begin 224 X.First_Call := Derived_Outer; 225 Inner_Proc (Root_Type'Class(X)); -- Redispatch. 226 end Outer_Proc; 227 228 procedure Inner_Proc (X : in out Convert_Derived_Type) is 229 begin 230 X.Second_Call := Derived_Inner; 231 end Inner_Proc; 232 233end C390007_0.C390007_3.C390007_4; 234 235 236 --==================================================================-- 237 238 239with C390007_0.C390007_1.C390007_2; 240with C390007_0.C390007_3.C390007_4; 241use C390007_0; 242 243with Report; 244procedure C390007 is 245begin 246 Report.Test ("C390007", "Check that the tag of an object of a tagged " & 247 "type is preserved by type conversion and parameter passing"); 248 249 250 -- 251 -- Check that tags are preserved by parameter passing: 252 -- 253 254 Parameter_Passing_Subtest: 255 declare 256 Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; 257 Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; 258 259 ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A; 260 ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B; 261 262 use C390007_0.C390007_1; 263 use C390007_0.C390007_1.C390007_2; 264 begin 265 266 Outer_Proc (Specific_A); 267 if Specific_A.Last_Call /= Derived_Inner then 268 Report.Failed ("Parameter passing: tag not preserved in call to " & 269 "primitive operation with specific operand"); 270 end if; 271 272 C390007_0.ClassWide_Proc (Specific_B); 273 if Specific_B.Last_Call /= Derived_Inner then 274 Report.Failed ("Parameter passing: tag not preserved in call to " & 275 "class-wide operation with specific operand"); 276 end if; 277 278 Outer_Proc (ClassWide_A); 279 if ClassWide_A.Last_Call /= Derived_Inner then 280 Report.Failed ("Parameter passing: tag not preserved in call to " & 281 "primitive operation with class-wide operand"); 282 end if; 283 284 C390007_0.ClassWide_Proc (ClassWide_B); 285 if ClassWide_B.Last_Call /= Derived_Inner then 286 Report.Failed ("Parameter passing: tag not preserved in call to " & 287 "class-wide operation with class-wide operand"); 288 end if; 289 290 end Parameter_Passing_Subtest; 291 292 293 -- 294 -- Check that tags are preserved by type conversion: 295 -- 296 297 Type_Conversion_Subtest: 298 declare 299 Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; 300 Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; 301 302 ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class := 303 C390007_0.C390007_3.Convert_Parent_Type(Specific_A); 304 ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class := 305 C390007_0.C390007_3.Convert_Parent_Type(Specific_B); 306 307 use C390007_0.C390007_3; 308 use C390007_0.C390007_3.C390007_4; 309 begin 310 311 Outer_Proc (Convert_Parent_Type(Specific_A)); 312 if (Specific_A.First_Call /= Parent_Outer) or 313 (Specific_A.Second_Call /= Derived_Inner) 314 then 315 Report.Failed ("Type conversion: tag not preserved in call to " & 316 "primitive operation with specific operand"); 317 end if; 318 319 Outer_Proc (ClassWide_A); 320 if (ClassWide_A.First_Call /= Derived_Outer) or 321 (ClassWide_A.Second_Call /= Derived_Inner) 322 then 323 Report.Failed ("Type conversion: tag not preserved in call to " & 324 "primitive operation with class-wide operand"); 325 end if; 326 327 C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B)); 328 if (Specific_B.Second_Call /= Derived_Inner) then 329 Report.Failed ("Type conversion: tag not preserved in call to " & 330 "class-wide operation with specific operand"); 331 end if; 332 333 C390007_0.ClassWide_Proc (ClassWide_B); 334 if (ClassWide_A.Second_Call /= Derived_Inner) then 335 Report.Failed ("Type conversion: tag not preserved in call to " & 336 "class-wide operation with class-wide operand"); 337 end if; 338 339 end Type_Conversion_Subtest; 340 341 342 -- 343 -- Check that tags are preserved by type conversion and parameter passing: 344 -- 345 346 Type_Conversion_And_Parameter_Passing_Subtest: 347 declare 348 Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; 349 Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; 350 351 use C390007_0.C390007_1; 352 use C390007_0.C390007_1.C390007_2; 353 begin 354 355 Outer_Proc (Param_Parent_Type (Specific_A)); 356 if Specific_A.Last_Call /= Parent_Outer then 357 Report.Failed ("Type conversion and parameter passing: tag not " & 358 "preserved in call to primitive operation with " & 359 "specific operand"); 360 end if; 361 362 C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B)); 363 if Specific_B.Last_Call /= Derived_Inner then 364 Report.Failed ("Type conversion and parameter passing: tag not " & 365 "preserved in call to class-wide operation with " & 366 "specific operand"); 367 end if; 368 369 end Type_Conversion_And_Parameter_Passing_Subtest; 370 371 372 Report.Result; 373 374end C390007; 375