1-- { dg-do run } 2 3with Ada.Text_IO; use Ada.Text_IO; 4with GNAT; use GNAT; 5with GNAT.Sets; use GNAT.Sets; 6 7procedure Sets1 is 8 function Hash (Key : Integer) return Bucket_Range_Type; 9 10 package Integer_Sets is new Membership_Sets 11 (Element_Type => Integer, 12 "=" => "=", 13 Hash => Hash); 14 use Integer_Sets; 15 16 procedure Check_Empty 17 (Caller : String; 18 S : Membership_Set; 19 Low_Elem : Integer; 20 High_Elem : Integer); 21 -- Ensure that none of the elements in the range Low_Elem .. High_Elem are 22 -- present in set S, and that the set's length is 0. 23 24 procedure Check_Locked_Mutations 25 (Caller : String; 26 S : in out Membership_Set); 27 -- Ensure that all mutation operations of set S are locked 28 29 procedure Check_Present 30 (Caller : String; 31 S : Membership_Set; 32 Low_Elem : Integer; 33 High_Elem : Integer); 34 -- Ensure that all elements in the range Low_Elem .. High_Elem are present 35 -- in set S. 36 37 procedure Check_Unlocked_Mutations 38 (Caller : String; 39 S : in out Membership_Set); 40 -- Ensure that all mutation operations of set S are unlocked 41 42 procedure Populate 43 (S : Membership_Set; 44 Low_Elem : Integer; 45 High_Elem : Integer); 46 -- Add elements in the range Low_Elem .. High_Elem in set S 47 48 procedure Test_Contains 49 (Low_Elem : Integer; 50 High_Elem : Integer; 51 Init_Size : Positive); 52 -- Verify that Contains properly identifies that elements in the range 53 -- Low_Elem .. High_Elem are within a set. Init_Size denotes the initial 54 -- size of the set. 55 56 procedure Test_Create; 57 -- Verify that all set operations fail on a non-created set 58 59 procedure Test_Delete 60 (Low_Elem : Integer; 61 High_Elem : Integer; 62 Init_Size : Positive); 63 -- Verify that Delete properly removes elements in the range Low_Elem .. 64 -- High_Elem from a set. Init_Size denotes the initial size of the set. 65 66 procedure Test_Is_Empty; 67 -- Verify that Is_Empty properly returns this status of a set 68 69 procedure Test_Iterate; 70 -- Verify that iterators properly manipulate mutation operations 71 72 procedure Test_Iterate_Empty; 73 -- Verify that iterators properly manipulate mutation operations of an 74 -- empty set. 75 76 procedure Test_Iterate_Forced 77 (Low_Elem : Integer; 78 High_Elem : Integer; 79 Init_Size : Positive); 80 -- Verify that an iterator that is forcefully advanced by Next properly 81 -- unlocks the mutation operations of a set. Init_Size denotes the initial 82 -- size of the set. 83 84 procedure Test_Size; 85 -- Verify that Size returns the correct size of a set 86 87 ----------------- 88 -- Check_Empty -- 89 ----------------- 90 91 procedure Check_Empty 92 (Caller : String; 93 S : Membership_Set; 94 Low_Elem : Integer; 95 High_Elem : Integer) 96 is 97 Siz : constant Natural := Size (S); 98 99 begin 100 for Elem in Low_Elem .. High_Elem loop 101 if Contains (S, Elem) then 102 Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img); 103 end if; 104 end loop; 105 106 if Siz /= 0 then 107 Put_Line ("ERROR: " & Caller & ": wrong size"); 108 Put_Line ("expected: 0"); 109 Put_Line ("got :" & Siz'Img); 110 end if; 111 end Check_Empty; 112 113 ---------------------------- 114 -- Check_Locked_Mutations -- 115 ---------------------------- 116 117 procedure Check_Locked_Mutations 118 (Caller : String; 119 S : in out Membership_Set) 120 is 121 begin 122 begin 123 Delete (S, 1); 124 Put_Line ("ERROR: " & Caller & ": Delete: no exception raised"); 125 exception 126 when Iterated => 127 null; 128 when others => 129 Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception"); 130 end; 131 132 begin 133 Destroy (S); 134 Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised"); 135 exception 136 when Iterated => 137 null; 138 when others => 139 Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception"); 140 end; 141 142 begin 143 Insert (S, 1); 144 Put_Line ("ERROR: " & Caller & ": Insert: no exception raised"); 145 exception 146 when Iterated => 147 null; 148 when others => 149 Put_Line ("ERROR: " & Caller & ": Insert: unexpected exception"); 150 end; 151 end Check_Locked_Mutations; 152 153 ------------------- 154 -- Check_Present -- 155 ------------------- 156 157 procedure Check_Present 158 (Caller : String; 159 S : Membership_Set; 160 Low_Elem : Integer; 161 High_Elem : Integer) 162 is 163 Elem : Integer; 164 Iter : Iterator; 165 166 begin 167 Iter := Iterate (S); 168 for Exp_Elem in Low_Elem .. High_Elem loop 169 Next (Iter, Elem); 170 171 if Elem /= Exp_Elem then 172 Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element"); 173 Put_Line ("expected:" & Exp_Elem'Img); 174 Put_Line ("got :" & Elem'Img); 175 end if; 176 end loop; 177 178 -- At this point all elements should have been accounted for. Check for 179 -- extra elements. 180 181 while Has_Next (Iter) loop 182 Next (Iter, Elem); 183 Put_Line 184 ("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img); 185 end loop; 186 187 exception 188 when Iterator_Exhausted => 189 Put_Line 190 ("ERROR: " 191 & Caller 192 & "Check_Present: incorrect number of elements"); 193 end Check_Present; 194 195 ------------------------------ 196 -- Check_Unlocked_Mutations -- 197 ------------------------------ 198 199 procedure Check_Unlocked_Mutations 200 (Caller : String; 201 S : in out Membership_Set) 202 is 203 begin 204 Delete (S, 1); 205 Insert (S, 1); 206 end Check_Unlocked_Mutations; 207 208 ---------- 209 -- Hash -- 210 ---------- 211 212 function Hash (Key : Integer) return Bucket_Range_Type is 213 begin 214 return Bucket_Range_Type (Key); 215 end Hash; 216 217 -------------- 218 -- Populate -- 219 -------------- 220 221 procedure Populate 222 (S : Membership_Set; 223 Low_Elem : Integer; 224 High_Elem : Integer) 225 is 226 begin 227 for Elem in Low_Elem .. High_Elem loop 228 Insert (S, Elem); 229 end loop; 230 end Populate; 231 232 ------------------- 233 -- Test_Contains -- 234 ------------------- 235 236 procedure Test_Contains 237 (Low_Elem : Integer; 238 High_Elem : Integer; 239 Init_Size : Positive) 240 is 241 Low_Bogus : constant Integer := Low_Elem - 1; 242 High_Bogus : constant Integer := High_Elem + 1; 243 244 S : Membership_Set := Create (Init_Size); 245 246 begin 247 Populate (S, Low_Elem, High_Elem); 248 249 -- Ensure that the elements are contained in the set 250 251 for Elem in Low_Elem .. High_Elem loop 252 if not Contains (S, Elem) then 253 Put_Line 254 ("ERROR: Test_Contains: element" & Elem'Img & " not in set"); 255 end if; 256 end loop; 257 258 -- Ensure that arbitrary elements which were not inserted in the set are 259 -- not contained in the set. 260 261 if Contains (S, Low_Bogus) then 262 Put_Line 263 ("ERROR: Test_Contains: element" & Low_Bogus'Img & " in set"); 264 end if; 265 266 if Contains (S, High_Bogus) then 267 Put_Line 268 ("ERROR: Test_Contains: element" & High_Bogus'Img & " in set"); 269 end if; 270 271 Destroy (S); 272 end Test_Contains; 273 274 ----------------- 275 -- Test_Create -- 276 ----------------- 277 278 procedure Test_Create is 279 Count : Natural; 280 Flag : Boolean; 281 Iter : Iterator; 282 S : Membership_Set; 283 284 begin 285 -- Ensure that every routine defined in the API fails on a set which 286 -- has not been created yet. 287 288 begin 289 Flag := Contains (S, 1); 290 Put_Line ("ERROR: Test_Create: Contains: no exception raised"); 291 exception 292 when Not_Created => 293 null; 294 when others => 295 Put_Line ("ERROR: Test_Create: Contains: unexpected exception"); 296 end; 297 298 begin 299 Delete (S, 1); 300 Put_Line ("ERROR: Test_Create: Delete: no exception raised"); 301 exception 302 when Not_Created => 303 null; 304 when others => 305 Put_Line ("ERROR: Test_Create: Delete: unexpected exception"); 306 end; 307 308 begin 309 Insert (S, 1); 310 Put_Line ("ERROR: Test_Create: Insert: no exception raised"); 311 exception 312 when Not_Created => 313 null; 314 when others => 315 Put_Line ("ERROR: Test_Create: Insert: unexpected exception"); 316 end; 317 318 begin 319 Flag := Is_Empty (S); 320 Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised"); 321 exception 322 when Not_Created => 323 null; 324 when others => 325 Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception"); 326 end; 327 328 begin 329 Iter := Iterate (S); 330 Put_Line ("ERROR: Test_Create: Iterate: no exception raised"); 331 exception 332 when Not_Created => 333 null; 334 when others => 335 Put_Line ("ERROR: Test_Create: Iterate: unexpected exception"); 336 end; 337 338 begin 339 Count := Size (S); 340 Put_Line ("ERROR: Test_Create: Size: no exception raised"); 341 exception 342 when Not_Created => 343 null; 344 when others => 345 Put_Line ("ERROR: Test_Create: Size: unexpected exception"); 346 end; 347 end Test_Create; 348 349 ----------------- 350 -- Test_Delete -- 351 ----------------- 352 353 procedure Test_Delete 354 (Low_Elem : Integer; 355 High_Elem : Integer; 356 Init_Size : Positive) 357 is 358 Iter : Iterator; 359 S : Membership_Set := Create (Init_Size); 360 361 begin 362 Populate (S, Low_Elem, High_Elem); 363 364 -- Delete all even elements 365 366 for Elem in Low_Elem .. High_Elem loop 367 if Elem mod 2 = 0 then 368 Delete (S, Elem); 369 end if; 370 end loop; 371 372 -- Ensure that all remaining odd elements are present in the set 373 374 for Elem in Low_Elem .. High_Elem loop 375 if Elem mod 2 /= 0 and then not Contains (S, Elem) then 376 Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img); 377 end if; 378 end loop; 379 380 -- Delete all odd elements 381 382 for Elem in Low_Elem .. High_Elem loop 383 if Elem mod 2 /= 0 then 384 Delete (S, Elem); 385 end if; 386 end loop; 387 388 -- At this point the set should be completely empty 389 390 Check_Empty 391 (Caller => "Test_Delete", 392 S => S, 393 Low_Elem => Low_Elem, 394 High_Elem => High_Elem); 395 396 Destroy (S); 397 end Test_Delete; 398 399 ------------------- 400 -- Test_Is_Empty -- 401 ------------------- 402 403 procedure Test_Is_Empty is 404 S : Membership_Set := Create (8); 405 406 begin 407 if not Is_Empty (S) then 408 Put_Line ("ERROR: Test_Is_Empty: set is not empty"); 409 end if; 410 411 Insert (S, 1); 412 413 if Is_Empty (S) then 414 Put_Line ("ERROR: Test_Is_Empty: set is empty"); 415 end if; 416 417 Delete (S, 1); 418 419 if not Is_Empty (S) then 420 Put_Line ("ERROR: Test_Is_Empty: set is not empty"); 421 end if; 422 423 Destroy (S); 424 end Test_Is_Empty; 425 426 ------------------ 427 -- Test_Iterate -- 428 ------------------ 429 430 procedure Test_Iterate is 431 Elem : Integer; 432 Iter_1 : Iterator; 433 Iter_2 : Iterator; 434 S : Membership_Set := Create (5); 435 436 begin 437 Populate (S, 1, 5); 438 439 -- Obtain an iterator. This action must lock all mutation operations of 440 -- the set. 441 442 Iter_1 := Iterate (S); 443 444 -- Ensure that every mutation routine defined in the API fails on a set 445 -- with at least one outstanding iterator. 446 447 Check_Locked_Mutations 448 (Caller => "Test_Iterate", 449 S => S); 450 451 -- Obtain another iterator 452 453 Iter_2 := Iterate (S); 454 455 -- Ensure that every mutation is still locked 456 457 Check_Locked_Mutations 458 (Caller => "Test_Iterate", 459 S => S); 460 461 -- Exhaust the first itertor 462 463 while Has_Next (Iter_1) loop 464 Next (Iter_1, Elem); 465 end loop; 466 467 -- Ensure that every mutation is still locked 468 469 Check_Locked_Mutations 470 (Caller => "Test_Iterate", 471 S => S); 472 473 -- Exhaust the second itertor 474 475 while Has_Next (Iter_2) loop 476 Next (Iter_2, Elem); 477 end loop; 478 479 -- Ensure that all mutation operations are once again callable 480 481 Check_Unlocked_Mutations 482 (Caller => "Test_Iterate", 483 S => S); 484 485 Destroy (S); 486 end Test_Iterate; 487 488 ------------------------ 489 -- Test_Iterate_Empty -- 490 ------------------------ 491 492 procedure Test_Iterate_Empty is 493 Elem : Integer; 494 Iter : Iterator; 495 S : Membership_Set := Create (5); 496 497 begin 498 -- Obtain an iterator. This action must lock all mutation operations of 499 -- the set. 500 501 Iter := Iterate (S); 502 503 -- Ensure that every mutation routine defined in the API fails on a set 504 -- with at least one outstanding iterator. 505 506 Check_Locked_Mutations 507 (Caller => "Test_Iterate_Empty", 508 S => S); 509 510 -- Attempt to iterate over the elements 511 512 while Has_Next (Iter) loop 513 Next (Iter, Elem); 514 515 Put_Line 516 ("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists"); 517 end loop; 518 519 -- Ensure that all mutation operations are once again callable 520 521 Check_Unlocked_Mutations 522 (Caller => "Test_Iterate_Empty", 523 S => S); 524 525 Destroy (S); 526 end Test_Iterate_Empty; 527 528 ------------------------- 529 -- Test_Iterate_Forced -- 530 ------------------------- 531 532 procedure Test_Iterate_Forced 533 (Low_Elem : Integer; 534 High_Elem : Integer; 535 Init_Size : Positive) 536 is 537 Elem : Integer; 538 Iter : Iterator; 539 S : Membership_Set := Create (Init_Size); 540 541 begin 542 Populate (S, Low_Elem, High_Elem); 543 544 -- Obtain an iterator. This action must lock all mutation operations of 545 -- the set. 546 547 Iter := Iterate (S); 548 549 -- Ensure that every mutation routine defined in the API fails on a set 550 -- with at least one outstanding iterator. 551 552 Check_Locked_Mutations 553 (Caller => "Test_Iterate_Forced", 554 S => S); 555 556 -- Forcibly advance the iterator until it raises an exception 557 558 begin 559 for Guard in Low_Elem .. High_Elem + 1 loop 560 Next (Iter, Elem); 561 end loop; 562 563 Put_Line 564 ("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised"); 565 exception 566 when Iterator_Exhausted => 567 null; 568 when others => 569 Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception"); 570 end; 571 572 -- Ensure that all mutation operations are once again callable 573 574 Check_Unlocked_Mutations 575 (Caller => "Test_Iterate_Forced", 576 S => S); 577 578 Destroy (S); 579 end Test_Iterate_Forced; 580 581 --------------- 582 -- Test_Size -- 583 --------------- 584 585 procedure Test_Size is 586 S : Membership_Set := Create (6); 587 Siz : Natural; 588 589 begin 590 Siz := Size (S); 591 592 if Siz /= 0 then 593 Put_Line ("ERROR: Test_Size: wrong size"); 594 Put_Line ("expected: 0"); 595 Put_Line ("got :" & Siz'Img); 596 end if; 597 598 Populate (S, 1, 2); 599 Siz := Size (S); 600 601 if Siz /= 2 then 602 Put_Line ("ERROR: Test_Size: wrong size"); 603 Put_Line ("expected: 2"); 604 Put_Line ("got :" & Siz'Img); 605 end if; 606 607 Populate (S, 3, 6); 608 Siz := Size (S); 609 610 if Siz /= 6 then 611 Put_Line ("ERROR: Test_Size: wrong size"); 612 Put_Line ("expected: 6"); 613 Put_Line ("got :" & Siz'Img); 614 end if; 615 616 Destroy (S); 617 end Test_Size; 618 619-- Start of processing for Operations 620 621begin 622 Test_Contains 623 (Low_Elem => 1, 624 High_Elem => 5, 625 Init_Size => 5); 626 627 Test_Create; 628 629 Test_Delete 630 (Low_Elem => 1, 631 High_Elem => 10, 632 Init_Size => 10); 633 634 Test_Is_Empty; 635 Test_Iterate; 636 Test_Iterate_Empty; 637 638 Test_Iterate_Forced 639 (Low_Elem => 1, 640 High_Elem => 5, 641 Init_Size => 5); 642 643 Test_Size; 644end Sets1; 645