Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/ada/acats/tests/c4/c432003.a @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children |
line wrap: on
line source
-- C432003.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 the type of the ancestor part of an extension aggregate -- has discriminants that are not inherited by the type of the aggregate, -- and the ancestor part is a subtype mark that denotes a constrained -- subtype, Constraint_Error is raised if: 1) any discriminant of the -- ancestor has a different value than that specified for a corresponding -- discriminant in the derived type definition for some ancestor of the -- type of the aggregate, or 2) the value for the discriminant in the -- record association list is not the value of the corresponding -- discriminant. Check that the components of the value of the -- aggregate not given by the record component association list are -- initialized by default as for an object of the ancestor type. -- -- TEST DESCRIPTION: -- Consider: -- -- type T (D1: ...) is tagged ... -- -- type DT is new T with ... -- subtype ST is DT (D1 => 3); -- Constrained subtype. -- -- type NT1 (D2: ...) is new DT (D1 => D2) with null record; -- type NT2 (D2: ...) is new DT (D1 => 6) with null record; -- type NT3 is new DT (D1 => 6) with null record; -- -- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained. -- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained. -- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2. -- -- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained. -- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained. -- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2. -- -- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained. -- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained. -- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3. -- -- In A, B, D, E, G, and H the ancestor part is the name of an -- unconstrained subtype, so this rule does not apply. In C, F, and I -- the ancestor part (ST) is the name of a constrained subtype of DT, -- which is itself a derived type of a discriminated tagged type T. ST -- constrains the discriminant of DT (D1) to the value 3; thus, the -- type of any extension aggregate for which ST is the ancestor part -- must have an ancestor which also constrained D1 to 3. F and I raise -- Constraint_Error because NT2 and NT3, respectively, constrain D1 to -- 6. C raises Constraint_Error because NT1 constrains D1 to the value -- of D2, which is set to 6 in the record component association list of -- the aggregate. -- -- This test verifies each of the three scenarios above: -- -- (1) Ancestor of type of aggregate constrains discriminant with -- new discriminant. -- (2) Ancestor of type of aggregate constrains discriminant with -- value, and has a new discriminant part. -- (3) Ancestor of type of aggregate constrains discriminant with -- value, and has no discriminant part. -- -- Verification is made for cases where the type of the aggregate is -- once- and twice-removed from the type of the ancestor part. -- -- Additionally, a case is included where a new discriminant corresponds -- to multiple discriminants of the type of the ancestor part. -- -- To test the portion of the objective concerning "initialization by -- default," the test verifies that, after a successful aggregate -- assignment, components not assigned an explicit value by the aggregate -- contain the default values for the corresponding components of the -- ancestor type. -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 15 Dec 94 SAIC Removed discriminant defaults from tagged types. -- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint -- for component NT_C3.Str2. Added missing component -- checks. Removed record component update from -- Avoid_Optimization. Fixed incorrect component -- checks. -- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for -- Q case. -- --! package C432003_0 is Default_String : constant String := "This is a default string"; -- len = 24 Another_String : constant String := "Another default string"; -- len = 22 subtype Length is Natural range 0..255; type ROOT (D1 : Length) is tagged record S1 : String (1..D1) := Default_String(1..D1); Acc : Natural := 356; end record; procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type -- extensions. type Unconstrained_Der is new ROOT with record Str1 : String(1..5) := "abcde"; end record; subtype Constrained_Subtype is Unconstrained_Der (D1 => 10); type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with record S2 : String(1..D2); -- Inherited discrim. constrained by end record; -- new discriminant. type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with record S3 : String(1..D3); -- Inherited discrim. constrained by end record; -- new discriminant. type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with record S2 : String(1..D2); -- Inherited discrim. constrained by end record; -- explicit value. type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with record S3 : String(1..D3); -- Inherited discrim. constrained by end record; -- explicit value. type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with record S2 : String(1..D2); end record; type NT_C1 is new Unconstrained_Der (D1 => 5) with record Str2 : String(1..5); -- Inherited discrim. constrained end record; -- No new value. type NT_C2 (D2 : Length) is new NT_C1 with record S2 : String(1..D2); -- Inherited discrim. not further end record; -- constrained, new discriminant. type NT_C3 is new Unconstrained_Der(D1 => 10) with record Str2 : String(1..5); end record; type MULTI_ROOT (D1 : Length; D2 : Length) is tagged record S1 : String (1..D1) := Default_String(1..D1); S2 : String (1..D2) := Another_String(1..D2); end record; procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all -- type extensions. type Mult_Unconstr_Der is new MULTI_ROOT with record Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints. end record; -- Subtypes with constrained discriminants. subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have D2 => 20); -- diff values subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have D2 => 15); -- same value type Mult_NT_A1 (D3 : Length) is new Mult_Unconstr_Der (D1 => D3, D2 => D3) with record S3 : String(1..D3); -- Both inherited discriminants constrained end record; -- by new discriminant. end C432003_0; --=====================================================================-- with Report; package body C432003_0 is procedure Avoid_Optimization (Rec : in out ROOT) is begin Rec.S1 := Report.Ident_Str(Rec.S1); end Avoid_Optimization; procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is begin Rec.S1 := Report.Ident_Str(Rec.S1); end Avoid_Optimization; end C432003_0; --=====================================================================-- with C432003_0; with Report; procedure C432003 is begin Report.Test("C432003", "Extension aggregates where ancestor part " & "is a subtype mark that denotes a constrained " & "subtype causing Constraint_Error if any " & "discriminant of the ancestor has a different " & "value than that specified for a corresponding " & "discriminant in the derived type definition " & "for some ancestor of the type of the aggregate"); Test_Block: declare -- Variety of string object declarations. String2 : String(1..2) := Report.Ident_Str("12"); String5 : String(1..5) := Report.Ident_Str("12345"); String8 : String(1..8) := Report.Ident_Str("AbCdEfGh"); String10 : String(1..10) := Report.Ident_Str("1234567890"); String15 : String(1..15) := Report.Ident_Str("123456789012345"); String20 : String(1..20) := Report.Ident_Str("12345678901234567890"); begin begin declare A : C432003_0.NT_A1 := -- OK (C432003_0.ROOT with D2 => 5, Str1 => "cdefg", S2 => String5); begin C432003_0.Avoid_Optimization(A); if A.Acc /= 356 or A.Str1 /= "cdefg" or A.S2 /= String5 or A.D2 /= 5 or A.S1 /= C432003_0.Default_String(1..5) then Report.Failed("Incorrect object values for Object A"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object A"); end; begin declare C: C432003_0.NT_A1 := -- OK (C432003_0.Constrained_Subtype with D2 => 10, S2 => String10); begin C432003_0.Avoid_Optimization(C); if C.D2 /= 10 or C.Acc /= 356 or C.Str1 /= "abcde" or C.S2 /= String10 or C.S1 /= C432003_0.Default_String(1..10) then Report.Failed("Incorrect object values for Object C"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object C"); end; begin declare D: C432003_0.NT_A1 := -- C_E (C432003_0.Constrained_Subtype with D2 => Report.Ident_Int(5), S2 => String5); begin C432003_0.Avoid_Optimization(D); Report.Failed("Constraint_Error not raised for Object D"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare E: C432003_0.NT_A2 := -- OK (C432003_0.Constrained_Subtype with D3 => 10, S2 => String10, S3 => String10); begin C432003_0.Avoid_Optimization(E); if E.D3 /= 10 or E.Acc /= 356 or E.Str1 /= "abcde" or E.S2 /= String10 or E.S3 /= String10 or E.S1 /= C432003_0.Default_String(1..10) then Report.Failed("Incorrect object values for Object E"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object E"); end; begin declare F: C432003_0.NT_A2 := -- C_E (C432003_0.Constrained_Subtype with D3 => Report.Ident_Int(5), S2 => String5, S3 => String5); begin C432003_0.Avoid_Optimization(F); Report.Failed("Constraint_Error not raised for Object F"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare G: C432003_0.NT_B2 := -- OK (C432003_0.ROOT with D3 => 5, Str1 => "cdefg", S2 => String10, S3 => String5); begin C432003_0.Avoid_Optimization(G); if G.D3 /= 5 or G.Acc /= 356 or G.Str1 /= "cdefg" or G.S2 /= String10 or G.S3 /= String5 or G.S1 /= C432003_0.Default_String(1..5) then Report.Failed("Incorrect object values for Object G"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object G"); end; begin declare H: C432003_0.NT_B3 := -- OK (C432003_0.Unconstrained_Der with D2 => 5, S2 => String5); begin C432003_0.Avoid_Optimization(H); if H.D2 /= 5 or H.Acc /= 356 or H.Str1 /= "abcde" or H.S2 /= String5 or H.S1 /= C432003_0.Default_String(1..10) then Report.Failed("Incorrect object values for Object H"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object H"); end; begin declare I: C432003_0.NT_B1 := -- C_E (C432003_0.Constrained_Subtype with D2 => Report.Ident_Int(10), S2 => String10); begin C432003_0.Avoid_Optimization(I); Report.Failed("Constraint_Error not raised for Object I"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare J: C432003_0.NT_B2 := -- C_E (C432003_0.Constrained_Subtype with D3 => Report.Ident_Int(10), S2 => String10, S3 => String10); begin C432003_0.Avoid_Optimization(J); Report.Failed("Constraint_Error not raised by Object J"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare K: C432003_0.NT_B3 := -- OK (C432003_0.Constrained_Subtype with D2 => 5, S2 => String5); begin C432003_0.Avoid_Optimization(K); if K.D2 /= 5 or K.Acc /= 356 or K.Str1 /= "abcde" or K.S2 /= String5 or K.S1 /= C432003_0.Default_String(1..10) then Report.Failed("Incorrect object values for Object K"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object K"); end; begin declare M: C432003_0.NT_C2 := -- OK (C432003_0.ROOT with D2 => 10, Str1 => "cdefg", Str2 => String5, S2 => String10); begin C432003_0.Avoid_Optimization(M); if M.D2 /= 10 or M.Acc /= 356 or M.Str1 /= "cdefg" or M.S2 /= String10 or M.Str2 /= String5 or M.S1 /= C432003_0.Default_String(1..5) then Report.Failed("Incorrect object values for Object M"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object M"); end; begin declare O: C432003_0.NT_C1 := -- C_E (C432003_0.Constrained_Subtype with Str2 => Report.Ident_Str(String5)); begin C432003_0.Avoid_Optimization(O); Report.Failed("Constraint_Error not raised for Object O"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare P: C432003_0.NT_C2 := -- C_E (C432003_0.Constrained_Subtype with D2 => Report.Ident_Int(10), Str2 => String5, S2 => String10); begin C432003_0.Avoid_Optimization(P); Report.Failed("Constraint_Error not raised by Object P"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare Q: C432003_0.NT_C3 := (C432003_0.Constrained_Subtype with Str2 => String5); -- OK begin C432003_0.Avoid_Optimization(Q); if Q.Str2 /= String5 or Q.Acc /= 356 or Q.Str1 /= "abcde" or Q.D1 /= 10 or Q.S1 /= C432003_0.Default_String(1..10) then Report.Failed("Incorrect object values for Object Q"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object Q"); end; -- The following cases test where a new discriminant corresponds -- to multiple discriminants of the type of the ancestor part. begin declare S: C432003_0.Mult_NT_A1 := -- OK (C432003_0.Mult_Unconstr_Der with D3 => 15, S3 => String15); begin C432003_0.Avoid_Optimization(S); if S.S1 /= C432003_0.Default_String(1..15) or S.Str1 /= String8 or S.S2 /= C432003_0.Another_String(1..15) or S.S3 /= String15 or S.D3 /= 15 then Report.Failed("Incorrect object values for Object S"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object S"); end; begin declare U: C432003_0.Mult_NT_A1 := -- C_E (C432003_0.Mult_Constr_Sub1 with D3 => Report.Ident_Int(15), S3 => String15); begin C432003_0.Avoid_Optimization(U); Report.Failed("Constraint_Error not raised for Object U"); end; exception when Constraint_Error => null; -- Raise of Constraint_Error is expected. end; begin declare V: C432003_0.Mult_NT_A1 := -- OK (C432003_0.Mult_Constr_Sub2 with D3 => 15, S3 => String15); begin C432003_0.Avoid_Optimization(V); if V.D3 /= 15 or V.Str1 /= String8 or V.S3 /= String15 or V.S1 /= C432003_0.Default_String(1..15) or V.S2 /= C432003_0.Another_String(1..15) then Report.Failed("Incorrect object values for Object V"); end if; end; exception when Constraint_Error => Report.Failed("Constraint_Error raised for Object V"); end; exception when others => Report.Failed("Exception raised in Test_Block"); end Test_Block; Report.Result; end C432003;