aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a594
1 files changed, 594 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a
new file mode 100644
index 000000000..8988992c4
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432003.a
@@ -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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-18 00:58:24 +0000