| -- C432002.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that if an extension aggregate specifies a value for a record |
| -- extension and the ancestor expression has discriminants that are |
| -- inherited by the record extension, then a check is made that each |
| -- discriminant has the value specified. |
| -- |
| -- Check that if an extension aggregate specifies a value for a record |
| -- extension and the ancestor expression has discriminants that are not |
| -- inherited by the record extension, then a check is made that each |
| -- such discriminant has the value specified for the corresponding |
| -- discriminant. |
| -- |
| -- Check that the corresponding discriminant value may be specified |
| -- in the record component association list or in the derived type |
| -- definition for an ancestor. |
| -- |
| -- Check the case of ancestors that are several generations removed. |
| -- Check the case where the value of the discriminant(s) in question |
| -- is supplied several generations removed. |
| -- |
| -- Check the case of multiple discriminants. |
| -- |
| -- Check that Constraint_Error is raised if the check fails. |
| -- |
| -- TEST DESCRIPTION: |
| -- A hierarchy of tagged types is declared from a discriminated |
| -- root type. Each level declares two kinds of types: (1) a type |
| -- extension which constrains the discriminant of its parent to |
| -- the value of an expression and (2) a type extension that |
| -- constrains the discriminant of its parent to equal a new discriminant |
| -- of the type extension (These are the two categories of noninherited |
| -- discriminants). |
| -- |
| -- Values for each type are declared within nested blocks. This is |
| -- done so that the instances that produce Constraint_Error may |
| -- be dealt with cleanly without forcing the program to exit. |
| -- |
| -- Success and failure cases (which should raise Constraint_Error) |
| -- are set up for each kind of type. Additionally, for the first |
| -- level of the hierarchy, separate tests are done for ancestor |
| -- expressions specified by aggregates and those specified by |
| -- variables. Later tests are performed using variables only. |
| -- |
| -- Additionally, the cases tested consist of the following kinds of |
| -- types: |
| -- |
| -- Extensions of extensions, using both the parent and grandparent |
| -- types for the ancestor expression, |
| -- |
| -- Ancestor expressions which are several generations removed |
| -- from the type of the aggregate, |
| -- |
| -- Extensions of types with multiple discriminants, where the |
| -- extension declares a new discriminant which corresponds to |
| -- more than one discriminant of the ancestor types. |
| -- |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 19 Dec 94 SAIC Removed RM references from objective text. |
| -- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants |
| -- |
| --! |
| |
| package C432002_0 is |
| |
| subtype Length is Natural range 0..256; |
| type Discriminant (L : Length) is tagged |
| record |
| S1 : String (1..L); |
| end record; |
| |
| procedure Do_Something (Rec : in out Discriminant); |
| -- inherited by all type extensions |
| |
| -- Aggregates of Discriminant are of the form |
| -- (L, S1) where L= S1'Length |
| |
| -- Discriminant of parent constrained to value of an expression |
| type Constrained_Discriminant_Extension is |
| new Discriminant (L => 10) |
| with record |
| S2 : String (1..20); |
| end record; |
| |
| -- Aggregates of Constrained_Discriminant_Extension are of the form |
| -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20 |
| |
| type Once_Removed is new Constrained_Discriminant_Extension |
| with record |
| S3 : String (1..3); |
| end record; |
| |
| type Twice_Removed is new Once_Removed |
| with record |
| S4 : String (1..8); |
| end record; |
| |
| -- Aggregates of Twice_Removed are of the form |
| -- (L, S1, S2, S3, S4), where L = S1'Length = 10, |
| -- S2'Length = 20, |
| -- S3'Length = 3, |
| -- S4'Length = 8 |
| |
| -- Discriminant of parent constrained to equal new discriminant |
| type New_Discriminant_Extension (N : Length) is |
| new Discriminant (L => N) with |
| record |
| S2 : String (1..N); |
| end record; |
| |
| -- Aggregates of New_Discriminant_Extension are of the form |
| -- (N, S1, S2), where N = S1'Length = S2'Length |
| |
| -- Discriminant of parent extension constrained to the value of |
| -- an expression |
| type Constrained_Extension_Extension is |
| new New_Discriminant_Extension (N => 20) |
| with record |
| S3 : String (1..5); |
| end record; |
| |
| -- Aggregates of Constrained_Extension_Extension are of the form |
| -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20, |
| -- S3'Length = 5 |
| |
| -- Discriminant of parent extension constrained to equal a new |
| -- discriminant |
| type New_Extension_Extension (I : Length) is |
| new New_Discriminant_Extension (N => I) |
| with record |
| S3 : String (1..I); |
| end record; |
| |
| -- Aggregates of New_Extension_Extension are of the form |
| -- (I, S1, 2, S3), where |
| -- I = S1'Length = S2'Length = S3'Length |
| |
| type Multiple_Discriminants (A, B : Length) is tagged |
| record |
| S1 : String (1..A); |
| S2 : String (1..B); |
| end record; |
| |
| procedure Do_Something (Rec : in out Multiple_Discriminants); |
| -- inherited by type extension |
| |
| -- Aggregates of Multiple_Discriminants are of the form |
| -- (A, B, S1, S2), where A = S1'Length, B = S2'Length |
| |
| type Multiple_Discriminant_Extension (C : Length) is |
| new Multiple_Discriminants (A => C, B => C) |
| with record |
| S3 : String (1..C); |
| end record; |
| |
| -- Aggregates of Multiple_Discriminant_Extension are of the form |
| -- (A, B, S1, S2, C, S3), where |
| -- A = B = C = S1'Length = S2'Length = S3'Length |
| |
| end C432002_0; |
| |
| with Report; |
| package body C432002_0 is |
| |
| S : String (1..20) := "12345678901234567890"; |
| |
| procedure Do_Something (Rec : in out Discriminant) is |
| begin |
| Rec.S1 := Report.Ident_Str (S (1..Rec.L)); |
| end Do_Something; |
| |
| procedure Do_Something (Rec : in out Multiple_Discriminants) is |
| begin |
| Rec.S1 := Report.Ident_Str (S (1..Rec.A)); |
| end Do_Something; |
| |
| end C432002_0; |
| |
| |
| with C432002_0; |
| with Report; |
| procedure C432002 is |
| |
| -- Various different-sized strings for variety |
| String_3 : String (1..3) := Report.Ident_Str("123"); |
| String_5 : String (1..5) := Report.Ident_Str("12345"); |
| String_8 : String (1..8) := Report.Ident_Str("12345678"); |
| String_10 : String (1..10) := Report.Ident_Str("1234567890"); |
| String_11 : String (1..11) := Report.Ident_Str("12345678901"); |
| String_20 : String (1..20) := Report.Ident_Str("12345678901234567890"); |
| |
| begin |
| |
| Report.Test ("C432002", |
| "Extension aggregates for discriminated types"); |
| |
| -------------------------------------------------------------------- |
| -- Extension constrains parent's discriminant to value of expression |
| -------------------------------------------------------------------- |
| |
| -- Successful cases - value matches corresponding discriminant value |
| |
| CD_Matched_Aggregate: |
| begin |
| declare |
| CD : C432002_0.Constrained_Discriminant_Extension := |
| (C432002_0.Discriminant'(L => 10, |
| S1 => String_10) |
| with S2 => String_20); |
| begin |
| C432002_0.Do_Something(CD); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end CD_Matched_Aggregate; |
| |
| CD_Matched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 10) := |
| C432002_0.Discriminant'(L => 10, |
| S1 => String_10); |
| |
| CD : C432002_0.Constrained_Discriminant_Extension := |
| (D with S2 => String_20); |
| begin |
| C432002_0.Do_Something(CD); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is a variable"); |
| Report.Failed ("Aggregate of extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end CD_Matched_Variable; |
| |
| |
| -- Unsuccessful cases - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| CD_Unmatched_Aggregate: |
| begin |
| declare |
| CD : C432002_0.Constrained_Discriminant_Extension := |
| (C432002_0.Discriminant'(L => 5, |
| S1 => String_5) |
| with S2 => String_20); |
| begin |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(CD); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise of Constraint_Error is expected |
| end CD_Unmatched_Aggregate; |
| |
| CD_Unmatched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 5) := |
| C432002_0.Discriminant'(L => 5, |
| S1 => String_5); |
| |
| CD : C432002_0.Constrained_Discriminant_Extension := |
| (D with S2 => String_20); |
| begin |
| Report.Comment ("Ancestor expression is an variable"); |
| Report.Failed ("Aggregate of extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(CD); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise of Constraint_Error is expected |
| end CD_Unmatched_Variable; |
| |
| ----------------------------------------------------------------------- |
| -- Extension constrains parent's discriminant to equal new discriminant |
| ----------------------------------------------------------------------- |
| |
| -- Successful cases - value matches corresponding discriminant value |
| |
| ND_Matched_Aggregate: |
| begin |
| declare |
| ND : C432002_0.New_Discriminant_Extension (N => 8) := |
| (C432002_0.Discriminant'(L => 8, |
| S1 => String_8) |
| with N => 8, |
| S2 => String_8); |
| begin |
| C432002_0.Do_Something(ND); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension " & |
| "with new discriminant: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end ND_Matched_Aggregate; |
| |
| ND_Matched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 3) := |
| C432002_0.Discriminant'(L => 3, |
| S1 => String_3); |
| |
| ND : C432002_0.New_Discriminant_Extension (N => 3) := |
| (D with N => 3, |
| S2 => String_3); |
| begin |
| C432002_0.Do_Something(ND); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is an variable"); |
| Report.Failed ("Aggregate of extension " & |
| "with new discriminant: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end ND_Matched_Variable; |
| |
| |
| -- Unsuccessful cases - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| ND_Unmatched_Aggregate: |
| begin |
| declare |
| ND : C432002_0.New_Discriminant_Extension (N => 20) := |
| (C432002_0.Discriminant'(L => 11, |
| S1 => String_11) |
| with N => 20, |
| S2 => String_20); |
| begin |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension " & |
| "with new discriminant: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(ND); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end ND_Unmatched_Aggregate; |
| |
| ND_Unmatched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 5) := |
| C432002_0.Discriminant'(L => 5, |
| S1 => String_5); |
| |
| ND : C432002_0.New_Discriminant_Extension (N => 20) := |
| (D with N => 20, |
| S2 => String_20); |
| begin |
| Report.Comment ("Ancestor expression is an variable"); |
| Report.Failed ("Aggregate of extension " & |
| "with new discriminant: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(ND); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end ND_Unmatched_Variable; |
| |
| -------------------------------------------------------------------- |
| -- Extension constrains parent's discriminant to value of expression |
| -- Parent is a discriminant extension |
| -------------------------------------------------------------------- |
| |
| -- Successful cases - value matches corresponding discriminant value |
| |
| CE_Matched_Aggregate: |
| begin |
| declare |
| CE : C432002_0.Constrained_Extension_Extension := |
| (C432002_0.Discriminant'(L => 20, |
| S1 => String_20) |
| with N => 20, |
| S2 => String_20, |
| S3 => String_5); |
| begin |
| C432002_0.Do_Something(CE); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with discriminant constrained: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end CE_Matched_Aggregate; |
| |
| CE_Matched_Variable: |
| begin |
| declare |
| ND : C432002_0.New_Discriminant_Extension (N => 20) := |
| C432002_0.New_Discriminant_Extension' |
| (N => 20, |
| S1 => String_20, |
| S2 => String_20); |
| |
| CE : C432002_0.Constrained_Extension_Extension := |
| (ND with S3 => String_5); |
| begin |
| C432002_0.Do_Something(CE); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is a variable"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with discriminant constrained: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end CE_Matched_Variable; |
| |
| |
| -- Unsuccessful cases - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| CE_Unmatched_Aggregate: |
| begin |
| declare |
| CE : C432002_0.Constrained_Extension_Extension := |
| (C432002_0.New_Discriminant_Extension' |
| (N => 11, |
| S1 => String_11, |
| S2 => String_11) |
| with S3 => String_5); |
| begin |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "Constraint_Error was not raised " & |
| "with discriminant constrained: " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(CE); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise of Constraint_Error is expected |
| end CE_Unmatched_Aggregate; |
| |
| CE_Unmatched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 8) := |
| C432002_0.Discriminant'(L => 8, |
| S1 => String_8); |
| |
| CE : C432002_0.Constrained_Extension_Extension := |
| (D with N => 8, |
| S2 => String_8, |
| S3 => String_5); |
| begin |
| Report.Comment ("Ancestor expression is a variable"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with discriminant constrained: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(CE); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise of Constraint_Error is expected |
| end CE_Unmatched_Variable; |
| |
| ----------------------------------------------------------------------- |
| -- Extension constrains parent's discriminant to equal new discriminant |
| -- Parent is a discriminant extension |
| ----------------------------------------------------------------------- |
| |
| -- Successful cases - value matches corresponding discriminant value |
| |
| NE_Matched_Aggregate: |
| begin |
| declare |
| NE : C432002_0.New_Extension_Extension (I => 8) := |
| (C432002_0.Discriminant'(L => 8, |
| S1 => String_8) |
| with I => 8, |
| S2 => String_8, |
| S3 => String_8); |
| begin |
| C432002_0.Do_Something(NE); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is an aggregate"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with new discriminant: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end NE_Matched_Aggregate; |
| |
| NE_Matched_Variable: |
| begin |
| declare |
| ND : C432002_0.New_Discriminant_Extension (N => 3) := |
| C432002_0.New_Discriminant_Extension' |
| (N => 3, |
| S1 => String_3, |
| S2 => String_3); |
| |
| NE : C432002_0.New_Extension_Extension (I => 3) := |
| (ND with I => 3, |
| S3 => String_3); |
| begin |
| C432002_0.Do_Something(NE); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Comment ("Ancestor expression is a variable"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with new discriminant: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end NE_Matched_Variable; |
| |
| |
| -- Unsuccessful cases - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| NE_Unmatched_Aggregate: |
| begin |
| declare |
| NE : C432002_0.New_Extension_Extension (I => 8) := |
| (C432002_0.New_Discriminant_Extension' |
| (C432002_0.Discriminant'(L => 11, |
| S1 => String_11) |
| with N => 11, |
| S2 => String_11) |
| with I => 8, |
| S3 => String_8); |
| begin |
| Report.Comment ("Ancestor expression is an extension aggregate"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with new discriminant: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(NE); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end NE_Unmatched_Aggregate; |
| |
| NE_Unmatched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant(L => 5) := |
| C432002_0.Discriminant'(L => 5, |
| S1 => String_5); |
| |
| NE : C432002_0.New_Extension_Extension (I => 20) := |
| (D with I => 5, |
| S2 => String_5, |
| S3 => String_20); |
| begin |
| Report.Comment ("Ancestor expression is a variable"); |
| Report.Failed ("Aggregate of extension (of extension) " & |
| "with new discriminant: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(NE); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end NE_Unmatched_Variable; |
| |
| ----------------------------------------------------------------------- |
| -- Corresponding discriminant is two levels deeper than aggregate |
| ----------------------------------------------------------------------- |
| |
| -- Successful case - value matches corresponding discriminant value |
| |
| TR_Matched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant (L => 10) := |
| C432002_0.Discriminant'(L => 10, |
| S1 => String_10); |
| |
| TR : C432002_0.Twice_Removed := |
| C432002_0.Twice_Removed'(D with S2 => String_20, |
| S3 => String_3, |
| S4 => String_8); |
| -- N is constrained to a value in the derived_type_definition |
| -- of Constrained_Discriminant_Extension. Its omission from |
| -- the above record_component_association_list is allowed by |
| -- 4.3.2(6). |
| |
| begin |
| C432002_0.Do_Something(TR); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Failed ("Aggregate of far-removed extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end TR_Matched_Variable; |
| |
| |
| -- Unsuccessful case - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| TR_Unmatched_Variable: |
| begin |
| declare |
| D : C432002_0.Discriminant (L => 5) := |
| C432002_0.Discriminant'(L => 5, |
| S1 => String_5); |
| |
| TR : C432002_0.Twice_Removed := |
| C432002_0.Twice_Removed'(D with S2 => String_20, |
| S3 => String_3, |
| S4 => String_8); |
| |
| begin |
| Report.Failed ("Aggregate of far-removed extension " & |
| "with discriminant constrained: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(TR); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end TR_Unmatched_Variable; |
| |
| ------------------------------------------------------------------------ |
| -- Parent has multiple discriminants. |
| -- Discriminant in extension corresponds to both parental discriminants. |
| ------------------------------------------------------------------------ |
| |
| -- Successful case - value matches corresponding discriminant value |
| |
| MD_Matched_Variable: |
| begin |
| declare |
| MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) := |
| C432002_0.Multiple_Discriminants'(A => 10, |
| B => 10, |
| S1 => String_10, |
| S2 => String_10); |
| MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := |
| (MD with C => 10, |
| S3 => String_10); |
| |
| begin |
| C432002_0.Do_Something(MDE); -- success |
| end; |
| exception |
| when Constraint_Error => |
| Report.Failed ("Aggregate of extension " & |
| "of multiply-discriminated parent: " & |
| "Constraint_Error was incorrectly raised " & |
| "for value that matches corresponding " & |
| "discriminant"); |
| end MD_Matched_Variable; |
| |
| |
| -- Unsuccessful case - value does not match value of corresponding |
| -- discriminant. Constraint_Error should be |
| -- raised. |
| |
| MD_Unmatched_Variable: |
| begin |
| declare |
| MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) := |
| C432002_0.Multiple_Discriminants'(A => 10, |
| B => 8, |
| S1 => String_10, |
| S2 => String_8); |
| MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := |
| (MD with C => 10, |
| S3 => String_10); |
| |
| begin |
| Report.Failed ("Aggregate of extension " & |
| "of multiply-discriminated parent: " & |
| "Constraint_Error was not raised " & |
| "for discriminant value that does not match " & |
| "corresponding discriminant"); |
| C432002_0.Do_Something(MDE); -- disallow unused var optimization |
| end; |
| exception |
| when Constraint_Error => |
| null; -- raise is expected |
| end MD_Unmatched_Variable; |
| |
| Report.Result; |
| |
| end C432002; |
