1-- C540001.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 an expression in a case statement may be of a generic formal 28-- type. Check that a function call may be used as a case statement 29-- expression. Check that a call to a generic formal function may be 30-- used as a case statement expression. Check that a call to an inherited 31-- function may be used as a case statement expression even if its result 32-- type does not correspond to any nameable subtype. 33-- 34-- TEST DESCRIPTION: 35-- This transition test creates examples where expressions in a case 36-- statement can be a generic formal object and a call to a generic formal 37-- function. This test also creates examples when either a function call, 38-- a renaming of a function, or a call to an inherited function is used 39-- in the case expressions, the choices of the case statement only need 40-- to cover the values in the result of the function. 41-- 42-- Inspired by B54A08A.ADA. 43-- 44-- 45-- CHANGE HISTORY: 46-- 12 Feb 96 SAIC Initial version for ACVC 2.1. 47-- 48--! 49 50package C540001_0 is 51 type Int is range 1 .. 2; 52 53end C540001_0; 54 55 --==================================================================-- 56 57with C540001_0; 58package C540001_1 is 59 type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3. 60 type Mixed is ('A','B', 'C', None); 61 subtype Small_Num is Natural range 0 .. 10; 62 type Small_Int is range 1 .. 2; 63 function Get_Small_Int (P : Boolean) return Small_Int; 64 procedure Assign_Mixed (P1 : in Boolean; 65 P2 : out Mixed); 66 67 type Tagged_Type is tagged 68 record 69 C1 : Enum_Type; 70 end record; 71 function Get_Tagged (P : Tagged_Type) return C540001_0.Int; 72 73end C540001_1; 74 75 --==================================================================-- 76 77package body C540001_1 is 78 function Get_Small_Int (P : Boolean) return Small_Int is 79 begin 80 if P then 81 return Small_Int'First; 82 else 83 return Small_Int'Last; 84 end if; 85 end Get_Small_Int; 86 87 --------------------------------------------------------------------- 88 procedure Assign_Mixed (P1 : in Boolean; 89 P2 : out Mixed) is 90 begin 91 case Get_Small_Int (P1) is -- Function call as expression 92 when 1 => P2 := None; -- in case statement. 93 when 2 => P2 := 'A'; 94 -- No others needed. 95 end case; 96 97 end Assign_Mixed; 98 99 --------------------------------------------------------------------- 100 function Get_Tagged (P : Tagged_Type) return C540001_0.Int is 101 begin 102 return C540001_0.Int'Last; 103 end Get_Tagged; 104 105end C540001_1; 106 107 --==================================================================-- 108 109generic 110 111 type Formal_Scalar is range <>; 112 113 FSO : Formal_Scalar; 114 115package C540001_2 is 116 117 type Enum is (Alpha, Beta, Theta); 118 119 procedure Assign_Enum (ET : out Enum); 120 121end C540001_2; 122 123 --==================================================================-- 124 125package body C540001_2 is 126 127 procedure Assign_Enum (ET : out Enum) is 128 begin 129 case FSO is -- Type of expression in case 130 when 1 => ET := Alpha; -- statement is generic formal type. 131 when 2 => ET := Beta; 132 when others => ET := Theta; 133 end case; 134 135 end Assign_Enum; 136 137end C540001_2; 138 139 --==================================================================-- 140 141with C540001_1; 142generic 143 144 type Formal_Enum_Type is new C540001_1.Enum_Type; 145 146 with function Formal_Func (P : C540001_1.Small_Num) 147 return Formal_Enum_Type is <>; 148 149function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type; 150 151 --==================================================================-- 152 153function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is 154 155begin 156 return Formal_Func (P); 157end C540001_3; 158 159 --==================================================================-- 160 161with C540001_1; 162generic 163 164 type Formal_Int_Type is new C540001_1.Small_Int; 165 166 with function Formal_Func return Formal_Int_Type; 167 168package C540001_4 is 169 170 procedure Gen_Assign_Mixed (P : out C540001_1.Mixed); 171 172end C540001_4; 173 174 --==================================================================-- 175 176package body C540001_4 is 177 178 procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is 179 begin 180 case Formal_Func is -- Case expression is 181 when 1 => P := C540001_1.'A'; -- generic function. 182 when others => P := C540001_1.'B'; 183 end case; 184 185 end Gen_Assign_Mixed; 186 187end C540001_4; 188 189 --==================================================================-- 190 191with C540001_1; 192package C540001_5 is 193 type New_Tagged is new C540001_1.Tagged_Type with 194 record 195 C2 : C540001_1.Mixed; 196 end record; 197 198 -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int; 199 -- Note that the return type of the inherited function is not 200 -- nameable here. 201 202 procedure Assign_Tagged (P1 : in New_Tagged; 203 P2 : out New_Tagged); 204 205end C540001_5; 206 207 --==================================================================-- 208 209package body C540001_5 is 210 211 procedure Assign_Tagged (P1 : in New_Tagged; 212 P2 : out New_Tagged) is 213 begin 214 case Get_Tagged (P1) is -- Case expression is 215 -- inherited function. 216 when 2 => P2 := (C540001_1.Bee, 'B'); 217 when others => P2 := (C540001_1.Sea, C540001_1.None); 218 end case; 219 220 end Assign_Tagged; 221 222end C540001_5; 223 224 --==================================================================-- 225 226with Report; 227with C540001_1; 228with C540001_2; 229with C540001_3; 230with C540001_4; 231with C540001_5; 232 233procedure C540001 is 234 type Value is range 1 .. 5; 235 236begin 237 Report.Test ("C540001", "Check that an expression in a case statement " & 238 "may be of a generic formal type. Check that a function " & 239 "call may be used as a case statement expression. Check " & 240 "that a call to a generic formal function may be used as " & 241 "a case statement expression. Check that a call to an " & 242 "inherited function may be used as a case statement " & 243 "expression"); 244 245 Generic_Formal_Object_Subtest: 246 begin 247 declare 248 One : Value := 1; 249 package One_Pck is new C540001_2 (Value, One); 250 use One_Pck; 251 EObj : Enum; 252 begin 253 Assign_Enum (EObj); 254 if EObj /= Alpha then 255 Report.Failed ("Incorrect result for value of one in generic" & 256 "formal object subtest"); 257 end if; 258 end; 259 260 declare 261 Five : Value := 5; 262 package Five_Pck is new C540001_2 (Value, Five); 263 use Five_Pck; 264 EObj : Enum; 265 begin 266 Assign_Enum (EObj); 267 if EObj /= Theta then 268 Report.Failed ("Incorrect result for value of five in generic" & 269 "formal object subtest"); 270 end if; 271 end; 272 273 end Generic_Formal_Object_Subtest; 274 275 Instantiated_Generic_Function_Subtest: 276 declare 277 type New_Enum_Type is new C540001_1.Enum_Type; 278 279 function Get_Enum_Value (P : C540001_1.Small_Num) 280 return New_Enum_Type is 281 begin 282 return New_Enum_Type'Val (P); 283 end Get_Enum_Value; 284 285 function Val_Func is new C540001_3 286 (Formal_Enum_Type => New_Enum_Type, 287 Formal_Func => Get_Enum_Value); 288 289 procedure Assign_Num (P : in out C540001_1.Small_Num) is 290 begin 291 case Val_Func (P) is -- Case expression is 292 -- instantiated generic 293 when New_Enum_Type (C540001_1.Eh) | -- function. 294 New_Enum_Type (C540001_1.Sea) => P := 4; 295 when New_Enum_Type (C540001_1.Bee) => P := 7; 296 when others => P := 9; 297 end case; 298 299 end Assign_Num; 300 301 SNObj : C540001_1.Small_Num; 302 303 begin 304 SNObj := 0; 305 Assign_Num (SNObj); 306 if SNObj /= 4 then 307 Report.Failed ("Incorrect result for value of zero in call to " & 308 "generic function subtest"); 309 end if; 310 311 SNObj := 3; 312 Assign_Num (SNObj); 313 if SNObj /= 9 then 314 Report.Failed ("Incorrect result for value of three in call to " & 315 "generic function subtest"); 316 end if; 317 318 end Instantiated_Generic_Function_Subtest; 319 320 -- When a function call, a renaming of a function, or a call to an 321 -- inherited function is used in the case expressions, the choices 322 -- of the case statement only need to cover the values in the result 323 -- of the function. 324 325 Function_Call_Subtest: 326 declare 327 MObj : C540001_1.Mixed := 'B'; 328 BObj : Boolean := True; 329 use type C540001_1.Mixed; 330 begin 331 C540001_1.Assign_Mixed (BObj, MObj); 332 if MObj /= C540001_1.None then 333 Report.Failed ("Incorrect result for value of true in function" & 334 "call subtest"); 335 end if; 336 337 BObj := False; 338 C540001_1.Assign_Mixed (BObj, MObj); 339 if MObj /= C540001_1.'A' then 340 Report.Failed ("Incorrect result for value of false in function" & 341 "call subtest"); 342 end if; 343 344 end Function_Call_Subtest; 345 346 Function_Renaming_Subtest: 347 declare 348 use C540001_1; 349 function Rename_Get_Small_Int (P : Boolean) 350 return Small_Int renames Get_Small_Int; 351 MObj : Mixed := None; 352 BObj : Boolean := False; 353 begin 354 case Rename_Get_Small_Int (BObj) is 355 when 1 => MObj := 'A'; 356 when 2 => MObj := 'B'; 357 -- No others needed. 358 end case; 359 360 if MObj /= 'B' then 361 Report.Failed ("Incorrect result for value of false in function" & 362 "renaming subtest"); 363 end if; 364 365 end Function_Renaming_Subtest; 366 367 Call_To_Generic_Formal_Function_Subtest: 368 declare 369 type New_Small_Int is new C540001_1.Small_Int; 370 371 function Get_Int_Value return New_Small_Int is 372 begin 373 return New_Small_Int'First; 374 end Get_Int_Value; 375 376 package Int_Pck is new C540001_4 377 (Formal_Int_Type => New_Small_Int, 378 Formal_Func => Get_Int_Value); 379 380 use type C540001_1.Mixed; 381 MObj : C540001_1.Mixed := C540001_1.None; 382 383 begin 384 Int_Pck.Gen_Assign_Mixed (MObj); 385 if MObj /= C540001_1.'A' then 386 Report.Failed ("Incorrect result in call to generic formal " & 387 "function subtest"); 388 end if; 389 390 end Call_To_Generic_Formal_Function_Subtest; 391 392 Call_To_Inherited_Function_Subtest: 393 declare 394 NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh, 395 C2 => C540001_1.'A'); 396 NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C'); 397 use type C540001_1.Mixed; 398 use type C540001_1.Enum_Type; 399 begin 400 C540001_5.Assign_Tagged (NTObj1, NTObj2); 401 if NTObj2.C1 /= C540001_1.Bee or 402 NTObj2.C2 /= C540001_1.'B' then 403 Report.Failed ("Incorrect result in inherited function subtest"); 404 end if; 405 406 end Call_To_Inherited_Function_Subtest; 407 408 Report.Result; 409 410end C540001; 411