gcc/testsuite/ada/acats/tests/c4/c432002.a

   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
  91 package 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
 187 end C432002_0;
 188
 189 with Report;
 190 package 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
 204 end C432002_0;
 205
 206
 207 with C432002_0;
 208 with Report;
 209 procedure 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
 219 begin
 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
 764 end C432002;