| -- 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; |
