1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . L I S T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2018-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Unchecked_Deallocation; 33 34package body GNAT.Lists is 35 36 package body Doubly_Linked_Lists is 37 procedure Delete_Node 38 (L : Doubly_Linked_List; 39 Nod : Node_Ptr); 40 pragma Inline (Delete_Node); 41 -- Detach and delete node Nod from list L 42 43 procedure Ensure_Circular (Head : Node_Ptr); 44 pragma Inline (Ensure_Circular); 45 -- Ensure that dummy head Head is circular with respect to itself 46 47 procedure Ensure_Created (L : Doubly_Linked_List); 48 pragma Inline (Ensure_Created); 49 -- Verify that list L is created. Raise Not_Created if this is not the 50 -- case. 51 52 procedure Ensure_Full (L : Doubly_Linked_List); 53 pragma Inline (Ensure_Full); 54 -- Verify that list L contains at least one element. Raise List_Empty if 55 -- this is not the case. 56 57 procedure Ensure_Unlocked (L : Doubly_Linked_List); 58 pragma Inline (Ensure_Unlocked); 59 -- Verify that list L is unlocked. Raise Iterated if this is not the 60 -- case. 61 62 function Find_Node 63 (Head : Node_Ptr; 64 Elem : Element_Type) return Node_Ptr; 65 pragma Inline (Find_Node); 66 -- Travers a list indicated by dummy head Head to determine whethe there 67 -- exists a node with element Elem. If such a node exists, return it, 68 -- otherwise return null; 69 70 procedure Free is 71 new Ada.Unchecked_Deallocation 72 (Doubly_Linked_List_Attributes, Doubly_Linked_List); 73 74 procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); 75 76 procedure Insert_Between 77 (L : Doubly_Linked_List; 78 Elem : Element_Type; 79 Left : Node_Ptr; 80 Right : Node_Ptr); 81 pragma Inline (Insert_Between); 82 -- Insert element Elem between nodes Left and Right of list L 83 84 function Is_Valid (Iter : Iterator) return Boolean; 85 pragma Inline (Is_Valid); 86 -- Determine whether iterator Iter refers to a valid element 87 88 function Is_Valid 89 (Nod : Node_Ptr; 90 Head : Node_Ptr) return Boolean; 91 pragma Inline (Is_Valid); 92 -- Determine whether node Nod is non-null and does not refer to dummy 93 -- head Head, thus making it valid. 94 95 procedure Lock (L : Doubly_Linked_List); 96 pragma Inline (Lock); 97 -- Lock all mutation functionality of list L 98 99 function Present (Nod : Node_Ptr) return Boolean; 100 pragma Inline (Present); 101 -- Determine whether node Nod exists 102 103 procedure Unlock (L : Doubly_Linked_List); 104 pragma Inline (Unlock); 105 -- Unlock all mutation functionality of list L 106 107 ------------ 108 -- Append -- 109 ------------ 110 111 procedure Append 112 (L : Doubly_Linked_List; 113 Elem : Element_Type) 114 is 115 Head : Node_Ptr; 116 117 begin 118 Ensure_Created (L); 119 Ensure_Unlocked (L); 120 121 -- Ensure that the dummy head of an empty list is circular with 122 -- respect to itself. 123 124 Head := L.Nodes'Access; 125 Ensure_Circular (Head); 126 127 -- Append the node by inserting it between the last node and the 128 -- dummy head. 129 130 Insert_Between 131 (L => L, 132 Elem => Elem, 133 Left => Head.Prev, 134 Right => Head); 135 end Append; 136 137 ------------ 138 -- Create -- 139 ------------ 140 141 function Create return Doubly_Linked_List is 142 begin 143 return new Doubly_Linked_List_Attributes; 144 end Create; 145 146 -------------- 147 -- Contains -- 148 -------------- 149 150 function Contains 151 (L : Doubly_Linked_List; 152 Elem : Element_Type) return Boolean 153 is 154 Head : Node_Ptr; 155 Nod : Node_Ptr; 156 157 begin 158 Ensure_Created (L); 159 160 Head := L.Nodes'Access; 161 Nod := Find_Node (Head, Elem); 162 163 return Is_Valid (Nod, Head); 164 end Contains; 165 166 ------------ 167 -- Delete -- 168 ------------ 169 170 procedure Delete 171 (L : Doubly_Linked_List; 172 Elem : Element_Type) 173 is 174 Head : Node_Ptr; 175 Nod : Node_Ptr; 176 177 begin 178 Ensure_Created (L); 179 Ensure_Full (L); 180 Ensure_Unlocked (L); 181 182 Head := L.Nodes'Access; 183 Nod := Find_Node (Head, Elem); 184 185 if Is_Valid (Nod, Head) then 186 Delete_Node (L, Nod); 187 end if; 188 end Delete; 189 190 ------------------ 191 -- Delete_First -- 192 ------------------ 193 194 procedure Delete_First (L : Doubly_Linked_List) is 195 Head : Node_Ptr; 196 Nod : Node_Ptr; 197 198 begin 199 Ensure_Created (L); 200 Ensure_Full (L); 201 Ensure_Unlocked (L); 202 203 Head := L.Nodes'Access; 204 Nod := Head.Next; 205 206 if Is_Valid (Nod, Head) then 207 Delete_Node (L, Nod); 208 end if; 209 end Delete_First; 210 211 ----------------- 212 -- Delete_Last -- 213 ----------------- 214 215 procedure Delete_Last (L : Doubly_Linked_List) is 216 Head : Node_Ptr; 217 Nod : Node_Ptr; 218 219 begin 220 Ensure_Created (L); 221 Ensure_Full (L); 222 Ensure_Unlocked (L); 223 224 Head := L.Nodes'Access; 225 Nod := Head.Prev; 226 227 if Is_Valid (Nod, Head) then 228 Delete_Node (L, Nod); 229 end if; 230 end Delete_Last; 231 232 ----------------- 233 -- Delete_Node -- 234 ----------------- 235 236 procedure Delete_Node 237 (L : Doubly_Linked_List; 238 Nod : Node_Ptr) 239 is 240 Ref : Node_Ptr := Nod; 241 242 pragma Assert (Present (Ref)); 243 244 Next : constant Node_Ptr := Ref.Next; 245 Prev : constant Node_Ptr := Ref.Prev; 246 247 begin 248 pragma Assert (Present (L)); 249 pragma Assert (Present (Next)); 250 pragma Assert (Present (Prev)); 251 252 Prev.Next := Next; -- Prev ---> Next 253 Next.Prev := Prev; -- Prev <--> Next 254 255 Ref.Next := null; 256 Ref.Prev := null; 257 258 L.Elements := L.Elements - 1; 259 260 -- Invoke the element destructor before deallocating the node 261 262 Destroy_Element (Nod.Elem); 263 264 Free (Ref); 265 end Delete_Node; 266 267 ------------- 268 -- Destroy -- 269 ------------- 270 271 procedure Destroy (L : in out Doubly_Linked_List) is 272 Head : Node_Ptr; 273 274 begin 275 Ensure_Created (L); 276 Ensure_Unlocked (L); 277 278 Head := L.Nodes'Access; 279 280 while Is_Valid (Head.Next, Head) loop 281 Delete_Node (L, Head.Next); 282 end loop; 283 284 Free (L); 285 end Destroy; 286 287 --------------------- 288 -- Ensure_Circular -- 289 --------------------- 290 291 procedure Ensure_Circular (Head : Node_Ptr) is 292 pragma Assert (Present (Head)); 293 294 begin 295 if not Present (Head.Next) and then not Present (Head.Prev) then 296 Head.Next := Head; 297 Head.Prev := Head; 298 end if; 299 end Ensure_Circular; 300 301 -------------------- 302 -- Ensure_Created -- 303 -------------------- 304 305 procedure Ensure_Created (L : Doubly_Linked_List) is 306 begin 307 if not Present (L) then 308 raise Not_Created; 309 end if; 310 end Ensure_Created; 311 312 ----------------- 313 -- Ensure_Full -- 314 ----------------- 315 316 procedure Ensure_Full (L : Doubly_Linked_List) is 317 begin 318 pragma Assert (Present (L)); 319 320 if L.Elements = 0 then 321 raise List_Empty; 322 end if; 323 end Ensure_Full; 324 325 --------------------- 326 -- Ensure_Unlocked -- 327 --------------------- 328 329 procedure Ensure_Unlocked (L : Doubly_Linked_List) is 330 begin 331 pragma Assert (Present (L)); 332 333 -- The list has at least one outstanding iterator 334 335 if L.Iterators > 0 then 336 raise Iterated; 337 end if; 338 end Ensure_Unlocked; 339 340 ----------- 341 -- Equal -- 342 ----------- 343 344 function Equal 345 (Left : Doubly_Linked_List; 346 Right : Doubly_Linked_List) return Boolean 347 is 348 Left_Head : Node_Ptr; 349 Left_Nod : Node_Ptr; 350 Right_Head : Node_Ptr; 351 Right_Nod : Node_Ptr; 352 353 begin 354 -- Two non-existent lists are considered equal 355 356 if Left = Nil and then Right = Nil then 357 return True; 358 359 -- A non-existent list is never equal to an already created list 360 361 elsif Left = Nil or else Right = Nil then 362 return False; 363 364 -- The two lists must contain the same number of elements to be equal 365 366 elsif Size (Left) /= Size (Right) then 367 return False; 368 end if; 369 370 -- Compare the two lists element by element 371 372 Left_Head := Left.Nodes'Access; 373 Left_Nod := Left_Head.Next; 374 Right_Head := Right.Nodes'Access; 375 Right_Nod := Right_Head.Next; 376 while Is_Valid (Left_Nod, Left_Head) 377 and then 378 Is_Valid (Right_Nod, Right_Head) 379 loop 380 if Left_Nod.Elem /= Right_Nod.Elem then 381 return False; 382 end if; 383 384 Left_Nod := Left_Nod.Next; 385 Right_Nod := Right_Nod.Next; 386 end loop; 387 388 return True; 389 end Equal; 390 391 --------------- 392 -- Find_Node -- 393 --------------- 394 395 function Find_Node 396 (Head : Node_Ptr; 397 Elem : Element_Type) return Node_Ptr 398 is 399 pragma Assert (Present (Head)); 400 401 Nod : Node_Ptr; 402 403 begin 404 -- Traverse the nodes of the list, looking for a matching element 405 406 Nod := Head.Next; 407 while Is_Valid (Nod, Head) loop 408 if Nod.Elem = Elem then 409 return Nod; 410 end if; 411 412 Nod := Nod.Next; 413 end loop; 414 415 return null; 416 end Find_Node; 417 418 ----------- 419 -- First -- 420 ----------- 421 422 function First (L : Doubly_Linked_List) return Element_Type is 423 begin 424 Ensure_Created (L); 425 Ensure_Full (L); 426 427 return L.Nodes.Next.Elem; 428 end First; 429 430 -------------- 431 -- Has_Next -- 432 -------------- 433 434 function Has_Next (Iter : Iterator) return Boolean is 435 Is_OK : constant Boolean := Is_Valid (Iter); 436 437 begin 438 -- The iterator is no longer valid which indicates that it has been 439 -- exhausted. Unlock all mutation functionality of the list because 440 -- the iterator cannot be advanced any further. 441 442 if not Is_OK then 443 Unlock (Iter.List); 444 end if; 445 446 return Is_OK; 447 end Has_Next; 448 449 ------------------ 450 -- Insert_After -- 451 ------------------ 452 453 procedure Insert_After 454 (L : Doubly_Linked_List; 455 After : Element_Type; 456 Elem : Element_Type) 457 is 458 Head : Node_Ptr; 459 Nod : Node_Ptr; 460 461 begin 462 Ensure_Created (L); 463 Ensure_Unlocked (L); 464 465 Head := L.Nodes'Access; 466 Nod := Find_Node (Head, After); 467 468 if Is_Valid (Nod, Head) then 469 Insert_Between 470 (L => L, 471 Elem => Elem, 472 Left => Nod, 473 Right => Nod.Next); 474 end if; 475 end Insert_After; 476 477 ------------------- 478 -- Insert_Before -- 479 ------------------- 480 481 procedure Insert_Before 482 (L : Doubly_Linked_List; 483 Before : Element_Type; 484 Elem : Element_Type) 485 is 486 Head : Node_Ptr; 487 Nod : Node_Ptr; 488 489 begin 490 Ensure_Created (L); 491 Ensure_Unlocked (L); 492 493 Head := L.Nodes'Access; 494 Nod := Find_Node (Head, Before); 495 496 if Is_Valid (Nod, Head) then 497 Insert_Between 498 (L => L, 499 Elem => Elem, 500 Left => Nod.Prev, 501 Right => Nod); 502 end if; 503 end Insert_Before; 504 505 -------------------- 506 -- Insert_Between -- 507 -------------------- 508 509 procedure Insert_Between 510 (L : Doubly_Linked_List; 511 Elem : Element_Type; 512 Left : Node_Ptr; 513 Right : Node_Ptr) 514 is 515 pragma Assert (Present (L)); 516 pragma Assert (Present (Left)); 517 pragma Assert (Present (Right)); 518 519 Nod : constant Node_Ptr := 520 new Node'(Elem => Elem, 521 Next => Right, -- Left Nod ---> Right 522 Prev => Left); -- Left <--- Nod ---> Right 523 524 begin 525 Left.Next := Nod; -- Left <--> Nod ---> Right 526 Right.Prev := Nod; -- Left <--> Nod <--> Right 527 528 L.Elements := L.Elements + 1; 529 end Insert_Between; 530 531 -------------- 532 -- Is_Empty -- 533 -------------- 534 535 function Is_Empty (L : Doubly_Linked_List) return Boolean is 536 begin 537 Ensure_Created (L); 538 539 return L.Elements = 0; 540 end Is_Empty; 541 542 -------------- 543 -- Is_Valid -- 544 -------------- 545 546 function Is_Valid (Iter : Iterator) return Boolean is 547 begin 548 -- The invariant of Iterate and Next ensures that the iterator always 549 -- refers to a valid node if there exists one. 550 551 return Is_Valid (Iter.Curr_Nod, Iter.List.Nodes'Access); 552 end Is_Valid; 553 554 -------------- 555 -- Is_Valid -- 556 -------------- 557 558 function Is_Valid 559 (Nod : Node_Ptr; 560 Head : Node_Ptr) return Boolean 561 is 562 begin 563 -- A node is valid if it is non-null, and does not refer to the dummy 564 -- head of some list. 565 566 return Present (Nod) and then Nod /= Head; 567 end Is_Valid; 568 569 ------------- 570 -- Iterate -- 571 ------------- 572 573 function Iterate (L : Doubly_Linked_List) return Iterator is 574 begin 575 Ensure_Created (L); 576 577 -- Lock all mutation functionality of the list while it is being 578 -- iterated on. 579 580 Lock (L); 581 582 return (List => L, Curr_Nod => L.Nodes.Next); 583 end Iterate; 584 585 ---------- 586 -- Last -- 587 ---------- 588 589 function Last (L : Doubly_Linked_List) return Element_Type is 590 begin 591 Ensure_Created (L); 592 Ensure_Full (L); 593 594 return L.Nodes.Prev.Elem; 595 end Last; 596 597 ---------- 598 -- Lock -- 599 ---------- 600 601 procedure Lock (L : Doubly_Linked_List) is 602 begin 603 pragma Assert (Present (L)); 604 605 -- The list may be locked multiple times if multiple iterators are 606 -- operating over it. 607 608 L.Iterators := L.Iterators + 1; 609 end Lock; 610 611 ---------- 612 -- Next -- 613 ---------- 614 615 procedure Next 616 (Iter : in out Iterator; 617 Elem : out Element_Type) 618 is 619 Is_OK : constant Boolean := Is_Valid (Iter); 620 Saved : constant Node_Ptr := Iter.Curr_Nod; 621 622 begin 623 -- The iterator is no linger valid which indicates that it has been 624 -- exhausted. Unlock all mutation functionality of the list as the 625 -- iterator cannot be advanced any further. 626 627 if not Is_OK then 628 Unlock (Iter.List); 629 raise Iterator_Exhausted; 630 end if; 631 632 -- Advance to the next node along the list 633 634 Iter.Curr_Nod := Iter.Curr_Nod.Next; 635 636 Elem := Saved.Elem; 637 end Next; 638 639 ------------- 640 -- Prepend -- 641 ------------- 642 643 procedure Prepend 644 (L : Doubly_Linked_List; 645 Elem : Element_Type) 646 is 647 Head : Node_Ptr; 648 649 begin 650 Ensure_Created (L); 651 Ensure_Unlocked (L); 652 653 -- Ensure that the dummy head of an empty list is circular with 654 -- respect to itself. 655 656 Head := L.Nodes'Access; 657 Ensure_Circular (Head); 658 659 -- Append the node by inserting it between the dummy head and the 660 -- first node. 661 662 Insert_Between 663 (L => L, 664 Elem => Elem, 665 Left => Head, 666 Right => Head.Next); 667 end Prepend; 668 669 ------------- 670 -- Present -- 671 ------------- 672 673 function Present (L : Doubly_Linked_List) return Boolean is 674 begin 675 return L /= Nil; 676 end Present; 677 678 ------------- 679 -- Present -- 680 ------------- 681 682 function Present (Nod : Node_Ptr) return Boolean is 683 begin 684 return Nod /= null; 685 end Present; 686 687 ------------- 688 -- Replace -- 689 ------------- 690 691 procedure Replace 692 (L : Doubly_Linked_List; 693 Old_Elem : Element_Type; 694 New_Elem : Element_Type) 695 is 696 Head : Node_Ptr; 697 Nod : Node_Ptr; 698 699 begin 700 Ensure_Created (L); 701 Ensure_Unlocked (L); 702 703 Head := L.Nodes'Access; 704 Nod := Find_Node (Head, Old_Elem); 705 706 if Is_Valid (Nod, Head) then 707 Nod.Elem := New_Elem; 708 end if; 709 end Replace; 710 711 ---------- 712 -- Size -- 713 ---------- 714 715 function Size (L : Doubly_Linked_List) return Natural is 716 begin 717 Ensure_Created (L); 718 719 return L.Elements; 720 end Size; 721 722 ------------ 723 -- Unlock -- 724 ------------ 725 726 procedure Unlock (L : Doubly_Linked_List) is 727 begin 728 pragma Assert (Present (L)); 729 730 -- The list may be locked multiple times if multiple iterators are 731 -- operating over it. 732 733 L.Iterators := L.Iterators - 1; 734 end Unlock; 735 end Doubly_Linked_Lists; 736 737end GNAT.Lists; 738