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