1-- C433001.A 2 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE 27-- Check that an others choice is allowed in an array aggregate whose 28-- applicable index constraint is dynamic. (This was an extension to 29-- Ada 83). Check that index choices are within the applicable index 30-- constraint for array aggregates with others choices. 31-- 32-- TEST DESCRIPTION 33-- In this test, we declare several unconstrained array types, and 34-- several dynamic subtypes. We then test a variety of cases of using 35-- appropriate aggregates. Some cases expect to raise Constraint_Error. 36-- 37-- HISTORY: 38-- 16 DEC 1999 RLB Initial Version. 39-- 20 JAN 2009 RLB Corrected error messages. 40 41with Report; 42procedure C433001 is 43 44 type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); 45 46 type Array_1 is array (Positive range <>) of Integer; 47 48 subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3)); 49 subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5)); 50 subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9)); 51 52 type Array_2 is array (Color_Type range <>) of Integer; 53 54 subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) .. 55 Color_Type'Val(Report.Ident_Int(2))); 56 -- Red .. Yellow 57 subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) .. 58 Color_Type'Val(Report.Ident_Int(6))); 59 -- Green .. Violet 60 type Array_3 is array (Color_Type range <>, Positive range <>) of Integer; 61 62 subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) .. 63 Color_Type'Val(Report.Ident_Int(2)), 64 Report.Ident_Int(3) .. Report.Ident_Int(5)); 65 -- Red .. Yellow, 3 .. 5 66 subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) .. 67 Color_Type'Val(Report.Ident_Int(3)), 68 Report.Ident_Int(6) .. Report.Ident_Int(8)); 69 -- Orange .. Green, 6 .. 8 70 71 procedure Check_1 (Obj : Array_1; Low, High : Integer; 72 First_Component, Second_Component, 73 Last_Component : Integer; 74 Test_Case : Character) is 75 begin 76 if Obj'First /= Low then 77 Report.Failed ("Low bound incorrect (" & Test_Case & ")"); 78 end if; 79 if Obj'Last /= High then 80 Report.Failed ("High bound incorrect (" & Test_Case & ")"); 81 end if; 82 if Obj(Low) /= First_Component then 83 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 84 end if; 85 if Obj(Low+1) /= Second_Component then 86 Report.Failed ("Second Component incorrect (" & Test_Case & ")"); 87 end if; 88 if Obj(High) /= Last_Component then 89 Report.Failed ("Last Component incorrect (" & Test_Case & ")"); 90 end if; 91 end Check_1; 92 93 procedure Check_2 (Obj : Array_2; Low, High : Color_Type; 94 First_Component, Second_Component, 95 Last_Component : Integer; 96 Test_Case : Character) is 97 begin 98 if Obj'First /= Low then 99 Report.Failed ("Low bound incorrect (" & Test_Case & ")"); 100 end if; 101 if Obj'Last /= High then 102 Report.Failed ("High bound incorrect (" & Test_Case & ")"); 103 end if; 104 if Obj(Low) /= First_Component then 105 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 106 end if; 107 if Obj(Color_Type'Succ(Low)) /= Second_Component then 108 Report.Failed ("Second Component incorrect (" & Test_Case & ")"); 109 end if; 110 if Obj(High) /= Last_Component then 111 Report.Failed ("Last Component incorrect (" & Test_Case & ")"); 112 end if; 113 end Check_2; 114 115 procedure Check_3 (Test_Obj, Check_Obj : Array_3; 116 Low_1, High_1 : Color_Type; 117 Low_2, High_2 : Integer; 118 Test_Case : Character) is 119 begin 120 if Test_Obj'First(1) /= Low_1 then 121 Report.Failed ("Low bound for dimension 1 incorrect (" & 122 Test_Case & ")"); 123 end if; 124 if Test_Obj'Last(1) /= High_1 then 125 Report.Failed ("High bound for dimension 1 incorrect (" & 126 Test_Case & ")"); 127 end if; 128 if Test_Obj'First(2) /= Low_2 then 129 Report.Failed ("Low bound for dimension 2 incorrect (" & 130 Test_Case & ")"); 131 end if; 132 if Test_Obj'Last(2) /= High_2 then 133 Report.Failed ("High bound for dimension 2 incorrect (" & 134 Test_Case & ")"); 135 end if; 136 if Test_Obj /= Check_Obj then 137 Report.Failed ("Components incorrect (" & Test_Case & ")"); 138 end if; 139 end Check_3; 140 141 procedure Subtest_Check_1 (Obj : Sub_1_3; 142 First_Component, Second_Component, 143 Last_Component : Integer; 144 Test_Case : Character) is 145 begin 146 Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component, 147 Test_Case); 148 end Subtest_Check_1; 149 150 procedure Subtest_Check_2 (Obj : Sub_2_2; 151 First_Component, Second_Component, 152 Last_Component : Integer; 153 Test_Case : Character) is 154 begin 155 Check_2 (Obj, Green, Violet, First_Component, Second_Component, 156 Last_Component, Test_Case); 157 end Subtest_Check_2; 158 159 procedure Subtest_Check_3 (Obj : Sub_3_2; 160 Test_Case : Character) is 161 begin 162 Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case); 163 end Subtest_Check_3; 164 165begin 166 167 Report.Test ("C433001", 168 "Check that an others choice is allowed in an array " & 169 "aggregate whose applicable index constraint is dynamic. " & 170 "Also check index choices are within the applicable index " & 171 "constraint for array aggregates with others choices"); 172 173 -- Check with a qualified expression: 174 Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3, 175 First_Component => 2, Second_Component => 3, Last_Component => 4, 176 Test_Case => 'A'); 177 178 Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)), 179 Low => Red, High => Yellow, 180 First_Component => 1, Second_Component => 6, Last_Component => 6, 181 Test_Case => 'B'); 182 183 Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)), 184 Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)), 185 Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5, 186 Test_Case => 'C'); 187 188 -- Check that the others clause does not need to represent any components: 189 Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5, 190 First_Component => 5, Second_Component => 6, Last_Component => 8, 191 Test_Case => 'D'); 192 193 -- Check named choices are allowed: 194 Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8), 195 Low => 1, High => 3, 196 First_Component => 8, Second_Component => -1, Last_Component => 8, 197 Test_Case => 'E'); 198 199 -- Check named choices and formal parameters: 200 Subtest_Check_1 ((6 => 4, 8 => 86, others => 1), 201 First_Component => 1, Second_Component => 4, Last_Component => 1, 202 Test_Case => 'F'); 203 204 Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89, 205 Indigo => Report.Ident_Int(42), Blue => 0, others => -1), 206 First_Component => 88, Second_Component => 0, Last_Component => 89, 207 Test_Case => 'G'); 208 209 Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)), 210 Test_Case => 'H'); 211 212 -- Check object declarations and assignment: 213 declare 214 Var : Sub_1_2 := (4, 36, others => 86); 215 begin 216 Check_1 (Var, Low => 3, High => 5, 217 First_Component => 4, Second_Component => 36, 218 Last_Component => 86, 219 Test_Case => 'I'); 220 Var := (5 => 415, others => Report.Ident_Int(1522)); 221 Check_1 (Var, Low => 3, High => 5, 222 First_Component => 1522, Second_Component => 1522, 223 Last_Component => 415, 224 Test_Case => 'J'); 225 end; 226 227 -- Check positional aggregates that are too long: 228 begin 229 Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93), 230 First_Component => 88, Second_Component => 89, 231 Last_Component => 91, 232 Test_Case => 'K'); 233 Report.Failed ("Constraint_Error not raised by positional " & 234 "aggregate with too many choices (K)"); 235 exception 236 when Constraint_Error => null; -- Expected exception. 237 end; 238 239 begin 240 Subtest_Check_3 (((0, others => 10), (2, 3, others => 4), 241 (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)), 242 Test_Case => 'L'); 243 Report.Failed ("Constraint_Error not raised by positional " & 244 "aggregate with too many choices (L)"); 245 exception 246 when Constraint_Error => null; -- Expected exception. 247 end; 248 249 -- Check named aggregates with choices in the index subtype but not in the 250 -- applicable index constraint: 251 252 begin 253 Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89, 254 10 => 66, -- 10 not in applicable index constraint 255 others => 93), 256 First_Component => 88, Second_Component => 93, 257 Last_Component => 93, 258 Test_Case => 'M'); 259 Report.Failed ("Constraint_Error not raised by aggregate choice " & 260 "index outside of applicable index constraint (M)"); 261 exception 262 when Constraint_Error => null; -- Expected exception. 263 end; 264 265 begin 266 Subtest_Check_2 ( 267 (Yellow => 23, -- Yellow not in applicable index constraint. 268 Blue => 16, others => 77), 269 First_Component => 77, Second_Component => 16, 270 Last_Component => 77, 271 Test_Case => 'N'); 272 Report.Failed ("Constraint_Error not raised by aggregate choice " & 273 "index outside of applicable index constraint (N)"); 274 exception 275 when Constraint_Error => null; -- Expected exception. 276 end; 277 278 begin 279 Subtest_Check_3 ((Orange => (0, others => 10), 280 Blue => (2, 3, others => 4), -- Blue not in applicable index cons. 281 others => (1, 2, 3)), 282 Test_Case => 'P'); 283 Report.Failed ("Constraint_Error not raised by aggregate choice " & 284 "index outside of applicable index constraint (P)"); 285 exception 286 when Constraint_Error => null; -- Expected exception. 287 end; 288 289 begin 290 Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)), 291 Green => (8 => 2, 4 => 3, others => 7), 292 -- 4 not in applicable index cons. 293 others => (1, 2, 3, others => Report.Ident_Int(10))), 294 Test_Case => 'Q'); 295 Report.Failed ("Constraint_Error not raised by aggregate choice " & 296 "index outside of applicable index constraint (Q)"); 297 exception 298 when Constraint_Error => null; -- Expected exception. 299 end; 300 301 Report.Result; 302 303end C433001; 304