1-- Copyright 1994 Grady Booch 2-- Copyright 1994-1997 David Weller 3-- Copyright 1998-2014 Simon Wright <simon@pushface.org> 4 5-- This package is free software; you can redistribute it and/or 6-- modify it under terms of the GNU General Public License as 7-- published by the Free Software Foundation; either version 2, or 8-- (at your option) any later version. This package is distributed in 9-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without 10-- even the implied warranty of MERCHANTABILITY or FITNESS FOR A 11-- PARTICULAR PURPOSE. See the GNU General Public License for more 12-- details. You should have received a copy of the GNU General Public 13-- License distributed with this package; see file COPYING. If not, 14-- write to the Free Software Foundation, 59 Temple Place - Suite 15-- 330, Boston, MA 02111-1307, USA. 16 17-- As a special exception, if other files instantiate generics from 18-- this unit, or you link this unit with other files to produce an 19-- executable, this unit does not by itself cause the resulting 20-- executable to be covered by the GNU General Public License. This 21-- exception does not however invalidate any other reasons why the 22-- executable file might be covered by the GNU Public License. 23 24with Ada.Unchecked_Deallocation; 25with System.Address_To_Access_Conversions; 26 27package body BC.Lists.Double is 28 29 -- We can't take 'Access of non-aliased components. But if we 30 -- alias discriminated objects they become constrained - even if 31 -- the discriminant has a default. 32 package Allow_Element_Access 33 is new System.Address_To_Access_Conversions (Item); 34 35 function Create 36 (I : Item; Previous, Next : Double_Node_Ref) return Double_Node_Ref; 37 pragma Inline (Create); 38 39 function Create 40 (I : Item; Previous, Next : Double_Node_Ref) return Double_Node_Ref is 41 Result : Double_Node_Ref; 42 begin 43 Result := new Double_Node'(Element => I, 44 Previous => Previous, 45 Next => Next, 46 Count => 1); 47 if Previous /= null then 48 Previous.Next := Result; 49 end if; 50 if Next /= null then 51 Next.Previous := Result; 52 end if; 53 return Result; 54 end Create; 55 56 procedure Delete is 57 new Ada.Unchecked_Deallocation (Double_Node, Double_Node_Ref); 58 59 function "=" (L, R : List) return Boolean is 60 begin 61 return L.Rep = R.Rep; 62 end "="; 63 64 procedure Clear (L : in out List) is 65 Curr : Double_Node_Ref := L.Rep; 66 Ptr : Double_Node_Ref; 67 begin 68 while Curr /= null loop 69 Ptr := Curr; 70 Curr := Curr.Next; 71 if Ptr.Count > 1 then 72 Ptr.Count := Ptr.Count - 1; 73 exit; 74 else 75 if Curr /= null then 76 Curr.Previous := null; 77 end if; 78 Delete (Ptr); 79 end if; 80 end loop; 81 L.Rep := null; 82 end Clear; 83 84 procedure Insert (L : in out List; Elem : Item) is 85 begin 86 -- Ensure we only insert at a list's head. 87 if L.Rep /= null and then L.Rep.Previous /= null then 88 raise BC.Not_Root; 89 end if; 90 L.Rep := Create (Elem, Previous => null, Next => L.Rep); 91 end Insert; 92 93 procedure Insert (L : in out List; From_List : in out List) is 94 Ptr : Double_Node_Ref := From_List.Rep; 95 begin 96 -- Ensure we only insert at a list's head. 97 if L.Rep /= null and then L.Rep.Previous /= null then 98 raise BC.Not_Root; 99 end if; 100 if Ptr /= null then 101 while Ptr.Next /= null loop 102 Ptr := Ptr.Next; 103 end loop; 104 Ptr.Next := L.Rep; 105 if L.Rep /= null then 106 L.Rep.Previous := Ptr; 107 end if; 108 L.Rep := From_List.Rep; 109 L.Rep.Count := L.Rep.Count + 1; 110 end if; 111 end Insert; 112 113 procedure Insert (L : in out List; Elem : Item; Before : Positive) is 114 Prev : Double_Node_Ref; 115 Curr : Double_Node_Ref := L.Rep; 116 Index : Positive := 1; 117 begin 118 if Curr = null or else Before = 1 then 119 Insert (L, Elem); 120 else 121 while Curr /= null and then Index < Before loop 122 Prev := Curr; 123 Curr := Curr.Next; 124 Index := Index + 1; 125 end loop; 126 if Curr = null then 127 raise BC.Range_Error; 128 end if; 129 Prev.Next := Create (Elem, Previous => Prev, Next => Curr); 130 end if; 131 end Insert; 132 133 procedure Insert (L : in out List; 134 From_List : in out List; 135 Before : Positive) is 136 Prev : Double_Node_Ref; 137 Curr : Double_Node_Ref := L.Rep; 138 Ptr : Double_Node_Ref := From_List.Rep; 139 Index : Positive := 1; 140 begin 141 if Ptr /= null then 142 if Curr = null or else Before = 1 then 143 Insert (L, From_List); 144 else 145 -- Ensure From_List is the head of a list. 146 if Ptr.Previous /= null then 147 raise BC.Not_Root; 148 end if; 149 while Curr /= null and then Index < Before loop 150 Prev := Curr; 151 Curr := Curr.Next; 152 Index := Index + 1; 153 end loop; 154 if Curr = null then 155 raise BC.Range_Error; 156 end if; 157 while Ptr.Next /= null loop 158 Ptr := Ptr.Next; 159 end loop; 160 Ptr.Next := Curr; 161 Curr.Previous := Ptr; 162 Prev.Next := From_List.Rep; 163 From_List.Rep.Previous := Prev; 164 From_List.Rep.Count := From_List.Rep.Count + 1; 165 end if; 166 end if; 167 end Insert; 168 169 procedure Append (L : in out List; Elem : Item) is 170 Curr : Double_Node_Ref := L.Rep; 171 begin 172 if Curr /= null then 173 while Curr.Next /= null loop 174 Curr := Curr.Next; 175 end loop; 176 Curr.Next := Create (Elem, Previous => Curr, Next => null); 177 else 178 L.Rep := Create (Elem, Previous => null, Next => null); 179 end if; 180 end Append; 181 182 procedure Append (L : in out List; From_List : in out List) is 183 Curr : Double_Node_Ref := L.Rep; 184 begin 185 -- Ensure From_List is the head of a list. 186 if From_List.Rep /= null and then From_List.Rep.Previous /= null then 187 raise BC.Not_Root; 188 end if; 189 if From_List.Rep /= null then 190 if Curr /= null then 191 while Curr.Next /= null loop 192 Curr := Curr.Next; 193 end loop; 194 end if; 195 if Curr /= null then 196 Curr.Next := From_List.Rep; 197 From_List.Rep.Previous := Curr; 198 else 199 L.Rep := From_List.Rep; 200 end if; 201 From_List.Rep.Count := From_List.Rep.Count + 1; 202 end if; 203 end Append; 204 205 procedure Append (L : in out List; Elem : Item; After : Positive) is 206 Curr : Double_Node_Ref := L.Rep; 207 Index : Positive := 1; 208 begin 209 if Curr = null then 210 Append (L, Elem); 211 else 212 while Curr /= null and then Index < After loop 213 Curr := Curr.Next; 214 Index := Index + 1; 215 end loop; 216 if Curr = null then 217 raise BC.Range_Error; 218 end if; 219 Curr.Next := Create (Elem, 220 Previous => Curr, 221 Next => Curr.Next); 222 end if; 223 end Append; 224 225 procedure Append (L : in out List; 226 From_List : in out List; 227 After : Positive) is 228 Curr : Double_Node_Ref := L.Rep; 229 Ptr : Double_Node_Ref := From_List.Rep; 230 Index : Positive := 1; 231 begin 232 if Ptr /= null then 233 if Curr = null then 234 Append (L, From_List); 235 else 236 -- Ensure From_List is the head of a list. 237 -- XXX check this logic! 238 if From_List.Rep /= null and then 239 From_List.Rep.Previous /= null 240 then 241 raise BC.Not_Root; 242 end if; 243 while Curr /= null and then Index < After loop 244 Curr := Curr.Next; 245 Index := Index + 1; 246 end loop; 247 if Curr = null then 248 raise BC.Range_Error; 249 end if; 250 while Ptr.Next /= null loop 251 Ptr := Ptr.Next; 252 end loop; 253 Ptr.Next := Curr.Next; 254 if Curr.Next /= null then 255 Curr.Next.Previous := Ptr; 256 end if; 257 Curr.Next := From_List.Rep; 258 From_List.Rep.Previous := Curr; 259 From_List.Rep.Count := From_List.Rep.Count + 1; 260 end if; 261 end if; 262 end Append; 263 264 procedure Remove (L : in out List; From : Positive) is 265 Prev : Double_Node_Ref; 266 Curr : Double_Node_Ref := L.Rep; 267 Index : Positive := 1; 268 begin 269 while Curr /= null and then Index < From loop 270 Prev := Curr; 271 Curr := Curr.Next; 272 Index := Index + 1; 273 end loop; 274 if Curr = null then 275 raise BC.Range_Error; 276 end if; 277 -- Ensure we're not removing an aliased element. 278 if Curr.Count /= 1 then 279 raise BC.Referenced; 280 end if; 281 if Prev /= null then 282 Prev.Next := Curr.Next; 283 else 284 L.Rep := Curr.Next; 285 end if; 286 if Curr.Next /= null then 287 Curr.Next.Previous := Prev; 288 end if; 289 if Curr.Count > 1 then 290 Curr.Count := Curr.Count - 1; 291 else 292 Delete (Curr); 293 end if; 294 end Remove; 295 296 procedure Purge (L : in out List; From : Positive) is 297 Prev : Double_Node_Ref; 298 Curr : Double_Node_Ref := L.Rep; 299 Ptr : Double_Node_Ref; 300 Index : Positive := 1; 301 begin 302 while Curr /= null and then Index < From loop 303 Prev := Curr; 304 Curr := Curr.Next; 305 Index := Index + 1; 306 end loop; 307 if Curr = null then 308 raise BC.Range_Error; 309 end if; 310 if Prev /= null then 311 Prev.Next := null; 312 else 313 L.Rep := null; 314 end if; 315 while Curr /= null loop 316 Curr.Previous := null; 317 Ptr := Curr; 318 Curr := Curr.Next; 319 if Ptr.Count > 1 then 320 Ptr.Count := Ptr.Count - 1; 321 exit; 322 else 323 Delete (Ptr); 324 end if; 325 end loop; 326 end Purge; 327 328 procedure Purge (L : in out List; From : Positive; Count : Positive) is 329 Prev, Ptr : Double_Node_Ref; 330 Curr : Double_Node_Ref := L.Rep; 331 Index : Positive := 1; 332 Shared_Node_Found : Boolean := False; 333 begin 334 while Curr /= null and then Index < From loop 335 Prev := Curr; 336 Curr := Curr.Next; 337 Index := Index + 1; 338 end loop; 339 if Curr = null then 340 raise BC.Range_Error; 341 end if; 342 if Prev /= null then 343 Prev.Next := null; 344 else 345 L.Rep := null; 346 end if; 347 Index := 1; 348 while Curr /= null and then Index <= Count loop 349 Ptr := Curr; 350 Curr := Curr.Next; 351 if not Shared_Node_Found then 352 if Ptr.Count > 1 then 353 Ptr.Count := Ptr.Count - 1; 354 Shared_Node_Found := True; 355 else 356 if Curr /= null then 357 Curr.Previous := null; 358 Delete (Ptr); 359 end if; 360 end if; 361 end if; 362 Index := Index + 1; 363 end loop; 364 if Shared_Node_Found then 365 Ptr.Next := null; 366 end if; 367 if Curr /= null then 368 Curr.Previous := Prev; 369 if Prev /= null then 370 Prev.Next := Curr; 371 else 372 L.Rep := Curr; 373 end if; 374 end if; 375 end Purge; 376 377 procedure Preserve (L : in out List; From : Positive) is 378 Temp : List; 379 begin 380 Share (Temp, L, From); 381 Share_Head (L, Temp); 382 end Preserve; 383 384 procedure Preserve (L : in out List; 385 From : Positive; 386 Count : Positive) is 387 begin 388 Preserve (L, From); 389 if Length (L) > Count then 390 Purge (L, Count + 1); -- we start at 1, remember! 391 end if; 392 end Preserve; 393 394 procedure Share (L : in out List; 395 With_List : List; 396 Starting_At : Positive) is 397 Ptr : Double_Node_Ref := With_List.Rep; 398 Index : Positive := 1; 399 begin 400 if Ptr = null then 401 raise BC.Is_Null; 402 end if; 403 while Ptr /= null and then Index < Starting_At loop 404 Ptr := Ptr.Next; 405 Index := Index + 1; 406 end loop; 407 if Ptr = null then 408 raise BC.Range_Error; 409 end if; 410 Clear (L); 411 L.Rep := Ptr; 412 L.Rep.Count := L.Rep.Count + 1; 413 end Share; 414 415 procedure Share_Head (L : in out List; With_List : in List) is 416 begin 417 if With_List.Rep = null then 418 raise BC.Is_Null; 419 end if; 420 Clear (L); 421 L.Rep := With_List.Rep; 422 L.Rep.Count := L.Rep.Count + 1; 423 end Share_Head; 424 425 procedure Share_Foot (L : in out List; With_List : in List) is 426 Ptr : Double_Node_Ref := With_List.Rep; 427 begin 428 if Ptr = null then 429 raise BC.Is_Null; 430 end if; 431 Clear (L); 432 while Ptr.Next /= null loop 433 Ptr := Ptr.Next; 434 end loop; 435 L.Rep := Ptr; 436 L.Rep.Count := L.Rep.Count + 1; 437 end Share_Foot; 438 439 procedure Swap_Tail (L : in out List; With_List : in out List) is 440 Curr : Double_Node_Ref; 441 begin 442 if L.Rep = null then 443 raise BC.Is_Null; 444 end if; 445 if With_List.Rep /= null and then With_List.Rep.Previous /= null then 446 raise BC.Not_Root; 447 end if; 448 Curr := L.Rep.Next; 449 L.Rep.Next := With_List.Rep; 450 With_List.Rep.Previous := L.Rep; 451 With_List.Rep := Curr; 452 if With_List.Rep /= null then 453 With_List.Rep.Previous := null; 454 end if; 455 end Swap_Tail; 456 457 procedure Tail (L : in out List) is 458 Curr : Double_Node_Ref := L.Rep; 459 begin 460 if L.Rep = null then 461 raise BC.Is_Null; 462 end if; 463 L.Rep := L.Rep.Next; 464 if L.Rep /= null then 465 L.Rep.Count := L.Rep.Count + 1; 466 end if; 467 if Curr.Count > 1 then 468 Curr.Count := Curr.Count - 1; 469 else 470 if L.Rep /= null then 471 L.Rep.Count := L.Rep.Count - 1; 472 L.Rep.Previous := null; 473 end if; 474 Delete (Curr); 475 end if; 476 end Tail; 477 478 procedure Predecessor (L : in out List) is 479 begin 480 if L.Rep = null then 481 raise BC.Is_Null; 482 end if; 483 if L.Rep.Previous = null then 484 Clear (L); 485 else 486 L.Rep.Count := L.Rep.Count - 1; 487 L.Rep := L.Rep.Previous; 488 L.Rep.Count := L.Rep.Count + 1; 489 end if; 490 end Predecessor; 491 492 procedure Set_Head (L : in out List; Elem : Item) is 493 begin 494 if L.Rep = null then 495 raise BC.Is_Null; 496 end if; 497 L.Rep.Element := Elem; 498 end Set_Head; 499 500 procedure Set_Item (L : in out List; Elem : Item; At_Loc : Positive) is 501 Curr : Double_Node_Ref := L.Rep; 502 Index : Positive := 1; 503 begin 504 while Curr /= null and then Index < At_Loc loop 505 Curr := Curr.Next; 506 Index := Index + 1; 507 end loop; 508 if Curr = null then 509 raise BC.Range_Error; 510 end if; 511 Curr.Element := Elem; 512 end Set_Item; 513 514 function Length (L : List) return Natural is 515 Curr : Double_Node_Ref := L.Rep; 516 Count : Natural := 0; 517 begin 518 while Curr /= null loop 519 Curr := Curr.Next; 520 Count := Count + 1; 521 end loop; 522 return Count; 523 end Length; 524 525 function Is_Null (L : List) return Boolean is 526 begin 527 return L.Rep = null; 528 end Is_Null; 529 530 function Is_Shared (L : List) return Boolean is 531 begin 532 if L.Rep /= null then 533 return L.Rep.Count > 1; 534 else 535 return False; 536 end if; 537 end Is_Shared; 538 539 function Is_Head (L : List) return Boolean is 540 begin 541 return L.Rep = null or else L.Rep.Previous = null; 542 end Is_Head; 543 544 function Head (L : List) return Item is 545 begin 546 if L.Rep = null then 547 raise BC.Is_Null; 548 end if; 549 return L.Rep.Element; 550 end Head; 551 552 procedure Process_Head (L : in out List) is 553 begin 554 if L.Rep = null then 555 raise BC.Is_Null; 556 end if; 557 Process (L.Rep.Element); 558 end Process_Head; 559 560 function Foot (L : List) return Item is 561 Curr : Double_Node_Ref := L.Rep; 562 begin 563 if L.Rep = null then 564 raise BC.Is_Null; 565 end if; 566 while Curr.Next /= null loop 567 Curr := Curr.Next; 568 end loop; 569 return Curr.Element; 570 end Foot; 571 572 procedure Process_Foot (L : in out List) is 573 Curr : Double_Node_Ref := L.Rep; 574 begin 575 if L.Rep = null then 576 raise BC.Is_Null; 577 end if; 578 while Curr.Next /= null loop 579 Curr := Curr.Next; 580 end loop; 581 Process (Curr.Element); 582 end Process_Foot; 583 584 function Item_At (L : List; Index : Positive) return Item is 585 begin 586 return Item_At (L, Index).all; 587 end Item_At; 588 589 package Address_Conversions 590 is new System.Address_To_Access_Conversions (List); 591 592 function New_Iterator (For_The_List : List) return Iterator'Class is 593 Result : List_Iterator; 594 begin 595 Result.For_The_List := 596 List_Base_Ptr (Address_Conversions.To_Pointer (For_The_List'Address)); 597 Reset (Result); 598 return Result; 599 end New_Iterator; 600 601 function Item_At (L : List; Index : Positive) return Item_Ptr is 602 Curr : Double_Node_Ref := L.Rep; 603 Loc : Positive := 1; 604 begin 605 if L.Rep = null then 606 raise BC.Is_Null; 607 end if; 608 while Curr /= null and then Loc < Index loop 609 Curr := Curr.Next; 610 Loc := Loc + 1; 611 end loop; 612 if Curr = null then 613 raise BC.Range_Error; 614 end if; 615 if Curr = null then 616 raise BC.Range_Error; 617 end if; 618 return Item_Ptr 619 (Allow_Element_Access.To_Pointer (Curr.Element'Address)); 620 end Item_At; 621 622 procedure Initialize (L : in out List) is 623 pragma Warnings (Off, L); 624 begin 625 null; 626 end Initialize; 627 628 procedure Adjust (L : in out List) is 629 begin 630 if L.Rep /= null then 631 L.Rep.Count := L.Rep.Count + 1; 632 end if; 633 end Adjust; 634 635 procedure Finalize (L : in out List) is 636 begin 637 Clear (L); 638 end Finalize; 639 640 procedure Reset (It : in out List_Iterator) is 641 L : List'Class renames List'Class (It.For_The_List.all); 642 begin 643 It.Index := L.Rep; 644 end Reset; 645 646 procedure Next (It : in out List_Iterator) is 647 begin 648 if It.Index /= null then 649 It.Index := It.Index.Next; 650 end if; 651 end Next; 652 653 function Is_Done (It : List_Iterator) return Boolean is 654 begin 655 return It.Index = null; 656 end Is_Done; 657 658 function Current_Item (It : List_Iterator) return Item is 659 begin 660 if Is_Done (It) then 661 raise BC.Not_Found; 662 end if; 663 return It.Index.Element; 664 end Current_Item; 665 666 function Current_Item_Ptr (It : List_Iterator) return Item_Ptr is 667 begin 668 if Is_Done (It) then 669 raise BC.Not_Found; 670 end if; 671 return Item_Ptr 672 (Allow_Element_Access.To_Pointer (It.Index.Element'Address)); 673 end Current_Item_Ptr; 674 675 procedure Delete_Item_At (It : in out List_Iterator) is 676 L : List'Class renames List'Class (It.For_The_List.all); 677 Prev : Double_Node_Ref; 678 Curr : Double_Node_Ref := L.Rep; 679 begin 680 if Is_Done (It) then 681 raise BC.Not_Found; 682 end if; 683 while Curr /= null and then Curr /= It.Index loop 684 Prev := Curr; 685 Curr := Curr.Next; 686 end loop; 687 if Curr = null then 688 raise BC.Range_Error; 689 end if; 690 -- we need a writable version of the Iterator 691 declare 692 package Conversions is new System.Address_To_Access_Conversions 693 (List_Iterator'Class); 694 P : constant Conversions.Object_Pointer 695 := Conversions.To_Pointer (It'Address); 696 begin 697 P.Index := Curr.Next; 698 end; 699 if Prev /= null then 700 Prev.Next := Curr.Next; 701 else 702 L.Rep := Curr.Next; 703 end if; 704 if Curr.Next /= null then 705 Curr.Next.Previous := Prev; 706 end if; 707 if Curr.Count > 1 then 708 Curr.Count := Curr.Count - 1; 709 else 710 Delete (Curr); 711 end if; 712 end Delete_Item_At; 713 714end BC.Lists.Double; 715