1-- C3A0014.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 if the view defined by an object declaration is aliased, 28-- and the type of the object has discriminants, then the object is 29-- constrained by its initial value even if its nominal subtype is 30-- unconstrained. 31-- 32-- Check that the attribute A'Constrained returns True if A is a formal 33-- out or in out parameter, or dereference thereof, and A denotes an 34-- aliased view of an object. 35-- 36-- TEST DESCRIPTION: 37-- These rules apply to objects of a record type with defaulted 38-- discriminants, which may be unconstrained variables. If such a 39-- variable is declared to be aliased, then it is constrained by its 40-- initial value, and the value of the discriminant cannot be changed 41-- for the life of the variable. 42-- 43-- The rules do not apply to aliased component types because if such 44-- types are discriminated they must be constrained. 45-- 46-- A'Constrained returns True if A denotes a constant, value, or 47-- constrained variable. Since aliased objects are constrained, it must 48-- return True if the actual parameter corresponding to a formal 49-- parameter A is an aliased object. The objective only mentions formal 50-- parameters of mode out and in out, since parameters of mode in are 51-- by definition constant, and would result in True anyway. 52-- 53-- This test declares aliased objects of a nominally unconstrained 54-- record subtype, both with and without initialization expressions. 55-- It also declares access values which point to such objects. It then 56-- checks that Constraint_Error is raised if an attempt is made to 57-- change the discriminant value of an aliased object, either directly 58-- or via a dereference of an access value. For aliased objects, this 59-- check is also performed for subprogram parameters of mode out. 60-- 61-- The test also passes aliased objects and access values which point 62-- to such objects as actuals to subprograms and verifies, for parameter 63-- modes out and in out, that P'Constrained returns true if P is the 64-- corresponding formal parameter or a dereference thereof. 65-- 66-- Additionally, the test declares a generic package which declares a 67-- an aliased object of a formal derived unconstrained type, which is 68-- is initialized with the value of a formal object of that type. 69-- procedure declared within the generic assigns a value to the object 70-- which has the same discriminant value as the formal derived type's 71-- ancestor type. The generic is instantiated with various actuals 72-- for the formal object, and the procedure is called. The test verifies 73-- that Constraint_Error is raised if the discriminant values of the 74-- actual corresponding to the formal object and the value assigned 75-- by the procedure are not equal. 76-- 77-- 78-- CHANGE HISTORY: 79-- 06 Dec 94 SAIC ACVC 2.0 80-- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors. 81-- 82--! 83 84package C3A0014_0 is 85 86 subtype Reasonable is Integer range 1..10; 87 -- Unconstrained (sub)type. 88 type UC (D: Reasonable := 2) is record -- Discriminant default. 89 S: String (1 .. D) := "Hi"; -- Default value. 90 end record; 91 92 type AUC is access all UC; 93 94 -- Nominal subtype is unconstrained for the following: 95 96 Obj0 : UC; -- An unconstrained object. 97 98 Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization, 99 -- an unconstrained object. 100 101 Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization, 102 -- a constrained object. 103 104 Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view), 105 -- a constrained object. 106 Obj4 : aliased UC; -- Aliased without initialization, Obj4 107 -- constrained here to initial value 108 -- taken from default for type. 109 110 Ptr1 : AUC := new UC'(Obj1); 111 Ptr2 : AUC := new UC; 112 Ptr3 : AUC := Obj3'Access; 113 Ptr4 : AUC := Obj4'Access; 114 115 116 procedure NP_Proc (A: out UC); 117 procedure NP_Cons (A: in out UC; B: out Boolean); 118 procedure P_Cons (A: out AUC; B: out Boolean); 119 120 121 generic 122 type FT is new UC; 123 FObj : in out FT; 124 package Gen is 125 F : aliased FT := FObj; -- Constrained if FT has discriminants. 126 procedure Proc; 127 end Gen; 128 129 130 procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ); 131 132 133end C3A0014_0; 134 135 136 --=======================================================================-- 137 138with Report; 139 140package body C3A0014_0 is 141 142 procedure NP_Proc (A: out UC) is 143 begin 144 A := (3, "Bye"); 145 end NP_Proc; 146 147 procedure NP_Cons (A: in out UC; B: out Boolean) is 148 begin 149 B := A'Constrained; 150 end NP_Cons; 151 152 procedure P_Cons (A: out AUC; B: out Boolean) is 153 begin 154 B := A.all'Constrained; 155 end P_Cons; 156 157 158 package body Gen is 159 160 procedure Proc is 161 begin 162 F := (2, "Fi"); 163 end Proc; 164 165 end Gen; 166 167 168 procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is 169 Default : UC := (1, "!"); -- Unique value. 170 begin 171 if P = Default then -- Both If branches can't do the same thing. 172 Report.Failed (Msg & ": Constraint_Error not raised"); 173 else -- Subtests should always select this path. 174 Report.Failed ("Constraint_Error not raised " & Msg); 175 end if; 176 end Avoid_Optimization_and_Fail; 177 178 179end C3A0014_0; 180 181 182 --=======================================================================-- 183 184 185with C3A0014_0; use C3A0014_0; 186with Report; 187 188procedure C3A0014 is 189begin 190 191 Report.Test("C3A0014", "Check that if the view defined by an object " & 192 "declaration is aliased, and the type of the " & 193 "object has discriminants, then the object is " & 194 "constrained by its initial value even if its " & 195 "nominal subtype is unconstrained. Check that " & 196 "the attribute A'Constrained returns True if A " & 197 "is a formal out or in out parameter, or " & 198 "dereference thereof, and A denotes an aliased " & 199 "view of an object"); 200 201 Non_Pointer_Block: 202 begin 203 204 begin 205 Obj0 := (3, "Bye"); -- OK: Obj0 not constrained. 206 if Obj0 /= (3, "Bye") then 207 Report.Failed 208 ("Wrong value after aggregate assignment - Subtest 1"); 209 end if; 210 exception 211 when others => 212 Report.Failed ("Unexpected exception raised - Subtest 1"); 213 end; 214 215 216 begin 217 Obj1 := (3, "Bye"); -- OK: Obj1 not constrained. 218 if Obj1 /= (3, "Bye") then 219 Report.Failed 220 ("Wrong value after aggregate assignment - Subtest 2"); 221 end if; 222 exception 223 when others => 224 Report.Failed ("Unexpected exception raised - Subtest 2"); 225 end; 226 227 228 begin 229 Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5). 230 Avoid_Optimization_and_Fail (Obj2, "Subtest 3"); 231 exception 232 when Constraint_Error => null; -- Exception is expected. 233 end; 234 235 236 begin 237 Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5). 238 Avoid_Optimization_and_Fail (Obj3, "Subtest 4"); 239 exception 240 when Constraint_Error => null; -- Exception is expected. 241 end; 242 243 244 begin 245 Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2). 246 Avoid_Optimization_and_Fail (Obj4, "Subtest 5"); 247 exception 248 when Constraint_Error => null; -- Exception is expected. 249 end; 250 251 exception 252 when others => Report.Failed("Unexpected exception: Non_Pointer_Block"); 253 end Non_Pointer_Block; 254 255 256 Pointer_Block: 257 begin 258 259 begin 260 Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5). 261 Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6"); 262 exception 263 when Constraint_Error => null; -- Exception is expected. 264 end; 265 266 267 begin 268 Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2). 269 Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7"); 270 exception 271 when Constraint_Error => null; -- Exception is expected. 272 end; 273 274 275 begin 276 Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5). 277 Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8"); 278 exception 279 when Constraint_Error => null; -- Exception is expected. 280 end; 281 282 283 begin 284 Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2). 285 Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9"); 286 exception 287 when Constraint_Error => null; -- Exception is expected. 288 end; 289 290 exception 291 when others => Report.Failed("Unexpected exception: Pointer_Block"); 292 end Pointer_Block; 293 294 295 Subprogram_Block: 296 declare 297 Is_Constrained : Boolean; 298 begin 299 300 begin 301 NP_Proc (Obj0); -- OK: Obj0 not constrained, can 302 if Obj0 /= (3, "Bye") then -- change discriminant value. 303 Report.Failed 304 ("Wrong value after aggregate assignment - Subtest 10"); 305 end if; 306 exception 307 when others => 308 Report.Failed ("Unexpected exception raised - Subtest 10"); 309 end; 310 311 312 begin 313 NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5). 314 Avoid_Optimization_and_Fail (Obj2, "Subtest 11"); 315 exception 316 when Constraint_Error => null; -- Exception is expected. 317 end; 318 319 320 begin 321 NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5). 322 Avoid_Optimization_and_Fail (Obj3, "Subtest 12"); 323 exception 324 when Constraint_Error => null; -- Exception is expected. 325 end; 326 327 328 begin 329 NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2). 330 Avoid_Optimization_and_Fail (Obj4, "Subtest 13"); 331 exception 332 when Constraint_Error => null; -- Exception is expected. 333 end; 334 335 336 337 begin 338 Is_Constrained := True; 339 NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1 340 if Is_Constrained then -- is not constrained. 341 Report.Failed ("Wrong result from 'Constrained - Subtest 14"); 342 end if; 343 exception 344 when others => 345 Report.Failed ("Unexpected exception raised - Subtest 14"); 346 end; 347 348 349 begin 350 Is_Constrained := False; 351 NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is 352 if not Is_Constrained then -- constrained. 353 Report.Failed ("Wrong result from 'Constrained - Subtest 15"); 354 end if; 355 exception 356 when others => 357 Report.Failed ("Unexpected exception raised - Subtest 15"); 358 end; 359 360 361 362 363 begin 364 Is_Constrained := False; 365 P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all 366 if not Is_Constrained then -- is constrained. 367 Report.Failed ("Wrong result from 'Constrained - Subtest 16"); 368 end if; 369 exception 370 when others => 371 Report.Failed ("Unexpected exception raised - Subtest 16"); 372 end; 373 374 375 begin 376 Is_Constrained := False; 377 P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all 378 if not Is_Constrained then -- is constrained. 379 Report.Failed ("Wrong result from 'Constrained - Subtest 17"); 380 end if; 381 exception 382 when others => 383 Report.Failed ("Unexpected exception raised - Subtest 17"); 384 end; 385 386 387 exception 388 when others => Report.Failed("Exception raised in Subprogram_Block"); 389 end Subprogram_Block; 390 391 392 Generic_Block: 393 declare 394 395 type NUC is new UC; 396 397 Obj : NUC; 398 399 400 package Instance_A is new Gen (NUC, Obj); 401 package Instance_B is new Gen (UC, Obj2); 402 package Instance_C is new Gen (UC, Obj3); 403 package Instance_D is new Gen (UC, Obj4); 404 405 begin 406 407 begin 408 Instance_A.Proc; -- OK: Obj.D = 2. 409 if Instance_A.F /= (2, "Fi") then 410 Report.Failed 411 ("Wrong value after aggregate assignment - Subtest 18"); 412 end if; 413 exception 414 when others => 415 Report.Failed ("Unexpected exception raised - Subtest 18"); 416 end; 417 418 419 begin 420 Instance_B.Proc; -- C_E: Obj2.D = 5. 421 Avoid_Optimization_and_Fail (Obj2, "Subtest 19"); 422 exception 423 when Constraint_Error => null; -- Exception is expected. 424 end; 425 426 427 begin 428 Instance_C.Proc; -- C_E: Obj3.D = 5. 429 Avoid_Optimization_and_Fail (Obj3, "Subtest 20"); 430 exception 431 when Constraint_Error => null; -- Exception is expected. 432 end; 433 434 435 begin 436 Instance_D.Proc; -- OK: Obj4.D = 2. 437 if Instance_D.F /= (2, "Fi") then 438 Report.Failed 439 ("Wrong value after aggregate assignment - Subtest 21"); 440 end if; 441 exception 442 when others => 443 Report.Failed ("Unexpected exception raised - Subtest 21"); 444 end; 445 446 exception 447 when others => Report.Failed("Exception raised in Generic_Block"); 448 end Generic_Block; 449 450 451 Report.Result; 452 453end C3A0014; 454