aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c4/c433001.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c433001.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c433001.a302
1 files changed, 0 insertions, 302 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a
deleted file mode 100644
index 613b688c8ca..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c433001.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- C433001.A
-
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 an others choice is allowed in an array aggregate whose
--- applicable index constraint is dynamic. (This was an extension to
--- Ada 83). Check that index choices are within the applicable index
--- constraint for array aggregates with others choices.
---
--- TEST DESCRIPTION
--- In this test, we declare several unconstrained array types, and
--- several dynamic subtypes. We then test a variety of cases of using
--- appropriate aggregates. Some cases expect to raise Constraint_Error.
---
--- HISTORY:
--- 16 DEC 1999 RLB Initial Version.
-
-with Report;
-procedure C433001 is
-
- type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
-
- type Array_1 is array (Positive range <>) of Integer;
-
- subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3));
- subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5));
- subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9));
-
- type Array_2 is array (Color_Type range <>) of Integer;
-
- subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) ..
- Color_Type'Val(Report.Ident_Int(2)));
- -- Red .. Yellow
- subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) ..
- Color_Type'Val(Report.Ident_Int(6)));
- -- Green .. Violet
- type Array_3 is array (Color_Type range <>, Positive range <>) of Integer;
-
- subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) ..
- Color_Type'Val(Report.Ident_Int(2)),
- Report.Ident_Int(3) .. Report.Ident_Int(5));
- -- Red .. Yellow, 3 .. 5
- subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) ..
- Color_Type'Val(Report.Ident_Int(3)),
- Report.Ident_Int(6) .. Report.Ident_Int(8));
- -- Orange .. Green, 6 .. 8
-
- procedure Check_1 (Obj : Array_1; Low, High : Integer;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- if Obj'First /= Low then
- Report.Failed ("Low bound incorrect (" & Test_Case & ")");
- end if;
- if Obj'Last /= High then
- Report.Failed ("High bound incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low) /= First_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low+1) /= Second_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(High) /= Last_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- end Check_1;
-
- procedure Check_2 (Obj : Array_2; Low, High : Color_Type;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- if Obj'First /= Low then
- Report.Failed ("Low bound incorrect (" & Test_Case & ")");
- end if;
- if Obj'Last /= High then
- Report.Failed ("High bound incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low) /= First_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(Color_Type'Succ(Low)) /= Second_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(High) /= Last_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- end Check_2;
-
- procedure Check_3 (Test_Obj, Check_Obj : Array_3;
- Low_1, High_1 : Color_Type;
- Low_2, High_2 : Integer;
- Test_Case : Character) is
- begin
- if Test_Obj'First(1) /= Low_1 then
- Report.Failed ("Low bound for dimension 1 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'Last(1) /= High_1 then
- Report.Failed ("High bound for dimension 1 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'First(2) /= Low_2 then
- Report.Failed ("Low bound for dimension 2 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'Last(2) /= High_2 then
- Report.Failed ("High bound for dimension 2 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj /= Check_Obj then
- Report.Failed ("Components incorrect (" & Test_Case & ")");
- end if;
- end Check_3;
-
- procedure Subtest_Check_1 (Obj : Sub_1_3;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component,
- Test_Case);
- end Subtest_Check_1;
-
- procedure Subtest_Check_2 (Obj : Sub_2_2;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- Check_2 (Obj, Green, Violet, First_Component, Second_Component,
- Last_Component, Test_Case);
- end Subtest_Check_2;
-
- procedure Subtest_Check_3 (Obj : Sub_3_2;
- Test_Case : Character) is
- begin
- Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case);
- end Subtest_Check_3;
-
-begin
-
- Report.Test ("C433001",
- "Check that an others choice is allowed in an array " &
- "aggregate whose applicable index constraint is dynamic. " &
- "Also check index choices are within the applicable index " &
- "constraint for array aggregates with others choices");
-
- -- Check with a qualified expression:
- Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3,
- First_Component => 2, Second_Component => 3, Last_Component => 4,
- Test_Case => 'A');
-
- Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)),
- Low => Red, High => Yellow,
- First_Component => 1, Second_Component => 6, Last_Component => 6,
- Test_Case => 'B');
-
- Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)),
- Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)),
- Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5,
- Test_Case => 'C');
-
- -- Check that the others clause does not need to represent any components:
- Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5,
- First_Component => 5, Second_Component => 6, Last_Component => 8,
- Test_Case => 'D');
-
- -- Check named choices are allowed:
- Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8),
- Low => 1, High => 3,
- First_Component => 8, Second_Component => -1, Last_Component => 8,
- Test_Case => 'E');
-
- -- Check named choices and formal parameters:
- Subtest_Check_1 ((6 => 4, 8 => 86, others => 1),
- First_Component => 1, Second_Component => 4, Last_Component => 1,
- Test_Case => 'F');
-
- Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89,
- Indigo => Report.Ident_Int(42), Blue => 0, others => -1),
- First_Component => 88, Second_Component => 0, Last_Component => 89,
- Test_Case => 'G');
-
- Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)),
- Test_Case => 'H');
-
- -- Check object declarations and assignment:
- declare
- Var : Sub_1_2 := (4, 36, others => 86);
- begin
- Check_1 (Var, Low => 3, High => 5,
- First_Component => 4, Second_Component => 36,
- Last_Component => 86,
- Test_Case => 'I');
- Var := (5 => 415, others => Report.Ident_Int(1522));
- Check_1 (Var, Low => 3, High => 5,
- First_Component => 1522, Second_Component => 1522,
- Last_Component => 415,
- Test_Case => 'J');
- end;
-
- -- Check positional aggregates that are too long:
- begin
- Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93),
- First_Component => 88, Second_Component => 89,
- Last_Component => 91,
- Test_Case => 'K');
- Report.Failed ("Constraint_Error not raised by positional " &
- "aggregate with too many choices (K)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 (((0, others => 10), (2, 3, others => 4),
- (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)),
- Test_Case => 'L');
- Report.Failed ("Constraint_Error not raised by positional " &
- "aggregate with too many choices (L)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- -- Check named aggregates with choices in the index subtype but not in the
- -- applicable index constraint:
-
- begin
- Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89,
- 10 => 66, -- 10 not in applicable index constraint
- others => 93),
- First_Component => 88, Second_Component => 93,
- Last_Component => 93,
- Test_Case => 'M');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (M)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_2 (
- (Yellow => 23, -- Yellow not in applicable index constraint.
- Blue => 16, others => 77),
- First_Component => 77, Second_Component => 16,
- Last_Component => 77,
- Test_Case => 'N');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (N)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 ((Orange => (0, others => 10),
- Blue => (2, 3, others => 4), -- Blue not in applicable index cons.
- others => (1, 2, 3)),
- Test_Case => 'P');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (P)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)),
- Green => (8 => 2, 4 => 3, others => 7),
- -- 4 not in applicable index cons.
- others => (1, 2, 3, others => Report.Ident_Int(10))),
- Test_Case => 'Q');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (Q)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- Report.Result;
-
-end C433001;
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-17 23:32:03 +0000