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_List is 37 procedure Delete_Node (L : Instance; Nod : Node_Ptr); 38 pragma Inline (Delete_Node); 39 -- Detach and delete node Nod from list L 40 41 procedure Ensure_Circular (Head : Node_Ptr); 42 pragma Inline (Ensure_Circular); 43 -- Ensure that dummy head Head is circular with respect to itself 44 45 procedure Ensure_Created (L : Instance); 46 pragma Inline (Ensure_Created); 47 -- Verify that list L is created. Raise Not_Created if this is not the 48 -- case. 49 50 procedure Ensure_Full (L : Instance); 51 pragma Inline (Ensure_Full); 52 -- Verify that list L contains at least one element. Raise List_Empty if 53 -- this is not the case. 54 55 procedure Ensure_Unlocked (L : Instance); 56 pragma Inline (Ensure_Unlocked); 57 -- Verify that list L is unlocked. Raise Iterated if this is not the 58 -- case. 59 60 function Find_Node 61 (Head : Node_Ptr; 62 Elem : Element_Type) return Node_Ptr; 63 pragma Inline (Find_Node); 64 -- Travers a list indicated by dummy head Head to determine whethe there 65 -- exists a node with element Elem. If such a node exists, return it, 66 -- otherwise return null; 67 68 procedure Free is new Ada.Unchecked_Deallocation (Linked_List, Instance); 69 70 procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); 71 72 procedure Insert_Between 73 (L : Instance; 74 Elem : Element_Type; 75 Left : Node_Ptr; 76 Right : Node_Ptr); 77 pragma Inline (Insert_Between); 78 -- Insert element Elem between nodes Left and Right of list L 79 80 function Is_Valid (Iter : Iterator) return Boolean; 81 pragma Inline (Is_Valid); 82 -- Determine whether iterator Iter refers to a valid element 83 84 function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; 85 pragma Inline (Is_Valid); 86 -- Determine whether node Nod is non-null and does not refer to dummy 87 -- head Head, thus making it valid. 88 89 procedure Lock (L : Instance); 90 pragma Inline (Lock); 91 -- Lock all mutation functionality of list L 92 93 procedure Unlock (L : Instance); 94 pragma Inline (Unlock); 95 -- Unlock all mutation functionality of list L 96 97 ------------ 98 -- Append -- 99 ------------ 100 101 procedure Append (L : Instance; Elem : Element_Type) is 102 Head : Node_Ptr; 103 104 begin 105 Ensure_Created (L); 106 Ensure_Unlocked (L); 107 108 -- Ensure that the dummy head of an empty list is circular with 109 -- respect to itself. 110 111 Head := L.Nodes'Access; 112 Ensure_Circular (Head); 113 114 -- Append the node by inserting it between the last node and the 115 -- dummy head. 116 117 Insert_Between 118 (L => L, 119 Elem => Elem, 120 Left => Head.Prev, 121 Right => Head); 122 end Append; 123 124 ------------ 125 -- Create -- 126 ------------ 127 128 function Create return Instance is 129 begin 130 return new Linked_List; 131 end Create; 132 133 -------------- 134 -- Contains -- 135 -------------- 136 137 function Contains (L : Instance; Elem : Element_Type) return Boolean is 138 Head : Node_Ptr; 139 Nod : Node_Ptr; 140 141 begin 142 Ensure_Created (L); 143 144 Head := L.Nodes'Access; 145 Nod := Find_Node (Head, Elem); 146 147 return Is_Valid (Nod, Head); 148 end Contains; 149 150 ------------ 151 -- Delete -- 152 ------------ 153 154 procedure Delete (L : Instance; Elem : Element_Type) is 155 Head : Node_Ptr; 156 Nod : Node_Ptr; 157 158 begin 159 Ensure_Created (L); 160 Ensure_Full (L); 161 Ensure_Unlocked (L); 162 163 Head := L.Nodes'Access; 164 Nod := Find_Node (Head, Elem); 165 166 if Is_Valid (Nod, Head) then 167 Delete_Node (L, Nod); 168 end if; 169 end Delete; 170 171 ------------------ 172 -- Delete_First -- 173 ------------------ 174 175 procedure Delete_First (L : Instance) is 176 Head : Node_Ptr; 177 Nod : Node_Ptr; 178 179 begin 180 Ensure_Created (L); 181 Ensure_Full (L); 182 Ensure_Unlocked (L); 183 184 Head := L.Nodes'Access; 185 Nod := Head.Next; 186 187 if Is_Valid (Nod, Head) then 188 Delete_Node (L, Nod); 189 end if; 190 end Delete_First; 191 192 ----------------- 193 -- Delete_Last -- 194 ----------------- 195 196 procedure Delete_Last (L : Instance) is 197 Head : Node_Ptr; 198 Nod : Node_Ptr; 199 200 begin 201 Ensure_Created (L); 202 Ensure_Full (L); 203 Ensure_Unlocked (L); 204 205 Head := L.Nodes'Access; 206 Nod := Head.Prev; 207 208 if Is_Valid (Nod, Head) then 209 Delete_Node (L, Nod); 210 end if; 211 end Delete_Last; 212 213 ----------------- 214 -- Delete_Node -- 215 ----------------- 216 217 procedure Delete_Node (L : Instance; Nod : Node_Ptr) is 218 Ref : Node_Ptr := Nod; 219 220 pragma Assert (Ref /= null); 221 222 Next : constant Node_Ptr := Ref.Next; 223 Prev : constant Node_Ptr := Ref.Prev; 224 225 begin 226 pragma Assert (L /= null); 227 pragma Assert (Next /= null); 228 pragma Assert (Prev /= null); 229 230 Prev.Next := Next; -- Prev ---> Next 231 Next.Prev := Prev; -- Prev <--> Next 232 233 Ref.Next := null; 234 Ref.Prev := null; 235 236 L.Elements := L.Elements - 1; 237 238 Free (Ref); 239 end Delete_Node; 240 241 ------------- 242 -- Destroy -- 243 ------------- 244 245 procedure Destroy (L : in out Instance) is 246 Head : Node_Ptr; 247 248 begin 249 Ensure_Created (L); 250 Ensure_Unlocked (L); 251 252 Head := L.Nodes'Access; 253 254 while Is_Valid (Head.Next, Head) loop 255 Delete_Node (L, Head.Next); 256 end loop; 257 258 Free (L); 259 end Destroy; 260 261 --------------------- 262 -- Ensure_Circular -- 263 --------------------- 264 265 procedure Ensure_Circular (Head : Node_Ptr) is 266 pragma Assert (Head /= null); 267 268 begin 269 if Head.Next = null and then Head.Prev = null then 270 Head.Next := Head; 271 Head.Prev := Head; 272 end if; 273 end Ensure_Circular; 274 275 -------------------- 276 -- Ensure_Created -- 277 -------------------- 278 279 procedure Ensure_Created (L : Instance) is 280 begin 281 if L = null then 282 raise Not_Created; 283 end if; 284 end Ensure_Created; 285 286 ----------------- 287 -- Ensure_Full -- 288 ----------------- 289 290 procedure Ensure_Full (L : Instance) is 291 begin 292 pragma Assert (L /= null); 293 294 if L.Elements = 0 then 295 raise List_Empty; 296 end if; 297 end Ensure_Full; 298 299 --------------------- 300 -- Ensure_Unlocked -- 301 --------------------- 302 303 procedure Ensure_Unlocked (L : Instance) is 304 begin 305 pragma Assert (L /= null); 306 307 -- The list has at least one outstanding iterator 308 309 if L.Iterators > 0 then 310 raise Iterated; 311 end if; 312 end Ensure_Unlocked; 313 314 --------------- 315 -- Find_Node -- 316 --------------- 317 318 function Find_Node 319 (Head : Node_Ptr; 320 Elem : Element_Type) return Node_Ptr 321 is 322 pragma Assert (Head /= null); 323 324 Nod : Node_Ptr; 325 326 begin 327 -- Traverse the nodes of the list, looking for a matching element 328 329 Nod := Head.Next; 330 while Is_Valid (Nod, Head) loop 331 if Nod.Elem = Elem then 332 return Nod; 333 end if; 334 335 Nod := Nod.Next; 336 end loop; 337 338 return null; 339 end Find_Node; 340 341 ----------- 342 -- First -- 343 ----------- 344 345 function First (L : Instance) return Element_Type is 346 begin 347 Ensure_Created (L); 348 Ensure_Full (L); 349 350 return L.Nodes.Next.Elem; 351 end First; 352 353 -------------- 354 -- Has_Next -- 355 -------------- 356 357 function Has_Next (Iter : Iterator) return Boolean is 358 Is_OK : constant Boolean := Is_Valid (Iter); 359 360 begin 361 -- The iterator is no longer valid which indicates that it has been 362 -- exhausted. Unlock all mutation functionality of the list because 363 -- the iterator cannot be advanced any further. 364 365 if not Is_OK then 366 Unlock (Iter.List); 367 end if; 368 369 return Is_OK; 370 end Has_Next; 371 372 ------------------ 373 -- Insert_After -- 374 ------------------ 375 376 procedure Insert_After 377 (L : Instance; 378 After : Element_Type; 379 Elem : Element_Type) 380 is 381 Head : Node_Ptr; 382 Nod : Node_Ptr; 383 384 begin 385 Ensure_Created (L); 386 Ensure_Unlocked (L); 387 388 Head := L.Nodes'Access; 389 Nod := Find_Node (Head, After); 390 391 if Is_Valid (Nod, Head) then 392 Insert_Between 393 (L => L, 394 Elem => Elem, 395 Left => Nod, 396 Right => Nod.Next); 397 end if; 398 end Insert_After; 399 400 ------------------- 401 -- Insert_Before -- 402 ------------------- 403 404 procedure Insert_Before 405 (L : Instance; 406 Before : Element_Type; 407 Elem : Element_Type) 408 is 409 Head : Node_Ptr; 410 Nod : Node_Ptr; 411 412 begin 413 Ensure_Created (L); 414 Ensure_Unlocked (L); 415 416 Head := L.Nodes'Access; 417 Nod := Find_Node (Head, Before); 418 419 if Is_Valid (Nod, Head) then 420 Insert_Between 421 (L => L, 422 Elem => Elem, 423 Left => Nod.Prev, 424 Right => Nod); 425 end if; 426 end Insert_Before; 427 428 -------------------- 429 -- Insert_Between -- 430 -------------------- 431 432 procedure Insert_Between 433 (L : Instance; 434 Elem : Element_Type; 435 Left : Node_Ptr; 436 Right : Node_Ptr) 437 is 438 pragma Assert (L /= null); 439 pragma Assert (Left /= null); 440 pragma Assert (Right /= null); 441 442 Nod : constant Node_Ptr := 443 new Node'(Elem => Elem, 444 Next => Right, -- Left Nod ---> Right 445 Prev => Left); -- Left <--- Nod ---> Right 446 447 begin 448 Left.Next := Nod; -- Left <--> Nod ---> Right 449 Right.Prev := Nod; -- Left <--> Nod <--> Right 450 451 L.Elements := L.Elements + 1; 452 end Insert_Between; 453 454 -------------- 455 -- Is_Empty -- 456 -------------- 457 458 function Is_Empty (L : Instance) return Boolean is 459 begin 460 Ensure_Created (L); 461 462 return L.Elements = 0; 463 end Is_Empty; 464 465 -------------- 466 -- Is_Valid -- 467 -------------- 468 469 function Is_Valid (Iter : Iterator) return Boolean is 470 begin 471 -- The invariant of Iterate and Next ensures that the iterator always 472 -- refers to a valid node if there exists one. 473 474 return Is_Valid (Iter.Nod, Iter.List.Nodes'Access); 475 end Is_Valid; 476 477 -------------- 478 -- Is_Valid -- 479 -------------- 480 481 function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is 482 begin 483 -- A node is valid if it is non-null, and does not refer to the dummy 484 -- head of some list. 485 486 return Nod /= null and then Nod /= Head; 487 end Is_Valid; 488 489 ------------- 490 -- Iterate -- 491 ------------- 492 493 function Iterate (L : Instance) return Iterator is 494 begin 495 Ensure_Created (L); 496 497 -- Lock all mutation functionality of the list while it is being 498 -- iterated on. 499 500 Lock (L); 501 502 return (List => L, Nod => L.Nodes.Next); 503 end Iterate; 504 505 ---------- 506 -- Last -- 507 ---------- 508 509 function Last (L : Instance) return Element_Type is 510 begin 511 Ensure_Created (L); 512 Ensure_Full (L); 513 514 return L.Nodes.Prev.Elem; 515 end Last; 516 517 ---------- 518 -- Lock -- 519 ---------- 520 521 procedure Lock (L : Instance) is 522 begin 523 pragma Assert (L /= null); 524 525 -- The list may be locked multiple times if multiple iterators are 526 -- operating over it. 527 528 L.Iterators := L.Iterators + 1; 529 end Lock; 530 531 ---------- 532 -- Next -- 533 ---------- 534 535 procedure Next (Iter : in out Iterator; Elem : out Element_Type) is 536 Is_OK : constant Boolean := Is_Valid (Iter); 537 Saved : constant Node_Ptr := Iter.Nod; 538 539 begin 540 -- The iterator is no linger valid which indicates that it has been 541 -- exhausted. Unlock all mutation functionality of the list as the 542 -- iterator cannot be advanced any further. 543 544 if not Is_OK then 545 Unlock (Iter.List); 546 raise Iterator_Exhausted; 547 end if; 548 549 -- Advance to the next node along the list 550 551 Iter.Nod := Iter.Nod.Next; 552 Elem := Saved.Elem; 553 end Next; 554 555 ------------- 556 -- Prepend -- 557 ------------- 558 559 procedure Prepend (L : Instance; Elem : Element_Type) is 560 Head : Node_Ptr; 561 562 begin 563 Ensure_Created (L); 564 Ensure_Unlocked (L); 565 566 -- Ensure that the dummy head of an empty list is circular with 567 -- respect to itself. 568 569 Head := L.Nodes'Access; 570 Ensure_Circular (Head); 571 572 -- Append the node by inserting it between the dummy head and the 573 -- first node. 574 575 Insert_Between 576 (L => L, 577 Elem => Elem, 578 Left => Head, 579 Right => Head.Next); 580 end Prepend; 581 582 ------------- 583 -- Replace -- 584 ------------- 585 586 procedure Replace 587 (L : Instance; 588 Old_Elem : Element_Type; 589 New_Elem : Element_Type) 590 is 591 Head : Node_Ptr; 592 Nod : Node_Ptr; 593 594 begin 595 Ensure_Created (L); 596 Ensure_Unlocked (L); 597 598 Head := L.Nodes'Access; 599 Nod := Find_Node (Head, Old_Elem); 600 601 if Is_Valid (Nod, Head) then 602 Nod.Elem := New_Elem; 603 end if; 604 end Replace; 605 606 ---------- 607 -- Size -- 608 ---------- 609 610 function Size (L : Instance) return Natural is 611 begin 612 Ensure_Created (L); 613 614 return L.Elements; 615 end Size; 616 617 ------------ 618 -- Unlock -- 619 ------------ 620 621 procedure Unlock (L : Instance) is 622 begin 623 pragma Assert (L /= null); 624 625 -- The list may be locked multiple times if multiple iterators are 626 -- operating over it. 627 628 L.Iterators := L.Iterators - 1; 629 end Unlock; 630 end Doubly_Linked_List; 631 632end GNAT.Lists; 633