diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432002.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432002.a | 764 |
1 files changed, 764 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432002.a new file mode 100644 index 000000000..5de821b30 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432002.a @@ -0,0 +1,764 @@ +-- 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; |