Mercurial > hg > CbC > CbC_gcc
diff 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 diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/ada/acats/tests/c4/c432003.a Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,594 @@ +-- 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;