-- 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;