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 40with Report; 41procedure C433001 is 42 43 type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); 44 45 type Array_1 is array (Positive range <>) of Integer; 46 47 subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3)); 48 subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5)); 49 subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9)); 50 51 type Array_2 is array (Color_Type range <>) of Integer; 52 53 subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) .. 54 Color_Type'Val(Report.Ident_Int(2))); 55 -- Red .. Yellow 56 subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) .. 57 Color_Type'Val(Report.Ident_Int(6))); 58 -- Green .. Violet 59 type Array_3 is array (Color_Type range <>, Positive range <>) of Integer; 60 61 subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) .. 62 Color_Type'Val(Report.Ident_Int(2)), 63 Report.Ident_Int(3) .. Report.Ident_Int(5)); 64 -- Red .. Yellow, 3 .. 5 65 subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) .. 66 Color_Type'Val(Report.Ident_Int(3)), 67 Report.Ident_Int(6) .. Report.Ident_Int(8)); 68 -- Orange .. Green, 6 .. 8 69 70 procedure Check_1 (Obj : Array_1; Low, High : Integer; 71 First_Component, Second_Component, 72 Last_Component : Integer; 73 Test_Case : Character) is 74 begin 75 if Obj'First /= Low then 76 Report.Failed ("Low bound incorrect (" & Test_Case & ")"); 77 end if; 78 if Obj'Last /= High then 79 Report.Failed ("High bound incorrect (" & Test_Case & ")"); 80 end if; 81 if Obj(Low) /= First_Component then 82 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 83 end if; 84 if Obj(Low+1) /= Second_Component then 85 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 86 end if; 87 if Obj(High) /= Last_Component then 88 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 89 end if; 90 end Check_1; 91 92 procedure Check_2 (Obj : Array_2; Low, High : Color_Type; 93 First_Component, Second_Component, 94 Last_Component : Integer; 95 Test_Case : Character) is 96 begin 97 if Obj'First /= Low then 98 Report.Failed ("Low bound incorrect (" & Test_Case & ")"); 99 end if; 100 if Obj'Last /= High then 101 Report.Failed ("High bound incorrect (" & Test_Case & ")"); 102 end if; 103 if Obj(Low) /= First_Component then 104 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 105 end if; 106 if Obj(Color_Type'Succ(Low)) /= Second_Component then 107 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 108 end if; 109 if Obj(High) /= Last_Component then 110 Report.Failed ("First Component incorrect (" & Test_Case & ")"); 111 end if; 112 end Check_2; 113 114 procedure Check_3 (Test_Obj, Check_Obj : Array_3; 115 Low_1, High_1 : Color_Type; 116 Low_2, High_2 : Integer; 117 Test_Case : Character) is 118 begin 119 if Test_Obj'First(1) /= Low_1 then 120 Report.Failed ("Low bound for dimension 1 incorrect (" & 121 Test_Case & ")"); 122 end if; 123 if Test_Obj'Last(1) /= High_1 then 124 Report.Failed ("High bound for dimension 1 incorrect (" & 125 Test_Case & ")"); 126 end if; 127 if Test_Obj'First(2) /= Low_2 then 128 Report.Failed ("Low bound for dimension 2 incorrect (" & 129 Test_Case & ")"); 130 end if; 131 if Test_Obj'Last(2) /= High_2 then 132 Report.Failed ("High bound for dimension 2 incorrect (" & 133 Test_Case & ")"); 134 end if; 135 if Test_Obj /= Check_Obj then 136 Report.Failed ("Components incorrect (" & Test_Case & ")"); 137 end if; 138 end Check_3; 139 140 procedure Subtest_Check_1 (Obj : Sub_1_3; 141 First_Component, Second_Component, 142 Last_Component : Integer; 143 Test_Case : Character) is 144 begin 145 Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component, 146 Test_Case); 147 end Subtest_Check_1; 148 149 procedure Subtest_Check_2 (Obj : Sub_2_2; 150 First_Component, Second_Component, 151 Last_Component : Integer; 152 Test_Case : Character) is 153 begin 154 Check_2 (Obj, Green, Violet, First_Component, Second_Component, 155 Last_Component, Test_Case); 156 end Subtest_Check_2; 157 158 procedure Subtest_Check_3 (Obj : Sub_3_2; 159 Test_Case : Character) is 160 begin 161 Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case); 162 end Subtest_Check_3; 163 164begin 165 166 Report.Test ("C433001", 167 "Check that an others choice is allowed in an array " & 168 "aggregate whose applicable index constraint is dynamic. " & 169 "Also check index choices are within the applicable index " & 170 "constraint for array aggregates with others choices"); 171 172 -- Check with a qualified expression: 173 Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3, 174 First_Component => 2, Second_Component => 3, Last_Component => 4, 175 Test_Case => 'A'); 176 177 Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)), 178 Low => Red, High => Yellow, 179 First_Component => 1, Second_Component => 6, Last_Component => 6, 180 Test_Case => 'B'); 181 182 Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)), 183 Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)), 184 Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5, 185 Test_Case => 'C'); 186 187 -- Check that the others clause does not need to represent any components: 188 Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5, 189 First_Component => 5, Second_Component => 6, Last_Component => 8, 190 Test_Case => 'D'); 191 192 -- Check named choices are allowed: 193 Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8), 194 Low => 1, High => 3, 195 First_Component => 8, Second_Component => -1, Last_Component => 8, 196 Test_Case => 'E'); 197 198 -- Check named choices and formal parameters: 199 Subtest_Check_1 ((6 => 4, 8 => 86, others => 1), 200 First_Component => 1, Second_Component => 4, Last_Component => 1, 201 Test_Case => 'F'); 202 203 Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89, 204 Indigo => Report.Ident_Int(42), Blue => 0, others => -1), 205 First_Component => 88, Second_Component => 0, Last_Component => 89, 206 Test_Case => 'G'); 207 208 Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)), 209 Test_Case => 'H'); 210 211 -- Check object declarations and assignment: 212 declare 213 Var : Sub_1_2 := (4, 36, others => 86); 214 begin 215 Check_1 (Var, Low => 3, High => 5, 216 First_Component => 4, Second_Component => 36, 217 Last_Component => 86, 218 Test_Case => 'I'); 219 Var := (5 => 415, others => Report.Ident_Int(1522)); 220 Check_1 (Var, Low => 3, High => 5, 221 First_Component => 1522, Second_Component => 1522, 222 Last_Component => 415, 223 Test_Case => 'J'); 224 end; 225 226 -- Check positional aggregates that are too long: 227 begin 228 Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93), 229 First_Component => 88, Second_Component => 89, 230 Last_Component => 91, 231 Test_Case => 'K'); 232 Report.Failed ("Constraint_Error not raised by positional " & 233 "aggregate with too many choices (K)"); 234 exception 235 when Constraint_Error => null; -- Expected exception. 236 end; 237 238 begin 239 Subtest_Check_3 (((0, others => 10), (2, 3, others => 4), 240 (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)), 241 Test_Case => 'L'); 242 Report.Failed ("Constraint_Error not raised by positional " & 243 "aggregate with too many choices (L)"); 244 exception 245 when Constraint_Error => null; -- Expected exception. 246 end; 247 248 -- Check named aggregates with choices in the index subtype but not in the 249 -- applicable index constraint: 250 251 begin 252 Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89, 253 10 => 66, -- 10 not in applicable index constraint 254 others => 93), 255 First_Component => 88, Second_Component => 93, 256 Last_Component => 93, 257 Test_Case => 'M'); 258 Report.Failed ("Constraint_Error not raised by aggregate choice " & 259 "index outside of applicable index constraint (M)"); 260 exception 261 when Constraint_Error => null; -- Expected exception. 262 end; 263 264 begin 265 Subtest_Check_2 ( 266 (Yellow => 23, -- Yellow not in applicable index constraint. 267 Blue => 16, others => 77), 268 First_Component => 77, Second_Component => 16, 269 Last_Component => 77, 270 Test_Case => 'N'); 271 Report.Failed ("Constraint_Error not raised by aggregate choice " & 272 "index outside of applicable index constraint (N)"); 273 exception 274 when Constraint_Error => null; -- Expected exception. 275 end; 276 277 begin 278 Subtest_Check_3 ((Orange => (0, others => 10), 279 Blue => (2, 3, others => 4), -- Blue not in applicable index cons. 280 others => (1, 2, 3)), 281 Test_Case => 'P'); 282 Report.Failed ("Constraint_Error not raised by aggregate choice " & 283 "index outside of applicable index constraint (P)"); 284 exception 285 when Constraint_Error => null; -- Expected exception. 286 end; 287 288 begin 289 Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)), 290 Green => (8 => 2, 4 => 3, others => 7), 291 -- 4 not in applicable index cons. 292 others => (1, 2, 3, others => Report.Ident_Int(10))), 293 Test_Case => 'Q'); 294 Report.Failed ("Constraint_Error not raised by aggregate choice " & 295 "index outside of applicable index constraint (Q)"); 296 exception 297 when Constraint_Error => null; -- Expected exception. 298 end; 299 300 Report.Result; 301 302end C433001; 303