1-- C371002.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 until 29-- an object of the subtype is created. Check for cases of records. 30-- 31-- TEST DESCRIPTION: 32-- This transition test defines record types with discriminant components 33-- which depend on the discriminants. The discriminants are calculated 34-- by function calls. The test verifies that Constraint_Error is raised 35-- during the object creations when values of discriminants are 36-- incompatible with the subtypes. 37-- 38-- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA. 39-- 40-- 41-- CHANGE HISTORY: 42-- 05 Apr 96 SAIC Initial version for ACVC 2.1. 43-- 44--! 45 46with Report; 47 48procedure C371002 is 49 50 subtype Small_Int is Integer range 1..10; 51 52 type Rec_W_Disc (Disc1, Disc2 : Small_Int) is 53 record 54 Str1 : String (1 .. Disc1) := (others => '*'); 55 Str2 : String (1 .. Disc2) := (others => '*'); 56 end record; 57 58 type My_Array is array (Small_Int range <>) of Integer; 59 60 Func1_Cons : Integer := 0; 61 62 --------------------------------------------------------- 63 function Chk (Cons : Integer; 64 Value : Integer; 65 Message : String) return Boolean is 66 begin 67 if Cons /= Value then 68 Report.Failed (Message & ": Func1_Cons is " & 69 Integer'Image(Func1_Cons)); 70 end if; 71 return True; 72 end Chk; 73 74 --------------------------------------------------------- 75 function Func1 return Integer is 76 begin 77 Func1_Cons := Func1_Cons + Report.Ident_Int(1); 78 return Func1_Cons; 79 end Func1; 80 81begin 82 Report.Test ("C371002", "Check that if a discriminant constraint " & 83 "depends on a discriminant, the evaluation of the " & 84 "expressions in the constraint is deferred until " & 85 "object declarations"); 86 87 --------------------------------------------------------- 88 declare 89 type Rec1 (D3 : Integer) is 90 record 91 C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. 92 end record; 93 94 Chk1 : Boolean := Chk (Func1_Cons, 1, 95 "Func1 not evaluated for Rec1"); 96 97 Obj1 : Rec1 (1); -- Func1 not evaluated again. 98 Obj2 : Rec1 (2); -- Func1 not evaluated again. 99 100 Chk2 : Boolean := Chk (Func1_Cons, 1, 101 "Func1 evaluated too many times"); 102 begin 103 if Obj1 /= (D3 => 1, 104 C1 => (Disc1 => 1, 105 Disc2 => 1, 106 Str1 => (others => '*'), 107 Str2 => (others => '*'))) or 108 Obj2 /= (D3 => 2, 109 C1 => (Disc1 => 2, 110 Disc2 => 1, 111 Str1 => (others => '*'), 112 Str2 => (others => '*'))) then 113 Report.Failed ("Obj1 & Obj2 - Discriminant values not correct"); 114 end if; 115 end; 116 117 --------------------------------------------------------- 118 Func1_Cons := -11; 119 120 declare 121 type Rec_Of_Rec_01 (D3 : Integer) is 122 record 123 C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10. 124 end record; -- Constraint_Error not raised. 125 126 type Rec_Of_MyArr_01 (D3 : Integer) is 127 record 128 C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9. 129 end record; -- Constraint_Error not raised. 130 131 type Rec_Of_Rec_02 (D3 : Integer) is 132 record 133 C1 : Rec_W_Disc (D3, 1); 134 end record; 135 136 type Rec_Of_MyArr_02 (D3 : Integer) is 137 record 138 C1 : My_Array (D3 .. 1); 139 end record; 140 141 begin 142 143 --------------------------------------------------------- 144 begin 145 declare 146 Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised. 147 begin 148 Report.Failed ("Obj3 - Constraint_Error should be raised"); 149 if Obj3 /= (1, (1, 1, others => (others => '*'))) then 150 Report.Comment ("Obj3 - Shouldn't get here"); 151 end if; 152 end; 153 154 exception 155 when Constraint_Error => -- Exception expected. 156 null; 157 when others => 158 Report.Failed ("Obj3 - others exception raised"); 159 end; 160 161 --------------------------------------------------------- 162 begin 163 declare 164 subtype Subtype_Rec is Rec_Of_Rec_01(1); 165 -- No Constraint_Error raised. 166 begin 167 declare 168 Obj4 : Subtype_Rec; -- Constraint_Error raised. 169 begin 170 Report.Failed ("Obj4 - Constraint_Error should be raised"); 171 if Obj4 /= (D3 => 1, 172 C1 => (Disc1 => 1, 173 Disc2 => 1, 174 Str1 => (others => '*'), 175 Str2 => (others => '*'))) then 176 Report.Comment ("Obj4 - Shouldn't get here"); 177 end if; 178 end; 179 180 exception 181 when Constraint_Error => -- Exception expected. 182 null; 183 when others => 184 Report.Failed ("Obj4 - others exception raised"); 185 end; 186 187 exception 188 when Constraint_Error => 189 Report.Failed ("Subtype_Rec - Constraint_Error raised"); 190 when others => 191 Report.Failed ("Subtype_Rec - others exception raised"); 192 end; 193 194 --------------------------------------------------------- 195 begin 196 declare 197 type Arr is array (1..5) -- No Constraint_Error raised. 198 of Rec_Of_Rec_01(1); 199 200 begin 201 declare 202 Obj5 : Arr; -- Constraint_Error raised. 203 begin 204 Report.Failed ("Obj5 - Constraint_Error should be raised"); 205 if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then 206 Report.Comment ("Obj5 - Shouldn't get here"); 207 end if; 208 end; 209 210 exception 211 when Constraint_Error => -- Exception expected. 212 null; 213 when others => 214 Report.Failed ("Obj5 - others exception raised"); 215 end; 216 217 exception 218 when Constraint_Error => 219 Report.Failed ("Arr - Constraint_Error raised"); 220 when others => 221 Report.Failed ("Arr - others exception raised"); 222 end; 223 224 --------------------------------------------------------- 225 begin 226 declare 227 type Rec_Of_Rec_Of_MyArr is 228 record 229 C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised. 230 end record; 231 begin 232 declare 233 Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. 234 begin 235 Report.Failed ("Obj6 - Constraint_Error should be raised"); 236 if Obj6 /= (C1 => (1, (1, 1))) then 237 Report.Comment ("Obj6 - Shouldn't get here"); 238 end if; 239 end; 240 241 exception 242 when Constraint_Error => -- Exception expected. 243 null; 244 when others => 245 Report.Failed ("Obj6 - others exception raised"); 246 end; 247 248 exception 249 when Constraint_Error => 250 Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); 251 when others => 252 Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised"); 253 end; 254 255 --------------------------------------------------------- 256 begin 257 declare 258 type New_Rec is 259 new Rec_Of_MyArr_01(1); -- No Constraint_Error raised. 260 261 begin 262 declare 263 Obj7 : New_Rec; -- Constraint_Error raised. 264 begin 265 Report.Failed ("Obj7 - Constraint_Error should be raised"); 266 if Obj7 /= (1, (1, 1)) then 267 Report.Comment ("Obj7 - Shouldn't get here"); 268 end if; 269 end; 270 271 exception 272 when Constraint_Error => -- Exception expected. 273 null; 274 when others => 275 Report.Failed ("Obj7 - others exception raised"); 276 end; 277 278 exception 279 when Constraint_Error => 280 Report.Failed ("New_Rec - Constraint_Error raised"); 281 when others => 282 Report.Failed ("New_Rec - others exception raised"); 283 end; 284 285 --------------------------------------------------------- 286 begin 287 declare 288 type Acc_Rec is 289 access Rec_Of_Rec_02 (Report.Ident_Int(0)); 290 -- No Constraint_Error raised. 291 begin 292 declare 293 Obj8 : Acc_Rec; -- No Constraint_Error raised. 294 295 begin 296 Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0)); 297 -- Constraint_Error raised. 298 299 Report.Failed ("Obj8 - Constraint_Error should be raised"); 300 if Obj8.all /= (D3 => 1, 301 C1 => (Disc1 => 1, 302 Disc2 => 1, 303 Str1 => (others => '*'), 304 Str2 => (others => '*'))) then 305 Report.Comment ("Obj8 - Shouldn't get here"); 306 end if; 307 end; 308 309 exception 310 when Constraint_Error => -- Exception expected. 311 null; 312 when others => 313 Report.Failed ("Obj8 - others exception raised"); 314 end; 315 316 exception 317 when Constraint_Error => 318 Report.Failed ("Acc_Rec - Constraint_Error raised"); 319 when others => 320 Report.Failed ("Acc_Rec - others exception raised"); 321 end; 322 323 --------------------------------------------------------- 324 begin 325 declare 326 type Acc_Rec_MyArr is access 327 Rec_Of_MyArr_02; -- No Constraint_Error 328 -- raised for either 329 Obj9 : Acc_Rec_MyArr; -- declaration. 330 331 begin 332 Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0)); 333 -- Constraint_Error raised. 334 335 Report.Failed ("Obj9 - Constraint_Error should be raised"); 336 337 if Obj9.all /= (1, (1, 1)) then 338 Report.Comment ("Obj9 - Shouldn't get here"); 339 end if; 340 341 exception 342 when Constraint_Error => -- Exception expected. 343 null; 344 when others => 345 Report.Failed ("Obj9 - others exception raised"); 346 end; 347 348 exception 349 when Constraint_Error => 350 Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised"); 351 when others => 352 Report.Failed ("Acc_Rec_MyArr - others exception raised"); 353 end; 354 355 end; 356 357 Report.Result; 358 359exception 360 when others => 361 Report.Failed ("Discriminant value checked too soon"); 362 Report.Result; 363 364end C371002; 365