1-- C371003.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- 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 if a discriminant constraint depends on a discriminant, 28-- the evaluation of the expressions in the constraint is deferred 29-- until an object of the subtype is created. Check for cases of 30-- records where the component containing the constraint is present 31-- in the subtype. 32-- 33-- TEST DESCRIPTION: 34-- This transition test defines record types with discriminant components 35-- which depend on the discriminants. The discriminants are calculated 36-- by function calls. The test verifies that Constraint_Error is raised 37-- during the object creations when values of discriminants are 38-- incompatible with the subtypes. Also check for cases, where the 39-- component is absent. 40-- 41-- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA. 42-- 43-- 44-- CHANGE HISTORY: 45-- 10 Apr 96 SAIC Initial version for ACVC 2.1. 46-- 14 Jul 96 SAIC Modified test description. Added exception handler 47-- for VObj_10 assignment. 48-- 26 Oct 96 SAIC Added LM references. 49-- 50--! 51 52with Report; 53 54procedure C371003 is 55 56 subtype Small_Int is Integer range 1..10; 57 58 type Rec_W_Disc (Disc1, Disc2 : Small_Int) is 59 record 60 Str1 : String (1 .. Disc1) := (others => '*'); 61 Str2 : String (1 .. Disc2) := (others => '*'); 62 end record; 63 64 type My_Array is array (Small_Int range <>) of Integer; 65 66 Func1_Cons : Integer := 0; 67 68 --------------------------------------------------------- 69 function Chk (Cons : Integer; 70 Value : Integer; 71 Message : String) return Boolean is 72 begin 73 if Cons /= Value then 74 Report.Failed (Message & ": Func1_Cons is " & 75 Integer'Image(Func1_Cons)); 76 end if; 77 return True; 78 end Chk; 79 80 --------------------------------------------------------- 81 function Func1 return Integer is 82 begin 83 Func1_Cons := Func1_Cons + Report.Ident_Int(1); 84 return Func1_Cons; 85 end Func1; 86 87 88begin 89 Report.Test ("C371003", "Check that if a discriminant constraint " & 90 "depends on a discriminant, the evaluation of the " & 91 "expressions in the constraint is deferred until " & 92 "object declarations"); 93 94 --------------------------------------------------------- 95 declare 96 type VRec_01 (D3 : Integer) is 97 record 98 case D3 is 99 when -5..10 => 100 C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. 101 when others => 102 C2 : Integer := Report.Ident_Int(0); 103 end case; 104 end record; 105 106 Chk1 : Boolean := Chk (Func1_Cons, 1, 107 "Func1 not evaluated for VRec_01"); 108 109 VObj_1 : VRec_01(1); -- Func1 not evaluated again 110 VObj_2 : VRec_01(2); -- Func1 not evaluated again 111 112 Chk2 : Boolean := Chk (Func1_Cons, 1, 113 "Func1 evaluated too many times"); 114 115 begin 116 if VObj_1 /= (D3 => 1, 117 C1 => (Disc1 => 1, 118 Disc2 => 1, 119 Str1 => (others => '*'), 120 Str2 => (others => '*'))) or 121 VObj_2 /= (D3 => 2, 122 C1 => (Disc1 => 2, 123 Disc2 => 1, 124 Str1 => (others => '*'), 125 Str2 => (others => '*'))) then 126 Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct"); 127 end if; 128 end; 129 130 --------------------------------------------------------- 131 Func1_Cons := -11; 132 133 declare 134 type VRec_Of_VRec_01 (D3 : Integer) is 135 record 136 case D3 is 137 when -5..10 => 138 C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10. 139 when others => -- Constraint_Error not raised. 140 C2 : Integer := Report.Ident_Int(0); 141 end case; 142 end record; 143 144 type VRec_Of_VRec_02 (D3 : Integer) is 145 record 146 case D3 is 147 when -5..10 => 148 C1 : Rec_W_Disc (1, D3); 149 when others => 150 C2 : Integer := Report.Ident_Int(0); 151 end case; 152 end record; 153 154 type VRec_Of_MyArr_01 (D3 : Integer) is 155 record 156 case D3 is 157 when -5..10 => 158 C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9. 159 when others => -- Constraint_Error not raised. 160 C2 : Integer := Report.Ident_Int(0); 161 end case; 162 end record; 163 164 type VRec_Of_MyArr_02 (D3 : Integer) is 165 record 166 case D3 is 167 when -5..10 => 168 C1 : My_Array (D3..1); 169 when others => 170 C2 : Integer := Report.Ident_Int(0); 171 end case; 172 end record; 173 174 begin 175 176 --------------------------------------------------------- 177 -- Component containing the constraint is present. 178 begin 179 declare 180 VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised. 181 begin 182 Report.Failed ("VObj_3 - Constraint_Error should be raised"); 183 if VObj_3 /= (1, (1, 1, others => (others => '*'))) then 184 Report.Comment ("VObj_3 - Shouldn't get here"); 185 end if; 186 end; 187 188 exception 189 when Constraint_Error => -- Exception expected. 190 null; 191 when others => 192 Report.Failed ("VObj_3 - unexpected exception raised"); 193 end; 194 195 --------------------------------------------------------- 196 -- Component containing the constraint is present. 197 begin 198 declare 199 subtype Subtype_VRec is -- No Constraint_Error raised. 200 VRec_Of_VRec_01(Report.Ident_Int(1)); 201 begin 202 declare 203 VObj_4 : Subtype_VRec; -- Constraint_Error raised. 204 begin 205 Report.Failed ("VObj_4 - Constraint_Error should be raised"); 206 if VObj_4 /= (D3 => 1, 207 C1 => (Disc1 => 1, 208 Disc2 => 1, 209 Str1 => (others => '*'), 210 Str2 => (others => '*'))) then 211 Report.Comment ("VObj_4 - Shouldn't get here"); 212 end if; 213 end; 214 215 exception 216 when Constraint_Error => -- Exception expected. 217 null; 218 when others => 219 Report.Failed ("VObj_4 - unexpected exception raised"); 220 end; 221 222 exception 223 when Constraint_Error => 224 Report.Failed ("Subtype_VRec - Constraint_Error raised"); 225 when others => 226 Report.Failed ("Subtype_VRec - unexpected exception raised"); 227 end; 228 229 --------------------------------------------------------- 230 -- Component containing the constraint is absent. 231 begin 232 declare 233 type Arr is array (1..5) of 234 VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error 235 VObj_5 : Arr; -- for either declaration. 236 237 begin 238 if VObj_5 /= (1 .. 5 => (-6, 0)) then 239 Report.Comment ("VObj_5 - wrong values"); 240 end if; 241 end; 242 243 exception 244 when others => 245 Report.Failed ("Arr - unexpected exception raised"); 246 end; 247 248 --------------------------------------------------------- 249 -- Component containing the constraint is present. 250 begin 251 declare 252 type Rec_Of_Rec_Of_MyArr is 253 record 254 C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised. 255 end record; 256 begin 257 declare 258 Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. 259 begin 260 Report.Failed ("Obj_6 - Constraint_Error should be raised"); 261 if Obj_6 /= (C1 => (1, (1, 1))) then 262 Report.Comment ("Obj_6 - Shouldn't get here"); 263 end if; 264 end; 265 266 exception 267 when Constraint_Error => -- Exception expected. 268 null; 269 when others => 270 Report.Failed ("Obj_6 - unexpected exception raised"); 271 end; 272 273 exception 274 when Constraint_Error => 275 Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); 276 when others => 277 Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " & 278 "raised"); 279 end; 280 281 --------------------------------------------------------- 282 -- Component containing the constraint is absent. 283 begin 284 declare 285 type New_VRec_Arr is 286 new VRec_Of_MyArr_01(11); -- No Constraint_Error raised 287 Obj_7 : New_VRec_Arr; -- for either declaration. 288 289 begin 290 if Obj_7 /= (11, 0) then 291 Report.Failed ("Obj_7 - value incorrect"); 292 end if; 293 end; 294 295 exception 296 when others => 297 Report.Failed ("New_VRec_Arr - unexpected exception raised"); 298 end; 299 300 --------------------------------------------------------- 301 -- Component containing the constraint is present. 302 begin 303 declare 304 type New_VRec is new 305 VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error 306 -- raised. 307 begin 308 declare 309 VObj_8 : New_VRec; -- Constraint_Error raised. 310 begin 311 Report.Failed ("VObj_8 - Constraint_Error should be raised"); 312 if VObj_8 /= (1, (1, 1, others => (others => '*'))) then 313 Report.Comment ("VObj_8 - Shouldn't get here"); 314 end if; 315 end; 316 317 exception 318 when Constraint_Error => -- Exception expected. 319 null; 320 when others => 321 Report.Failed ("VObj_8 - unexpected exception raised"); 322 end; 323 324 exception 325 when Constraint_Error => 326 Report.Failed ("New_VRec - Constraint_Error raised"); 327 when others => 328 Report.Failed ("New_VRec - unexpected exception raised"); 329 end; 330 331 --------------------------------------------------------- 332 -- Component containing the constraint is absent. 333 begin 334 declare 335 subtype Sub_VRec is 336 VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error 337 VObj_9 : Sub_VRec; -- raised for either 338 -- declaration. 339 begin 340 if VObj_9 /= (11, 0) then 341 Report.Comment ("VObj_9 - wrong values"); 342 end if; 343 end; 344 345 exception 346 when others => 347 Report.Failed ("Sub_VRec - unexpected exception raised"); 348 end; 349 350 --------------------------------------------------------- 351 -- Component containing the constraint is present. 352 begin 353 declare 354 type Acc_VRec_01 is access 355 VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error 356 -- raised. 357 begin 358 declare 359 VObj_10 : Acc_VRec_01; -- No Constraint_Error 360 -- raised. 361 begin 362 VObj_10 := new VRec_Of_VRec_02 363 (Report.Ident_Int(0)); -- Constraint_Error 364 -- raised. 365 Report.Failed ("VObj_10 - Constraint_Error should be raised"); 366 if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then 367 Report.Comment ("VObj_10 - Shouldn't get here"); 368 end if; 369 370 exception 371 when Constraint_Error => -- Exception expected. 372 null; 373 when others => 374 Report.Failed ("VObj_10 - unexpected exception raised"); 375 end; 376 377 exception 378 when Constraint_Error => 379 Report.Failed ("VObj_10 - Constraint_Error exception raised"); 380 when others => 381 Report.Failed ("VObj_10 - unexpected exception raised at " & 382 "declaration"); 383 end; 384 385 exception 386 when Constraint_Error => 387 Report.Failed ("Acc_VRec_01 - Constraint_Error raised"); 388 when others => 389 Report.Failed ("Acc_VRec_01 - unexpected exception raised"); 390 end; 391 392 --------------------------------------------------------- 393 -- Component containing the constraint is absent. 394 begin 395 declare 396 type Acc_VRec_02 is access 397 VRec_Of_VRec_02(11); -- No Constraint_Error 398 -- raised for either 399 VObj_11 : Acc_VRec_02; -- declaration. 400 401 begin 402 VObj_11 := new VRec_Of_VRec_02(11); 403 if VObj_11.all /= (11, 0) then 404 Report.Comment ("VObj_11 - wrong values"); 405 end if; 406 end; 407 408 exception 409 when others => 410 Report.Failed ("Acc_VRec_02 - unexpected exception raised"); 411 end; 412 413 --------------------------------------------------------- 414 -- Component containing the constraint is present. 415 begin 416 declare 417 type Acc_VRec_03 is access 418 VRec_Of_MyArr_02; -- No Constraint_Error 419 -- raised for either 420 VObj_12 : Acc_VRec_03; -- declaration. 421 begin 422 VObj_12 := new VRec_Of_MyArr_02 423 (Report.Ident_Int(0)); -- Constraint_Error raised. 424 425 Report.Failed ("VObj_12 - Constraint_Error should be raised"); 426 if VObj_12.all /= (1, (1, 1)) then 427 Report.Comment ("VObj_12 - Shouldn't get here"); 428 end if; 429 430 exception 431 when Constraint_Error => -- Exception expected. 432 null; 433 when others => 434 Report.Failed ("VObj_12 - unexpected exception raised"); 435 end; 436 437 exception 438 when Constraint_Error => 439 Report.Failed ("Acc_VRec_03 - Constraint_Error raised"); 440 when others => 441 Report.Failed ("Acc_VRec_03 - unexpected exception raised"); 442 end; 443 444 --------------------------------------------------------- 445 -- Component containing the constraint is absent. 446 begin 447 declare 448 type Acc_VRec_04 is access 449 VRec_Of_MyArr_02(11); -- No Constraint_Error 450 -- raised for either 451 VObj_13 : Acc_VRec_04; -- declaration. 452 453 begin 454 VObj_13 := new VRec_Of_MyArr_02(11); 455 if VObj_13.all /= (11, 0) then 456 Report.Comment ("VObj_13 - wrong values"); 457 end if; 458 end; 459 460 exception 461 when others => 462 Report.Failed ("Acc_VRec_04 - unexpected exception raised"); 463 end; 464 465 end; 466 467 Report.Result; 468 469exception 470 when others => 471 Report.Failed ("Discriminant value checked too soon"); 472 Report.Result; 473 474end C371003; 475