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