aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c4/c432003.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c432003.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432003.a594
1 files changed, 0 insertions, 594 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc/testsuite/ada/acats/tests/c4/c432003.a
deleted file mode 100644
index 8988992c4e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432003.a
+++ /dev/null
@@ -1,594 +0,0 @@
--- 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-05-26 15:21:05 +0000