1-- C432003.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 type of the ancestor part of an extension aggregate 28-- has discriminants that are not inherited by the type of the aggregate, 29-- and the ancestor part is a subtype mark that denotes a constrained 30-- subtype, Constraint_Error is raised if: 1) any discriminant of the 31-- ancestor has a different value than that specified for a corresponding 32-- discriminant in the derived type definition for some ancestor of the 33-- type of the aggregate, or 2) the value for the discriminant in the 34-- record association list is not the value of the corresponding 35-- discriminant. Check that the components of the value of the 36-- aggregate not given by the record component association list are 37-- initialized by default as for an object of the ancestor type. 38-- 39-- TEST DESCRIPTION: 40-- Consider: 41-- 42-- type T (D1: ...) is tagged ... 43-- 44-- type DT is new T with ... 45-- subtype ST is DT (D1 => 3); -- Constrained subtype. 46-- 47-- type NT1 (D2: ...) is new DT (D1 => D2) with null record; 48-- type NT2 (D2: ...) is new DT (D1 => 6) with null record; 49-- type NT3 is new DT (D1 => 6) with null record; 50-- 51-- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained. 52-- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained. 53-- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2. 54-- 55-- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained. 56-- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained. 57-- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2. 58-- 59-- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained. 60-- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained. 61-- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3. 62-- 63-- In A, B, D, E, G, and H the ancestor part is the name of an 64-- unconstrained subtype, so this rule does not apply. In C, F, and I 65-- the ancestor part (ST) is the name of a constrained subtype of DT, 66-- which is itself a derived type of a discriminated tagged type T. ST 67-- constrains the discriminant of DT (D1) to the value 3; thus, the 68-- type of any extension aggregate for which ST is the ancestor part 69-- must have an ancestor which also constrained D1 to 3. F and I raise 70-- Constraint_Error because NT2 and NT3, respectively, constrain D1 to 71-- 6. C raises Constraint_Error because NT1 constrains D1 to the value 72-- of D2, which is set to 6 in the record component association list of 73-- the aggregate. 74-- 75-- This test verifies each of the three scenarios above: 76-- 77-- (1) Ancestor of type of aggregate constrains discriminant with 78-- new discriminant. 79-- (2) Ancestor of type of aggregate constrains discriminant with 80-- value, and has a new discriminant part. 81-- (3) Ancestor of type of aggregate constrains discriminant with 82-- value, and has no discriminant part. 83-- 84-- Verification is made for cases where the type of the aggregate is 85-- once- and twice-removed from the type of the ancestor part. 86-- 87-- Additionally, a case is included where a new discriminant corresponds 88-- to multiple discriminants of the type of the ancestor part. 89-- 90-- To test the portion of the objective concerning "initialization by 91-- default," the test verifies that, after a successful aggregate 92-- assignment, components not assigned an explicit value by the aggregate 93-- contain the default values for the corresponding components of the 94-- ancestor type. 95-- 96-- 97-- CHANGE HISTORY: 98-- 06 Dec 94 SAIC ACVC 2.0 99-- 15 Dec 94 SAIC Removed discriminant defaults from tagged types. 100-- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint 101-- for component NT_C3.Str2. Added missing component 102-- checks. Removed record component update from 103-- Avoid_Optimization. Fixed incorrect component 104-- checks. 105-- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for 106-- Q case. 107-- 108--! 109 110package C432003_0 is 111 112 Default_String : constant String := "This is a default string"; -- len = 24 113 Another_String : constant String := "Another default string"; -- len = 22 114 115 subtype Length is Natural range 0..255; 116 117 type ROOT (D1 : Length) is tagged 118 record 119 S1 : String (1..D1) := Default_String(1..D1); 120 Acc : Natural := 356; 121 end record; 122 123 procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type 124 -- extensions. 125 126 type Unconstrained_Der is new ROOT with 127 record 128 Str1 : String(1..5) := "abcde"; 129 end record; 130 131 subtype Constrained_Subtype is Unconstrained_Der (D1 => 10); 132 133 type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with 134 record 135 S2 : String(1..D2); -- Inherited discrim. constrained by 136 end record; -- new discriminant. 137 138 type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with 139 record 140 S3 : String(1..D3); -- Inherited discrim. constrained by 141 end record; -- new discriminant. 142 143 144 type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with 145 record 146 S2 : String(1..D2); -- Inherited discrim. constrained by 147 end record; -- explicit value. 148 149 type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with 150 record 151 S3 : String(1..D3); -- Inherited discrim. constrained by 152 end record; -- explicit value. 153 154 type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with 155 record 156 S2 : String(1..D2); 157 end record; 158 159 160 type NT_C1 is new Unconstrained_Der (D1 => 5) with 161 record 162 Str2 : String(1..5); -- Inherited discrim. constrained 163 end record; -- No new value. 164 165 type NT_C2 (D2 : Length) is new NT_C1 with 166 record 167 S2 : String(1..D2); -- Inherited discrim. not further 168 end record; -- constrained, new discriminant. 169 170 type NT_C3 is new Unconstrained_Der(D1 => 10) with 171 record 172 Str2 : String(1..5); 173 end record; 174 175 176 type MULTI_ROOT (D1 : Length; D2 : Length) is tagged 177 record 178 S1 : String (1..D1) := Default_String(1..D1); 179 S2 : String (1..D2) := Another_String(1..D2); 180 end record; 181 182 procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all 183 -- type extensions. 184 185 type Mult_Unconstr_Der is new MULTI_ROOT with 186 record 187 Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints. 188 end record; 189 190 -- Subtypes with constrained discriminants. 191 subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have 192 D2 => 20); -- diff values 193 194 subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have 195 D2 => 15); -- same value 196 197 type Mult_NT_A1 (D3 : Length) is 198 new Mult_Unconstr_Der (D1 => D3, D2 => D3) with 199 record 200 S3 : String(1..D3); -- Both inherited discriminants constrained 201 end record; -- by new discriminant. 202 203end C432003_0; 204 205 206 --=====================================================================-- 207 208 209with Report; 210package body C432003_0 is 211 212 procedure Avoid_Optimization (Rec : in out ROOT) is 213 begin 214 Rec.S1 := Report.Ident_Str(Rec.S1); 215 end Avoid_Optimization; 216 217 procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is 218 begin 219 Rec.S1 := Report.Ident_Str(Rec.S1); 220 end Avoid_Optimization; 221 222end C432003_0; 223 224 225 --=====================================================================-- 226 227 228with C432003_0; 229with Report; 230procedure C432003 is 231begin 232 233 Report.Test("C432003", "Extension aggregates where ancestor part " & 234 "is a subtype mark that denotes a constrained " & 235 "subtype causing Constraint_Error if any " & 236 "discriminant of the ancestor has a different " & 237 "value than that specified for a corresponding " & 238 "discriminant in the derived type definition " & 239 "for some ancestor of the type of the aggregate"); 240 241 Test_Block: 242 declare 243 244 -- Variety of string object declarations. 245 String2 : String(1..2) := Report.Ident_Str("12"); 246 String5 : String(1..5) := Report.Ident_Str("12345"); 247 String8 : String(1..8) := Report.Ident_Str("AbCdEfGh"); 248 String10 : String(1..10) := Report.Ident_Str("1234567890"); 249 String15 : String(1..15) := Report.Ident_Str("123456789012345"); 250 String20 : String(1..20) := Report.Ident_Str("12345678901234567890"); 251 252 begin 253 254 255 begin 256 declare 257 A : C432003_0.NT_A1 := -- OK 258 (C432003_0.ROOT with D2 => 5, 259 Str1 => "cdefg", 260 S2 => String5); 261 begin 262 C432003_0.Avoid_Optimization(A); 263 if A.Acc /= 356 or 264 A.Str1 /= "cdefg" or 265 A.S2 /= String5 or 266 A.D2 /= 5 or 267 A.S1 /= C432003_0.Default_String(1..5) 268 then 269 Report.Failed("Incorrect object values for Object A"); 270 end if; 271 end; 272 exception 273 when Constraint_Error => 274 Report.Failed("Constraint_Error raised for Object A"); 275 end; 276 277 278 begin 279 declare 280 C: C432003_0.NT_A1 := -- OK 281 (C432003_0.Constrained_Subtype with D2 => 10, 282 S2 => String10); 283 begin 284 C432003_0.Avoid_Optimization(C); 285 if C.D2 /= 10 or C.Acc /= 356 or 286 C.Str1 /= "abcde" or C.S2 /= String10 or 287 C.S1 /= C432003_0.Default_String(1..10) 288 then 289 Report.Failed("Incorrect object values for Object C"); 290 end if; 291 end; 292 exception 293 when Constraint_Error => 294 Report.Failed("Constraint_Error raised for Object C"); 295 end; 296 297 298 begin 299 declare 300 D: C432003_0.NT_A1 := -- C_E 301 (C432003_0.Constrained_Subtype with 302 D2 => Report.Ident_Int(5), 303 S2 => String5); 304 begin 305 C432003_0.Avoid_Optimization(D); 306 Report.Failed("Constraint_Error not raised for Object D"); 307 end; 308 exception 309 when Constraint_Error => 310 null; -- Raise of Constraint_Error is expected. 311 end; 312 313 314 begin 315 declare 316 E: C432003_0.NT_A2 := -- OK 317 (C432003_0.Constrained_Subtype with D3 => 10, 318 S2 => String10, 319 S3 => String10); 320 begin 321 C432003_0.Avoid_Optimization(E); 322 if E.D3 /= 10 or E.Acc /= 356 or 323 E.Str1 /= "abcde" or E.S2 /= String10 or 324 E.S3 /= String10 or 325 E.S1 /= C432003_0.Default_String(1..10) 326 then 327 Report.Failed("Incorrect object values for Object E"); 328 end if; 329 end; 330 exception 331 when Constraint_Error => 332 Report.Failed("Constraint_Error raised for Object E"); 333 end; 334 335 336 begin 337 declare 338 F: C432003_0.NT_A2 := -- C_E 339 (C432003_0.Constrained_Subtype with 340 D3 => Report.Ident_Int(5), 341 S2 => String5, 342 S3 => String5); 343 begin 344 C432003_0.Avoid_Optimization(F); 345 Report.Failed("Constraint_Error not raised for Object F"); 346 end; 347 exception 348 when Constraint_Error => 349 null; -- Raise of Constraint_Error is expected. 350 end; 351 352 353 begin 354 declare 355 G: C432003_0.NT_B2 := -- OK 356 (C432003_0.ROOT with D3 => 5, 357 Str1 => "cdefg", 358 S2 => String10, 359 S3 => String5); 360 begin 361 C432003_0.Avoid_Optimization(G); 362 if G.D3 /= 5 or G.Acc /= 356 or 363 G.Str1 /= "cdefg" or G.S2 /= String10 or 364 G.S3 /= String5 or 365 G.S1 /= C432003_0.Default_String(1..5) 366 then 367 Report.Failed("Incorrect object values for Object G"); 368 end if; 369 end; 370 exception 371 when Constraint_Error => 372 Report.Failed("Constraint_Error raised for Object G"); 373 end; 374 375 376 begin 377 declare 378 H: C432003_0.NT_B3 := -- OK 379 (C432003_0.Unconstrained_Der with D2 => 5, 380 S2 => String5); 381 begin 382 C432003_0.Avoid_Optimization(H); 383 if H.D2 /= 5 or H.Acc /= 356 or 384 H.Str1 /= "abcde" or H.S2 /= String5 or 385 H.S1 /= C432003_0.Default_String(1..10) 386 then 387 Report.Failed("Incorrect object values for Object H"); 388 end if; 389 end; 390 exception 391 when Constraint_Error => 392 Report.Failed("Constraint_Error raised for Object H"); 393 end; 394 395 396 begin 397 declare 398 I: C432003_0.NT_B1 := -- C_E 399 (C432003_0.Constrained_Subtype with 400 D2 => Report.Ident_Int(10), 401 S2 => String10); 402 begin 403 C432003_0.Avoid_Optimization(I); 404 Report.Failed("Constraint_Error not raised for Object I"); 405 end; 406 exception 407 when Constraint_Error => 408 null; -- Raise of Constraint_Error is expected. 409 end; 410 411 412 begin 413 declare 414 J: C432003_0.NT_B2 := -- C_E 415 (C432003_0.Constrained_Subtype with 416 D3 => Report.Ident_Int(10), 417 S2 => String10, 418 S3 => String10); 419 begin 420 C432003_0.Avoid_Optimization(J); 421 Report.Failed("Constraint_Error not raised by Object J"); 422 end; 423 exception 424 when Constraint_Error => 425 null; -- Raise of Constraint_Error is expected. 426 end; 427 428 429 begin 430 declare 431 K: C432003_0.NT_B3 := -- OK 432 (C432003_0.Constrained_Subtype with D2 => 5, 433 S2 => String5); 434 begin 435 C432003_0.Avoid_Optimization(K); 436 if K.D2 /= 5 or K.Acc /= 356 or 437 K.Str1 /= "abcde" or K.S2 /= String5 or 438 K.S1 /= C432003_0.Default_String(1..10) 439 then 440 Report.Failed("Incorrect object values for Object K"); 441 end if; 442 end; 443 exception 444 when Constraint_Error => 445 Report.Failed("Constraint_Error raised for Object K"); 446 end; 447 448 449 begin 450 declare 451 M: C432003_0.NT_C2 := -- OK 452 (C432003_0.ROOT with D2 => 10, 453 Str1 => "cdefg", 454 Str2 => String5, 455 S2 => String10); 456 begin 457 C432003_0.Avoid_Optimization(M); 458 if M.D2 /= 10 or M.Acc /= 356 or 459 M.Str1 /= "cdefg" or M.S2 /= String10 or 460 M.Str2 /= String5 or 461 M.S1 /= C432003_0.Default_String(1..5) 462 then 463 Report.Failed("Incorrect object values for Object M"); 464 end if; 465 end; 466 exception 467 when Constraint_Error => 468 Report.Failed("Constraint_Error raised for Object M"); 469 end; 470 471 472 begin 473 declare 474 O: C432003_0.NT_C1 := -- C_E 475 (C432003_0.Constrained_Subtype with 476 Str2 => Report.Ident_Str(String5)); 477 begin 478 C432003_0.Avoid_Optimization(O); 479 Report.Failed("Constraint_Error not raised for Object O"); 480 end; 481 exception 482 when Constraint_Error => 483 null; -- Raise of Constraint_Error is expected. 484 end; 485 486 487 begin 488 declare 489 P: C432003_0.NT_C2 := -- C_E 490 (C432003_0.Constrained_Subtype with 491 D2 => Report.Ident_Int(10), 492 Str2 => String5, 493 S2 => String10); 494 begin 495 C432003_0.Avoid_Optimization(P); 496 Report.Failed("Constraint_Error not raised by Object P"); 497 end; 498 exception 499 when Constraint_Error => 500 null; -- Raise of Constraint_Error is expected. 501 end; 502 503 504 begin 505 declare 506 Q: C432003_0.NT_C3 := 507 (C432003_0.Constrained_Subtype with Str2 => String5); -- OK 508 begin 509 C432003_0.Avoid_Optimization(Q); 510 if Q.Str2 /= String5 or 511 Q.Acc /= 356 or 512 Q.Str1 /= "abcde" or 513 Q.D1 /= 10 or 514 Q.S1 /= C432003_0.Default_String(1..10) 515 then 516 Report.Failed("Incorrect object values for Object Q"); 517 end if; 518 end; 519 exception 520 when Constraint_Error => 521 Report.Failed("Constraint_Error raised for Object Q"); 522 end; 523 524 525 -- The following cases test where a new discriminant corresponds 526 -- to multiple discriminants of the type of the ancestor part. 527 528 begin 529 declare 530 S: C432003_0.Mult_NT_A1 := -- OK 531 (C432003_0.Mult_Unconstr_Der with D3 => 15, 532 S3 => String15); 533 begin 534 C432003_0.Avoid_Optimization(S); 535 if S.S1 /= C432003_0.Default_String(1..15) or 536 S.Str1 /= String8 or 537 S.S2 /= C432003_0.Another_String(1..15) or 538 S.S3 /= String15 or 539 S.D3 /= 15 540 then 541 Report.Failed("Incorrect object values for Object S"); 542 end if; 543 end; 544 exception 545 when Constraint_Error => 546 Report.Failed("Constraint_Error raised for Object S"); 547 end; 548 549 550 begin 551 declare 552 U: C432003_0.Mult_NT_A1 := -- C_E 553 (C432003_0.Mult_Constr_Sub1 with 554 D3 => Report.Ident_Int(15), 555 S3 => String15); 556 begin 557 C432003_0.Avoid_Optimization(U); 558 Report.Failed("Constraint_Error not raised for Object U"); 559 end; 560 exception 561 when Constraint_Error => 562 null; -- Raise of Constraint_Error is expected. 563 end; 564 565 566 begin 567 declare 568 V: C432003_0.Mult_NT_A1 := -- OK 569 (C432003_0.Mult_Constr_Sub2 with D3 => 15, 570 S3 => String15); 571 begin 572 C432003_0.Avoid_Optimization(V); 573 if V.D3 /= 15 or 574 V.Str1 /= String8 or 575 V.S3 /= String15 or 576 V.S1 /= C432003_0.Default_String(1..15) or 577 V.S2 /= C432003_0.Another_String(1..15) 578 then 579 Report.Failed("Incorrect object values for Object V"); 580 end if; 581 end; 582 exception 583 when Constraint_Error => 584 Report.Failed("Constraint_Error raised for Object V"); 585 end; 586 587 588 exception 589 when others => Report.Failed("Exception raised in Test_Block"); 590 end Test_Block; 591 592 Report.Result; 593 594end C432003; 595