1-- C380004.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 ACAA 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 per-object expressions are evaluated as specified for entry 28-- families and protected components. (Defect Report 8652/0002, 29-- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and 30-- 9.5.2(22/1)). 31-- 32-- CHANGE HISTORY: 33-- 9 FEB 2001 PHL Initial version. 34-- 29 JUN 2002 RLB Readied for release. 35-- 36--! 37with Report; 38use Report; 39procedure C380004 is 40 41 type Rec (D1, D2 : Positive) is 42 record 43 null; 44 end record; 45 46 F1_Poe : Integer; 47 48 function Chk (Poe : Integer; Value : Integer; Message : String) 49 return Boolean is 50 begin 51 if Poe /= Value then 52 Failed (Message & ": Poe is " & Integer'Image (Poe)); 53 end if; 54 return True; 55 end Chk; 56 57 function F1 return Integer is 58 begin 59 F1_Poe := F1_Poe - Ident_Int (1); 60 return F1_Poe; 61 end F1; 62 63 generic 64 type T is limited private; 65 with function Is_Ok (X : T; 66 Param1 : Integer; 67 Param2 : Integer; 68 Param3 : Integer) return Boolean; 69 procedure Check; 70 71 procedure Check is 72 begin 73 74 declare 75 type Poe is new T; 76 Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated"); 77 X : Poe; -- F1 evaluated 78 Y : Poe; -- F1 evaluated 79 Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated"); 80 begin 81 if not Is_Ok (T (X), 16, 16, 17) or 82 not Is_Ok (T (Y), 15, 15, 17) then 83 Failed ("Discriminant values not correct - 0"); 84 end if; 85 end; 86 87 declare 88 type Poe is new T; 89 begin 90 begin 91 declare 92 X : Poe; 93 begin 94 if not Is_Ok (T (X), 14, 14, 17) then 95 Failed ("Discriminant values not correct - 1"); 96 end if; 97 end; 98 exception 99 when others => 100 Failed ("Unexpected exception - 1"); 101 end; 102 103 declare 104 type Acc_Poe is access Poe; 105 X : Acc_Poe; 106 begin 107 X := new Poe; 108 begin 109 if not Is_Ok (T (X.all), 13, 13, 17) then 110 Failed ("Discriminant values not correct - 2"); 111 end if; 112 end; 113 exception 114 when others => 115 Failed ("Unexpected exception raised - 2"); 116 end; 117 118 declare 119 subtype Spoe is Poe; 120 X : Spoe; 121 begin 122 if not Is_Ok (T (X), 12, 12, 17) then 123 Failed ("Discriminant values not correct - 3"); 124 end if; 125 exception 126 when others => 127 Failed ("Unexpected exception raised - 3"); 128 end; 129 130 declare 131 type Arr is array (1 .. 2) of Poe; 132 X : Arr; 133 begin 134 if Is_Ok (T (X (1)), 11, 11, 17) and then 135 Is_Ok (T (X (2)), 10, 10, 17) then 136 null; 137 elsif Is_Ok (T (X (2)), 11, 11, 17) and then 138 Is_Ok (T (X (1)), 10, 10, 17) then 139 null; 140 else 141 Failed ("Discriminant values not correct - 4"); 142 end if; 143 exception 144 when others => 145 Failed ("Unexpected exception raised - 4"); 146 end; 147 148 declare 149 type Nrec is 150 record 151 C1, C2 : Poe; 152 end record; 153 X : Nrec; 154 begin 155 if Is_Ok (T (X.C1), 8, 8, 17) and then 156 Is_Ok (T (X.C2), 9, 9, 17) then 157 null; 158 elsif Is_Ok (T (X.C2), 8, 8, 17) and then 159 Is_Ok (T (X.C1), 9, 9, 17) then 160 null; 161 else 162 Failed ("Discriminant values not correct - 5"); 163 end if; 164 exception 165 when others => 166 Failed ("Unexpected exception raised - 5"); 167 end; 168 169 declare 170 type Drec is new Poe; 171 X : Drec; 172 begin 173 if not Is_Ok (T (X), 7, 7, 17) then 174 Failed ("Discriminant values not correct - 6"); 175 end if; 176 exception 177 when others => 178 Failed ("Unexpected exception raised - 6"); 179 end; 180 end; 181 end Check; 182 183 184begin 185 Test ("C380004", 186 "Check evaluation of discriminant expressions " & 187 "when the constraint depends on a discriminant, " & 188 "and the discriminants have defaults - discriminant-dependent" & 189 "entry families and protected components"); 190 191 192 Comment ("Discriminant-dependent entry families for task types"); 193 194 F1_Poe := 18; 195 196 declare 197 task type Poe (D3 : Positive := F1) is 198 entry E (D3 .. F1); -- F1 evaluated 199 entry Is_Ok (D3 : Integer; 200 E_First : Integer; 201 E_Last : Integer; 202 Ok : out Boolean); 203 end Poe; 204 task body Poe is 205 begin 206 loop 207 select 208 accept Is_Ok (D3 : Integer; 209 E_First : Integer; 210 E_Last : Integer; 211 Ok : out Boolean) do 212 declare 213 Cnt : Natural; 214 begin 215 if Poe.D3 = D3 then 216 -- Can't think of a better way to check the 217 -- bounds of the entry family. 218 begin 219 Cnt := E (E_First)'Count; 220 Cnt := E (E_Last)'Count; 221 exception 222 when Constraint_Error => 223 Ok := False; 224 return; 225 end; 226 begin 227 Cnt := E (E_First - 1)'Count; 228 Ok := False; 229 return; 230 exception 231 when Constraint_Error => 232 null; 233 when others => 234 Ok := False; 235 return; 236 end; 237 begin 238 Cnt := E (E_Last + 1)'Count; 239 Ok := False; 240 return; 241 exception 242 when Constraint_Error => 243 null; 244 when others => 245 Ok := False; 246 return; 247 end; 248 Ok := True; 249 else 250 Ok := False; 251 return; 252 end if; 253 end; 254 end Is_Ok; 255 or 256 terminate; 257 end select; 258 end loop; 259 end Poe; 260 261 function Is_Ok 262 (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) 263 return Boolean is 264 Ok : Boolean; 265 begin 266 C.Is_Ok (D3, E_First, E_Last, Ok); 267 return Ok; 268 end Is_Ok; 269 270 procedure Chk is new Check (Poe, Is_Ok); 271 272 begin 273 Chk; 274 end; 275 276 277 Comment ("Discriminant-dependent entry families for protected types"); 278 279 F1_Poe := 18; 280 281 declare 282 protected type Poe (D3 : Integer := F1) is 283 entry E (D3 .. F1); -- F1 evaluated 284 function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) 285 return Boolean; 286 end Poe; 287 protected body Poe is 288 entry E (for I in D3 .. F1) when True is 289 begin 290 null; 291 end E; 292 function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) 293 return Boolean is 294 Cnt : Natural; 295 begin 296 if Poe.D3 = D3 then 297 -- Can't think of a better way to check the 298 -- bounds of the entry family. 299 begin 300 Cnt := E (E_First)'Count; 301 Cnt := E (E_Last)'Count; 302 exception 303 when Constraint_Error => 304 return False; 305 end; 306 begin 307 Cnt := E (E_First - 1)'Count; 308 return False; 309 exception 310 when Constraint_Error => 311 null; 312 when others => 313 return False; 314 end; 315 begin 316 Cnt := E (E_Last + 1)'Count; 317 return False; 318 exception 319 when Constraint_Error => 320 null; 321 when others => 322 return False; 323 end; 324 return True; 325 else 326 return False; 327 end if; 328 end Is_Ok; 329 end Poe; 330 331 function Is_Ok 332 (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) 333 return Boolean is 334 begin 335 return C.Is_Ok (D3, E_First, E_Last); 336 end Is_Ok; 337 338 procedure Chk is new Check (Poe, Is_Ok); 339 340 begin 341 Chk; 342 end; 343 344 Comment ("Protected components"); 345 346 F1_Poe := 18; 347 348 declare 349 protected type Poe (D3 : Integer := F1) is 350 function C1_D1 return Integer; 351 function C1_D2 return Integer; 352 private 353 C1 : Rec (D3, F1); -- F1 evaluated 354 end Poe; 355 protected body Poe is 356 function C1_D1 return Integer is 357 begin 358 return C1.D1; 359 end C1_D1; 360 function C1_D2 return Integer is 361 begin 362 return C1.D2; 363 end C1_D2; 364 end Poe; 365 366 function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) 367 return Boolean is 368 begin 369 return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; 370 end Is_Ok; 371 372 procedure Chk is new Check (Poe, Is_Ok); 373 374 begin 375 Chk; 376 end; 377 378 Result; 379 380exception 381 when others => 382 Failed ("Unexpected exception"); 383 Result; 384 385end C380004; 386