1-- C432002.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 an extension aggregate specifies a value for a record 28-- extension and the ancestor expression has discriminants that are 29-- inherited by the record extension, then a check is made that each 30-- discriminant has the value specified. 31-- 32-- Check that if an extension aggregate specifies a value for a record 33-- extension and the ancestor expression has discriminants that are not 34-- inherited by the record extension, then a check is made that each 35-- such discriminant has the value specified for the corresponding 36-- discriminant. 37-- 38-- Check that the corresponding discriminant value may be specified 39-- in the record component association list or in the derived type 40-- definition for an ancestor. 41-- 42-- Check the case of ancestors that are several generations removed. 43-- Check the case where the value of the discriminant(s) in question 44-- is supplied several generations removed. 45-- 46-- Check the case of multiple discriminants. 47-- 48-- Check that Constraint_Error is raised if the check fails. 49-- 50-- TEST DESCRIPTION: 51-- A hierarchy of tagged types is declared from a discriminated 52-- root type. Each level declares two kinds of types: (1) a type 53-- extension which constrains the discriminant of its parent to 54-- the value of an expression and (2) a type extension that 55-- constrains the discriminant of its parent to equal a new discriminant 56-- of the type extension (These are the two categories of noninherited 57-- discriminants). 58-- 59-- Values for each type are declared within nested blocks. This is 60-- done so that the instances that produce Constraint_Error may 61-- be dealt with cleanly without forcing the program to exit. 62-- 63-- Success and failure cases (which should raise Constraint_Error) 64-- are set up for each kind of type. Additionally, for the first 65-- level of the hierarchy, separate tests are done for ancestor 66-- expressions specified by aggregates and those specified by 67-- variables. Later tests are performed using variables only. 68-- 69-- Additionally, the cases tested consist of the following kinds of 70-- types: 71-- 72-- Extensions of extensions, using both the parent and grandparent 73-- types for the ancestor expression, 74-- 75-- Ancestor expressions which are several generations removed 76-- from the type of the aggregate, 77-- 78-- Extensions of types with multiple discriminants, where the 79-- extension declares a new discriminant which corresponds to 80-- more than one discriminant of the ancestor types. 81-- 82-- 83-- 84-- CHANGE HISTORY: 85-- 06 Dec 94 SAIC ACVC 2.0 86-- 19 Dec 94 SAIC Removed RM references from objective text. 87-- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants 88-- 89--! 90 91package C432002_0 is 92 93 subtype Length is Natural range 0..256; 94 type Discriminant (L : Length) is tagged 95 record 96 S1 : String (1..L); 97 end record; 98 99 procedure Do_Something (Rec : in out Discriminant); 100 -- inherited by all type extensions 101 102 -- Aggregates of Discriminant are of the form 103 -- (L, S1) where L= S1'Length 104 105 -- Discriminant of parent constrained to value of an expression 106 type Constrained_Discriminant_Extension is 107 new Discriminant (L => 10) 108 with record 109 S2 : String (1..20); 110 end record; 111 112 -- Aggregates of Constrained_Discriminant_Extension are of the form 113 -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20 114 115 type Once_Removed is new Constrained_Discriminant_Extension 116 with record 117 S3 : String (1..3); 118 end record; 119 120 type Twice_Removed is new Once_Removed 121 with record 122 S4 : String (1..8); 123 end record; 124 125 -- Aggregates of Twice_Removed are of the form 126 -- (L, S1, S2, S3, S4), where L = S1'Length = 10, 127 -- S2'Length = 20, 128 -- S3'Length = 3, 129 -- S4'Length = 8 130 131 -- Discriminant of parent constrained to equal new discriminant 132 type New_Discriminant_Extension (N : Length) is 133 new Discriminant (L => N) with 134 record 135 S2 : String (1..N); 136 end record; 137 138 -- Aggregates of New_Discriminant_Extension are of the form 139 -- (N, S1, S2), where N = S1'Length = S2'Length 140 141 -- Discriminant of parent extension constrained to the value of 142 -- an expression 143 type Constrained_Extension_Extension is 144 new New_Discriminant_Extension (N => 20) 145 with record 146 S3 : String (1..5); 147 end record; 148 149 -- Aggregates of Constrained_Extension_Extension are of the form 150 -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20, 151 -- S3'Length = 5 152 153 -- Discriminant of parent extension constrained to equal a new 154 -- discriminant 155 type New_Extension_Extension (I : Length) is 156 new New_Discriminant_Extension (N => I) 157 with record 158 S3 : String (1..I); 159 end record; 160 161 -- Aggregates of New_Extension_Extension are of the form 162 -- (I, S1, 2, S3), where 163 -- I = S1'Length = S2'Length = S3'Length 164 165 type Multiple_Discriminants (A, B : Length) is tagged 166 record 167 S1 : String (1..A); 168 S2 : String (1..B); 169 end record; 170 171 procedure Do_Something (Rec : in out Multiple_Discriminants); 172 -- inherited by type extension 173 174 -- Aggregates of Multiple_Discriminants are of the form 175 -- (A, B, S1, S2), where A = S1'Length, B = S2'Length 176 177 type Multiple_Discriminant_Extension (C : Length) is 178 new Multiple_Discriminants (A => C, B => C) 179 with record 180 S3 : String (1..C); 181 end record; 182 183 -- Aggregates of Multiple_Discriminant_Extension are of the form 184 -- (A, B, S1, S2, C, S3), where 185 -- A = B = C = S1'Length = S2'Length = S3'Length 186 187end C432002_0; 188 189with Report; 190package body C432002_0 is 191 192 S : String (1..20) := "12345678901234567890"; 193 194 procedure Do_Something (Rec : in out Discriminant) is 195 begin 196 Rec.S1 := Report.Ident_Str (S (1..Rec.L)); 197 end Do_Something; 198 199 procedure Do_Something (Rec : in out Multiple_Discriminants) is 200 begin 201 Rec.S1 := Report.Ident_Str (S (1..Rec.A)); 202 end Do_Something; 203 204end C432002_0; 205 206 207with C432002_0; 208with Report; 209procedure C432002 is 210 211 -- Various different-sized strings for variety 212 String_3 : String (1..3) := Report.Ident_Str("123"); 213 String_5 : String (1..5) := Report.Ident_Str("12345"); 214 String_8 : String (1..8) := Report.Ident_Str("12345678"); 215 String_10 : String (1..10) := Report.Ident_Str("1234567890"); 216 String_11 : String (1..11) := Report.Ident_Str("12345678901"); 217 String_20 : String (1..20) := Report.Ident_Str("12345678901234567890"); 218 219begin 220 221 Report.Test ("C432002", 222 "Extension aggregates for discriminated types"); 223 224 -------------------------------------------------------------------- 225 -- Extension constrains parent's discriminant to value of expression 226 -------------------------------------------------------------------- 227 228 -- Successful cases - value matches corresponding discriminant value 229 230 CD_Matched_Aggregate: 231 begin 232 declare 233 CD : C432002_0.Constrained_Discriminant_Extension := 234 (C432002_0.Discriminant'(L => 10, 235 S1 => String_10) 236 with S2 => String_20); 237 begin 238 C432002_0.Do_Something(CD); -- success 239 end; 240 exception 241 when Constraint_Error => 242 Report.Comment ("Ancestor expression is an aggregate"); 243 Report.Failed ("Aggregate of extension " & 244 "with discriminant constrained: " & 245 "Constraint_Error was incorrectly raised " & 246 "for value that matches corresponding " & 247 "discriminant"); 248 end CD_Matched_Aggregate; 249 250 CD_Matched_Variable: 251 begin 252 declare 253 D : C432002_0.Discriminant(L => 10) := 254 C432002_0.Discriminant'(L => 10, 255 S1 => String_10); 256 257 CD : C432002_0.Constrained_Discriminant_Extension := 258 (D with S2 => String_20); 259 begin 260 C432002_0.Do_Something(CD); -- success 261 end; 262 exception 263 when Constraint_Error => 264 Report.Comment ("Ancestor expression is a variable"); 265 Report.Failed ("Aggregate of extension " & 266 "with discriminant constrained: " & 267 "Constraint_Error was incorrectly raised " & 268 "for value that matches corresponding " & 269 "discriminant"); 270 end CD_Matched_Variable; 271 272 273 -- Unsuccessful cases - value does not match value of corresponding 274 -- discriminant. Constraint_Error should be 275 -- raised. 276 277 CD_Unmatched_Aggregate: 278 begin 279 declare 280 CD : C432002_0.Constrained_Discriminant_Extension := 281 (C432002_0.Discriminant'(L => 5, 282 S1 => String_5) 283 with S2 => String_20); 284 begin 285 Report.Comment ("Ancestor expression is an aggregate"); 286 Report.Failed ("Aggregate of extension " & 287 "with discriminant constrained: " & 288 "Constraint_Error was not raised " & 289 "for discriminant value that does not match " & 290 "corresponding discriminant"); 291 C432002_0.Do_Something(CD); -- disallow unused var optimization 292 end; 293 exception 294 when Constraint_Error => 295 null; -- raise of Constraint_Error is expected 296 end CD_Unmatched_Aggregate; 297 298 CD_Unmatched_Variable: 299 begin 300 declare 301 D : C432002_0.Discriminant(L => 5) := 302 C432002_0.Discriminant'(L => 5, 303 S1 => String_5); 304 305 CD : C432002_0.Constrained_Discriminant_Extension := 306 (D with S2 => String_20); 307 begin 308 Report.Comment ("Ancestor expression is an variable"); 309 Report.Failed ("Aggregate of extension " & 310 "with discriminant constrained: " & 311 "Constraint_Error was not raised " & 312 "for discriminant value that does not match " & 313 "corresponding discriminant"); 314 C432002_0.Do_Something(CD); -- disallow unused var optimization 315 end; 316 exception 317 when Constraint_Error => 318 null; -- raise of Constraint_Error is expected 319 end CD_Unmatched_Variable; 320 321 ----------------------------------------------------------------------- 322 -- Extension constrains parent's discriminant to equal new discriminant 323 ----------------------------------------------------------------------- 324 325 -- Successful cases - value matches corresponding discriminant value 326 327 ND_Matched_Aggregate: 328 begin 329 declare 330 ND : C432002_0.New_Discriminant_Extension (N => 8) := 331 (C432002_0.Discriminant'(L => 8, 332 S1 => String_8) 333 with N => 8, 334 S2 => String_8); 335 begin 336 C432002_0.Do_Something(ND); -- success 337 end; 338 exception 339 when Constraint_Error => 340 Report.Comment ("Ancestor expression is an aggregate"); 341 Report.Failed ("Aggregate of extension " & 342 "with new discriminant: " & 343 "Constraint_Error was incorrectly raised " & 344 "for value that matches corresponding " & 345 "discriminant"); 346 end ND_Matched_Aggregate; 347 348 ND_Matched_Variable: 349 begin 350 declare 351 D : C432002_0.Discriminant(L => 3) := 352 C432002_0.Discriminant'(L => 3, 353 S1 => String_3); 354 355 ND : C432002_0.New_Discriminant_Extension (N => 3) := 356 (D with N => 3, 357 S2 => String_3); 358 begin 359 C432002_0.Do_Something(ND); -- success 360 end; 361 exception 362 when Constraint_Error => 363 Report.Comment ("Ancestor expression is an variable"); 364 Report.Failed ("Aggregate of extension " & 365 "with new discriminant: " & 366 "Constraint_Error was incorrectly raised " & 367 "for value that matches corresponding " & 368 "discriminant"); 369 end ND_Matched_Variable; 370 371 372 -- Unsuccessful cases - value does not match value of corresponding 373 -- discriminant. Constraint_Error should be 374 -- raised. 375 376 ND_Unmatched_Aggregate: 377 begin 378 declare 379 ND : C432002_0.New_Discriminant_Extension (N => 20) := 380 (C432002_0.Discriminant'(L => 11, 381 S1 => String_11) 382 with N => 20, 383 S2 => String_20); 384 begin 385 Report.Comment ("Ancestor expression is an aggregate"); 386 Report.Failed ("Aggregate of extension " & 387 "with new discriminant: " & 388 "Constraint_Error was not raised " & 389 "for discriminant value that does not match " & 390 "corresponding discriminant"); 391 C432002_0.Do_Something(ND); -- disallow unused var optimization 392 end; 393 exception 394 when Constraint_Error => 395 null; -- raise is expected 396 end ND_Unmatched_Aggregate; 397 398 ND_Unmatched_Variable: 399 begin 400 declare 401 D : C432002_0.Discriminant(L => 5) := 402 C432002_0.Discriminant'(L => 5, 403 S1 => String_5); 404 405 ND : C432002_0.New_Discriminant_Extension (N => 20) := 406 (D with N => 20, 407 S2 => String_20); 408 begin 409 Report.Comment ("Ancestor expression is an variable"); 410 Report.Failed ("Aggregate of extension " & 411 "with new discriminant: " & 412 "Constraint_Error was not raised " & 413 "for discriminant value that does not match " & 414 "corresponding discriminant"); 415 C432002_0.Do_Something(ND); -- disallow unused var optimization 416 end; 417 exception 418 when Constraint_Error => 419 null; -- raise is expected 420 end ND_Unmatched_Variable; 421 422 -------------------------------------------------------------------- 423 -- Extension constrains parent's discriminant to value of expression 424 -- Parent is a discriminant extension 425 -------------------------------------------------------------------- 426 427 -- Successful cases - value matches corresponding discriminant value 428 429 CE_Matched_Aggregate: 430 begin 431 declare 432 CE : C432002_0.Constrained_Extension_Extension := 433 (C432002_0.Discriminant'(L => 20, 434 S1 => String_20) 435 with N => 20, 436 S2 => String_20, 437 S3 => String_5); 438 begin 439 C432002_0.Do_Something(CE); -- success 440 end; 441 exception 442 when Constraint_Error => 443 Report.Comment ("Ancestor expression is an aggregate"); 444 Report.Failed ("Aggregate of extension (of extension) " & 445 "with discriminant constrained: " & 446 "Constraint_Error was incorrectly raised " & 447 "for value that matches corresponding " & 448 "discriminant"); 449 end CE_Matched_Aggregate; 450 451 CE_Matched_Variable: 452 begin 453 declare 454 ND : C432002_0.New_Discriminant_Extension (N => 20) := 455 C432002_0.New_Discriminant_Extension' 456 (N => 20, 457 S1 => String_20, 458 S2 => String_20); 459 460 CE : C432002_0.Constrained_Extension_Extension := 461 (ND with S3 => String_5); 462 begin 463 C432002_0.Do_Something(CE); -- success 464 end; 465 exception 466 when Constraint_Error => 467 Report.Comment ("Ancestor expression is a variable"); 468 Report.Failed ("Aggregate of extension (of extension) " & 469 "with discriminant constrained: " & 470 "Constraint_Error was incorrectly raised " & 471 "for value that matches corresponding " & 472 "discriminant"); 473 end CE_Matched_Variable; 474 475 476 -- Unsuccessful cases - value does not match value of corresponding 477 -- discriminant. Constraint_Error should be 478 -- raised. 479 480 CE_Unmatched_Aggregate: 481 begin 482 declare 483 CE : C432002_0.Constrained_Extension_Extension := 484 (C432002_0.New_Discriminant_Extension' 485 (N => 11, 486 S1 => String_11, 487 S2 => String_11) 488 with S3 => String_5); 489 begin 490 Report.Comment ("Ancestor expression is an aggregate"); 491 Report.Failed ("Aggregate of extension (of extension) " & 492 "Constraint_Error was not raised " & 493 "with discriminant constrained: " & 494 "for discriminant value that does not match " & 495 "corresponding discriminant"); 496 C432002_0.Do_Something(CE); -- disallow unused var optimization 497 end; 498 exception 499 when Constraint_Error => 500 null; -- raise of Constraint_Error is expected 501 end CE_Unmatched_Aggregate; 502 503 CE_Unmatched_Variable: 504 begin 505 declare 506 D : C432002_0.Discriminant(L => 8) := 507 C432002_0.Discriminant'(L => 8, 508 S1 => String_8); 509 510 CE : C432002_0.Constrained_Extension_Extension := 511 (D with N => 8, 512 S2 => String_8, 513 S3 => String_5); 514 begin 515 Report.Comment ("Ancestor expression is a variable"); 516 Report.Failed ("Aggregate of extension (of extension) " & 517 "with discriminant constrained: " & 518 "Constraint_Error was not raised " & 519 "for discriminant value that does not match " & 520 "corresponding discriminant"); 521 C432002_0.Do_Something(CE); -- disallow unused var optimization 522 end; 523 exception 524 when Constraint_Error => 525 null; -- raise of Constraint_Error is expected 526 end CE_Unmatched_Variable; 527 528 ----------------------------------------------------------------------- 529 -- Extension constrains parent's discriminant to equal new discriminant 530 -- Parent is a discriminant extension 531 ----------------------------------------------------------------------- 532 533 -- Successful cases - value matches corresponding discriminant value 534 535 NE_Matched_Aggregate: 536 begin 537 declare 538 NE : C432002_0.New_Extension_Extension (I => 8) := 539 (C432002_0.Discriminant'(L => 8, 540 S1 => String_8) 541 with I => 8, 542 S2 => String_8, 543 S3 => String_8); 544 begin 545 C432002_0.Do_Something(NE); -- success 546 end; 547 exception 548 when Constraint_Error => 549 Report.Comment ("Ancestor expression is an aggregate"); 550 Report.Failed ("Aggregate of extension (of extension) " & 551 "with new discriminant: " & 552 "Constraint_Error was incorrectly raised " & 553 "for value that matches corresponding " & 554 "discriminant"); 555 end NE_Matched_Aggregate; 556 557 NE_Matched_Variable: 558 begin 559 declare 560 ND : C432002_0.New_Discriminant_Extension (N => 3) := 561 C432002_0.New_Discriminant_Extension' 562 (N => 3, 563 S1 => String_3, 564 S2 => String_3); 565 566 NE : C432002_0.New_Extension_Extension (I => 3) := 567 (ND with I => 3, 568 S3 => String_3); 569 begin 570 C432002_0.Do_Something(NE); -- success 571 end; 572 exception 573 when Constraint_Error => 574 Report.Comment ("Ancestor expression is a variable"); 575 Report.Failed ("Aggregate of extension (of extension) " & 576 "with new discriminant: " & 577 "Constraint_Error was incorrectly raised " & 578 "for value that matches corresponding " & 579 "discriminant"); 580 end NE_Matched_Variable; 581 582 583 -- Unsuccessful cases - value does not match value of corresponding 584 -- discriminant. Constraint_Error should be 585 -- raised. 586 587 NE_Unmatched_Aggregate: 588 begin 589 declare 590 NE : C432002_0.New_Extension_Extension (I => 8) := 591 (C432002_0.New_Discriminant_Extension' 592 (C432002_0.Discriminant'(L => 11, 593 S1 => String_11) 594 with N => 11, 595 S2 => String_11) 596 with I => 8, 597 S3 => String_8); 598 begin 599 Report.Comment ("Ancestor expression is an extension aggregate"); 600 Report.Failed ("Aggregate of extension (of extension) " & 601 "with new discriminant: " & 602 "Constraint_Error was not raised " & 603 "for discriminant value that does not match " & 604 "corresponding discriminant"); 605 C432002_0.Do_Something(NE); -- disallow unused var optimization 606 end; 607 exception 608 when Constraint_Error => 609 null; -- raise is expected 610 end NE_Unmatched_Aggregate; 611 612 NE_Unmatched_Variable: 613 begin 614 declare 615 D : C432002_0.Discriminant(L => 5) := 616 C432002_0.Discriminant'(L => 5, 617 S1 => String_5); 618 619 NE : C432002_0.New_Extension_Extension (I => 20) := 620 (D with I => 5, 621 S2 => String_5, 622 S3 => String_20); 623 begin 624 Report.Comment ("Ancestor expression is a variable"); 625 Report.Failed ("Aggregate of extension (of extension) " & 626 "with new discriminant: " & 627 "Constraint_Error was not raised " & 628 "for discriminant value that does not match " & 629 "corresponding discriminant"); 630 C432002_0.Do_Something(NE); -- disallow unused var optimization 631 end; 632 exception 633 when Constraint_Error => 634 null; -- raise is expected 635 end NE_Unmatched_Variable; 636 637 ----------------------------------------------------------------------- 638 -- Corresponding discriminant is two levels deeper than aggregate 639 ----------------------------------------------------------------------- 640 641 -- Successful case - value matches corresponding discriminant value 642 643 TR_Matched_Variable: 644 begin 645 declare 646 D : C432002_0.Discriminant (L => 10) := 647 C432002_0.Discriminant'(L => 10, 648 S1 => String_10); 649 650 TR : C432002_0.Twice_Removed := 651 C432002_0.Twice_Removed'(D with S2 => String_20, 652 S3 => String_3, 653 S4 => String_8); 654 -- N is constrained to a value in the derived_type_definition 655 -- of Constrained_Discriminant_Extension. Its omission from 656 -- the above record_component_association_list is allowed by 657 -- 4.3.2(6). 658 659 begin 660 C432002_0.Do_Something(TR); -- success 661 end; 662 exception 663 when Constraint_Error => 664 Report.Failed ("Aggregate of far-removed extension " & 665 "with discriminant constrained: " & 666 "Constraint_Error was incorrectly raised " & 667 "for value that matches corresponding " & 668 "discriminant"); 669 end TR_Matched_Variable; 670 671 672 -- Unsuccessful case - value does not match value of corresponding 673 -- discriminant. Constraint_Error should be 674 -- raised. 675 676 TR_Unmatched_Variable: 677 begin 678 declare 679 D : C432002_0.Discriminant (L => 5) := 680 C432002_0.Discriminant'(L => 5, 681 S1 => String_5); 682 683 TR : C432002_0.Twice_Removed := 684 C432002_0.Twice_Removed'(D with S2 => String_20, 685 S3 => String_3, 686 S4 => String_8); 687 688 begin 689 Report.Failed ("Aggregate of far-removed extension " & 690 "with discriminant constrained: " & 691 "Constraint_Error was not raised " & 692 "for discriminant value that does not match " & 693 "corresponding discriminant"); 694 C432002_0.Do_Something(TR); -- disallow unused var optimization 695 end; 696 exception 697 when Constraint_Error => 698 null; -- raise is expected 699 end TR_Unmatched_Variable; 700 701 ------------------------------------------------------------------------ 702 -- Parent has multiple discriminants. 703 -- Discriminant in extension corresponds to both parental discriminants. 704 ------------------------------------------------------------------------ 705 706 -- Successful case - value matches corresponding discriminant value 707 708 MD_Matched_Variable: 709 begin 710 declare 711 MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) := 712 C432002_0.Multiple_Discriminants'(A => 10, 713 B => 10, 714 S1 => String_10, 715 S2 => String_10); 716 MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := 717 (MD with C => 10, 718 S3 => String_10); 719 720 begin 721 C432002_0.Do_Something(MDE); -- success 722 end; 723 exception 724 when Constraint_Error => 725 Report.Failed ("Aggregate of extension " & 726 "of multiply-discriminated parent: " & 727 "Constraint_Error was incorrectly raised " & 728 "for value that matches corresponding " & 729 "discriminant"); 730 end MD_Matched_Variable; 731 732 733 -- Unsuccessful case - value does not match value of corresponding 734 -- discriminant. Constraint_Error should be 735 -- raised. 736 737 MD_Unmatched_Variable: 738 begin 739 declare 740 MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) := 741 C432002_0.Multiple_Discriminants'(A => 10, 742 B => 8, 743 S1 => String_10, 744 S2 => String_8); 745 MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := 746 (MD with C => 10, 747 S3 => String_10); 748 749 begin 750 Report.Failed ("Aggregate of extension " & 751 "of multiply-discriminated parent: " & 752 "Constraint_Error was not raised " & 753 "for discriminant value that does not match " & 754 "corresponding discriminant"); 755 C432002_0.Do_Something(MDE); -- disallow unused var optimization 756 end; 757 exception 758 when Constraint_Error => 759 null; -- raise is expected 760 end MD_Unmatched_Variable; 761 762 Report.Result; 763 764end C432002; 765