1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- N L I S T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 32-- WARNING: There is a C version of this package. Any changes to this source 33-- file must be properly reflected in the corresponding C header a-nlists.h 34 35with Alloc; 36with Atree; use Atree; 37with Debug; use Debug; 38with Output; use Output; 39with Sinfo; use Sinfo; 40with Table; 41 42package body Nlists is 43 44 use Atree_Private_Part; 45 -- Get access to Nodes table 46 47 ---------------------------------- 48 -- Implementation of Node Lists -- 49 ---------------------------------- 50 51 -- A node list is represented by a list header which contains 52 -- three fields: 53 54 type List_Header is record 55 First : Node_Or_Entity_Id; 56 -- Pointer to first node in list. Empty if list is empty 57 58 Last : Node_Or_Entity_Id; 59 -- Pointer to last node in list. Empty if list is empty 60 61 Parent : Node_Id; 62 -- Pointer to parent of list. Empty if list has no parent 63 end record; 64 65 -- The node lists are stored in a table indexed by List_Id values 66 67 package Lists is new Table.Table ( 68 Table_Component_Type => List_Header, 69 Table_Index_Type => List_Id'Base, 70 Table_Low_Bound => First_List_Id, 71 Table_Initial => Alloc.Lists_Initial, 72 Table_Increment => Alloc.Lists_Increment, 73 Table_Name => "Lists"); 74 75 -- The nodes in the list all have the In_List flag set, and their Link 76 -- fields (which otherwise point to the parent) contain the List_Id of 77 -- the list header giving immediate access to the list containing the 78 -- node, and its parent and first and last elements. 79 80 -- Two auxiliary tables, indexed by Node_Id values and built in parallel 81 -- with the main nodes table and always having the same size contain the 82 -- list link values that allow locating the previous and next node in a 83 -- list. The entries in these tables are valid only if the In_List flag 84 -- is set in the corresponding node. Next_Node is Empty at the end of a 85 -- list and Prev_Node is Empty at the start of a list. 86 87 package Next_Node is new Table.Table ( 88 Table_Component_Type => Node_Or_Entity_Id, 89 Table_Index_Type => Node_Or_Entity_Id'Base, 90 Table_Low_Bound => First_Node_Id, 91 Table_Initial => Alloc.Orig_Nodes_Initial, 92 Table_Increment => Alloc.Orig_Nodes_Increment, 93 Table_Name => "Next_Node"); 94 95 package Prev_Node is new Table.Table ( 96 Table_Component_Type => Node_Or_Entity_Id, 97 Table_Index_Type => Node_Or_Entity_Id'Base, 98 Table_Low_Bound => First_Node_Id, 99 Table_Initial => Alloc.Orig_Nodes_Initial, 100 Table_Increment => Alloc.Orig_Nodes_Increment, 101 Table_Name => "Prev_Node"); 102 103 ----------------------- 104 -- Local Subprograms -- 105 ----------------------- 106 107 procedure Set_First (List : List_Id; To : Node_Or_Entity_Id); 108 pragma Inline (Set_First); 109 -- Sets First field of list header List to reference To 110 111 procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id); 112 pragma Inline (Set_Last); 113 -- Sets Last field of list header List to reference To 114 115 procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id); 116 pragma Inline (Set_List_Link); 117 -- Sets list link of Node to list header To 118 119 procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); 120 pragma Inline (Set_Next); 121 -- Sets the Next_Node pointer for Node to reference To 122 123 procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); 124 pragma Inline (Set_Prev); 125 -- Sets the Prev_Node pointer for Node to reference To 126 127 -------------------------- 128 -- Allocate_List_Tables -- 129 -------------------------- 130 131 procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is 132 Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last; 133 134 begin 135 pragma Assert (N >= Old_Last); 136 Next_Node.Set_Last (N); 137 Prev_Node.Set_Last (N); 138 139 -- Make sure we have no uninitialized junk in any new entires added. 140 -- This ensures that Tree_Gen will not write out any uninitialized junk. 141 142 for J in Old_Last + 1 .. N loop 143 Next_Node.Table (J) := Empty; 144 Prev_Node.Table (J) := Empty; 145 end loop; 146 end Allocate_List_Tables; 147 148 ------------ 149 -- Append -- 150 ------------ 151 152 procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is 153 L : constant Node_Or_Entity_Id := Last (To); 154 155 procedure Append_Debug; 156 pragma Inline (Append_Debug); 157 -- Output debug information if Debug_Flag_N set 158 159 ------------------ 160 -- Append_Debug -- 161 ------------------ 162 163 procedure Append_Debug is 164 begin 165 if Debug_Flag_N then 166 Write_Str ("Append node "); 167 Write_Int (Int (Node)); 168 Write_Str (" to list "); 169 Write_Int (Int (To)); 170 Write_Eol; 171 end if; 172 end Append_Debug; 173 174 -- Start of processing for Append 175 176 begin 177 pragma Assert (not Is_List_Member (Node)); 178 179 if Node = Error then 180 return; 181 end if; 182 183 pragma Debug (Append_Debug); 184 185 if No (L) then 186 Set_First (To, Node); 187 else 188 Set_Next (L, Node); 189 end if; 190 191 Set_Last (To, Node); 192 193 Nodes.Table (Node).In_List := True; 194 195 Set_Next (Node, Empty); 196 Set_Prev (Node, L); 197 Set_List_Link (Node, To); 198 end Append; 199 200 ----------------- 201 -- Append_List -- 202 ----------------- 203 204 procedure Append_List (List : List_Id; To : List_Id) is 205 206 procedure Append_List_Debug; 207 pragma Inline (Append_List_Debug); 208 -- Output debug information if Debug_Flag_N set 209 210 ----------------------- 211 -- Append_List_Debug -- 212 ----------------------- 213 214 procedure Append_List_Debug is 215 begin 216 if Debug_Flag_N then 217 Write_Str ("Append list "); 218 Write_Int (Int (List)); 219 Write_Str (" to list "); 220 Write_Int (Int (To)); 221 Write_Eol; 222 end if; 223 end Append_List_Debug; 224 225 -- Start of processing for Append_List 226 227 begin 228 if Is_Empty_List (List) then 229 return; 230 231 else 232 declare 233 L : constant Node_Or_Entity_Id := Last (To); 234 F : constant Node_Or_Entity_Id := First (List); 235 N : Node_Or_Entity_Id; 236 237 begin 238 pragma Debug (Append_List_Debug); 239 240 N := F; 241 loop 242 Set_List_Link (N, To); 243 N := Next (N); 244 exit when No (N); 245 end loop; 246 247 if No (L) then 248 Set_First (To, F); 249 else 250 Set_Next (L, F); 251 end if; 252 253 Set_Prev (F, L); 254 Set_Last (To, Last (List)); 255 256 Set_First (List, Empty); 257 Set_Last (List, Empty); 258 end; 259 end if; 260 end Append_List; 261 262 -------------------- 263 -- Append_List_To -- 264 -------------------- 265 266 procedure Append_List_To (To : List_Id; List : List_Id) is 267 begin 268 Append_List (List, To); 269 end Append_List_To; 270 271 --------------- 272 -- Append_To -- 273 --------------- 274 275 procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id) is 276 begin 277 Append (Node, To); 278 end Append_To; 279 280 ----------- 281 -- First -- 282 ----------- 283 284 function First (List : List_Id) return Node_Or_Entity_Id is 285 begin 286 if List = No_List then 287 return Empty; 288 else 289 pragma Assert (List <= Lists.Last); 290 return Lists.Table (List).First; 291 end if; 292 end First; 293 294 ---------------------- 295 -- First_Non_Pragma -- 296 ---------------------- 297 298 function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is 299 N : constant Node_Or_Entity_Id := First (List); 300 begin 301 if Nkind (N) /= N_Pragma 302 and then 303 Nkind (N) /= N_Null_Statement 304 then 305 return N; 306 else 307 return Next_Non_Pragma (N); 308 end if; 309 end First_Non_Pragma; 310 311 ---------------- 312 -- Initialize -- 313 ---------------- 314 315 procedure Initialize is 316 E : constant List_Id := Error_List; 317 318 begin 319 Lists.Init; 320 Next_Node.Init; 321 Prev_Node.Init; 322 323 -- Allocate Error_List list header 324 325 Lists.Increment_Last; 326 Set_Parent (E, Empty); 327 Set_First (E, Empty); 328 Set_Last (E, Empty); 329 end Initialize; 330 331 ------------------ 332 -- In_Same_List -- 333 ------------------ 334 335 function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is 336 begin 337 return List_Containing (N1) = List_Containing (N2); 338 end In_Same_List; 339 340 ------------------ 341 -- Insert_After -- 342 ------------------ 343 344 procedure Insert_After 345 (After : Node_Or_Entity_Id; 346 Node : Node_Or_Entity_Id) 347 is 348 procedure Insert_After_Debug; 349 pragma Inline (Insert_After_Debug); 350 -- Output debug information if Debug_Flag_N set 351 352 ------------------------ 353 -- Insert_After_Debug -- 354 ------------------------ 355 356 procedure Insert_After_Debug is 357 begin 358 if Debug_Flag_N then 359 Write_Str ("Insert node"); 360 Write_Int (Int (Node)); 361 Write_Str (" after node "); 362 Write_Int (Int (After)); 363 Write_Eol; 364 end if; 365 end Insert_After_Debug; 366 367 -- Start of processing for Insert_After 368 369 begin 370 pragma Assert 371 (Is_List_Member (After) and then not Is_List_Member (Node)); 372 373 if Node = Error then 374 return; 375 end if; 376 377 pragma Debug (Insert_After_Debug); 378 379 declare 380 Before : constant Node_Or_Entity_Id := Next (After); 381 LC : constant List_Id := List_Containing (After); 382 383 begin 384 if Present (Before) then 385 Set_Prev (Before, Node); 386 else 387 Set_Last (LC, Node); 388 end if; 389 390 Set_Next (After, Node); 391 392 Nodes.Table (Node).In_List := True; 393 394 Set_Prev (Node, After); 395 Set_Next (Node, Before); 396 Set_List_Link (Node, LC); 397 end; 398 end Insert_After; 399 400 ------------------- 401 -- Insert_Before -- 402 ------------------- 403 404 procedure Insert_Before 405 (Before : Node_Or_Entity_Id; 406 Node : Node_Or_Entity_Id) 407 is 408 procedure Insert_Before_Debug; 409 pragma Inline (Insert_Before_Debug); 410 -- Output debug information if Debug_Flag_N set 411 412 ------------------------- 413 -- Insert_Before_Debug -- 414 ------------------------- 415 416 procedure Insert_Before_Debug is 417 begin 418 if Debug_Flag_N then 419 Write_Str ("Insert node"); 420 Write_Int (Int (Node)); 421 Write_Str (" before node "); 422 Write_Int (Int (Before)); 423 Write_Eol; 424 end if; 425 end Insert_Before_Debug; 426 427 -- Start of processing for Insert_Before 428 429 begin 430 pragma Assert 431 (Is_List_Member (Before) and then not Is_List_Member (Node)); 432 433 if Node = Error then 434 return; 435 end if; 436 437 pragma Debug (Insert_Before_Debug); 438 439 declare 440 After : constant Node_Or_Entity_Id := Prev (Before); 441 LC : constant List_Id := List_Containing (Before); 442 443 begin 444 if Present (After) then 445 Set_Next (After, Node); 446 else 447 Set_First (LC, Node); 448 end if; 449 450 Set_Prev (Before, Node); 451 452 Nodes.Table (Node).In_List := True; 453 454 Set_Prev (Node, After); 455 Set_Next (Node, Before); 456 Set_List_Link (Node, LC); 457 end; 458 end Insert_Before; 459 460 ----------------------- 461 -- Insert_List_After -- 462 ----------------------- 463 464 procedure Insert_List_After (After : Node_Or_Entity_Id; List : List_Id) is 465 466 procedure Insert_List_After_Debug; 467 pragma Inline (Insert_List_After_Debug); 468 -- Output debug information if Debug_Flag_N set 469 470 ----------------------------- 471 -- Insert_List_After_Debug -- 472 ----------------------------- 473 474 procedure Insert_List_After_Debug is 475 begin 476 if Debug_Flag_N then 477 Write_Str ("Insert list "); 478 Write_Int (Int (List)); 479 Write_Str (" after node "); 480 Write_Int (Int (After)); 481 Write_Eol; 482 end if; 483 end Insert_List_After_Debug; 484 485 -- Start of processing for Insert_List_After 486 487 begin 488 pragma Assert (Is_List_Member (After)); 489 490 if Is_Empty_List (List) then 491 return; 492 493 else 494 declare 495 Before : constant Node_Or_Entity_Id := Next (After); 496 LC : constant List_Id := List_Containing (After); 497 F : constant Node_Or_Entity_Id := First (List); 498 L : constant Node_Or_Entity_Id := Last (List); 499 N : Node_Or_Entity_Id; 500 501 begin 502 pragma Debug (Insert_List_After_Debug); 503 504 N := F; 505 loop 506 Set_List_Link (N, LC); 507 exit when N = L; 508 N := Next (N); 509 end loop; 510 511 if Present (Before) then 512 Set_Prev (Before, L); 513 else 514 Set_Last (LC, L); 515 end if; 516 517 Set_Next (After, F); 518 Set_Prev (F, After); 519 Set_Next (L, Before); 520 521 Set_First (List, Empty); 522 Set_Last (List, Empty); 523 end; 524 end if; 525 end Insert_List_After; 526 527 ------------------------ 528 -- Insert_List_Before -- 529 ------------------------ 530 531 procedure Insert_List_Before (Before : Node_Or_Entity_Id; List : List_Id) is 532 533 procedure Insert_List_Before_Debug; 534 pragma Inline (Insert_List_Before_Debug); 535 -- Output debug information if Debug_Flag_N set 536 537 ------------------------------ 538 -- Insert_List_Before_Debug -- 539 ------------------------------ 540 541 procedure Insert_List_Before_Debug is 542 begin 543 if Debug_Flag_N then 544 Write_Str ("Insert list "); 545 Write_Int (Int (List)); 546 Write_Str (" before node "); 547 Write_Int (Int (Before)); 548 Write_Eol; 549 end if; 550 end Insert_List_Before_Debug; 551 552 -- Start of processing for Insert_List_Before 553 554 begin 555 pragma Assert (Is_List_Member (Before)); 556 557 if Is_Empty_List (List) then 558 return; 559 560 else 561 declare 562 After : constant Node_Or_Entity_Id := Prev (Before); 563 LC : constant List_Id := List_Containing (Before); 564 F : constant Node_Or_Entity_Id := First (List); 565 L : constant Node_Or_Entity_Id := Last (List); 566 N : Node_Or_Entity_Id; 567 568 begin 569 pragma Debug (Insert_List_Before_Debug); 570 571 N := F; 572 loop 573 Set_List_Link (N, LC); 574 exit when N = L; 575 N := Next (N); 576 end loop; 577 578 if Present (After) then 579 Set_Next (After, F); 580 else 581 Set_First (LC, F); 582 end if; 583 584 Set_Prev (Before, L); 585 Set_Prev (F, After); 586 Set_Next (L, Before); 587 588 Set_First (List, Empty); 589 Set_Last (List, Empty); 590 end; 591 end if; 592 end Insert_List_Before; 593 594 ------------------- 595 -- Is_Empty_List -- 596 ------------------- 597 598 function Is_Empty_List (List : List_Id) return Boolean is 599 begin 600 return First (List) = Empty; 601 end Is_Empty_List; 602 603 -------------------- 604 -- Is_List_Member -- 605 -------------------- 606 607 function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is 608 begin 609 return Nodes.Table (Node).In_List; 610 end Is_List_Member; 611 612 ----------------------- 613 -- Is_Non_Empty_List -- 614 ----------------------- 615 616 function Is_Non_Empty_List (List : List_Id) return Boolean is 617 begin 618 return First (List) /= Empty; 619 end Is_Non_Empty_List; 620 621 ---------- 622 -- Last -- 623 ---------- 624 625 function Last (List : List_Id) return Node_Or_Entity_Id is 626 begin 627 pragma Assert (List <= Lists.Last); 628 return Lists.Table (List).Last; 629 end Last; 630 631 ------------------ 632 -- Last_List_Id -- 633 ------------------ 634 635 function Last_List_Id return List_Id is 636 begin 637 return Lists.Last; 638 end Last_List_Id; 639 640 --------------------- 641 -- Last_Non_Pragma -- 642 --------------------- 643 644 function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is 645 N : constant Node_Or_Entity_Id := Last (List); 646 begin 647 if Nkind (N) /= N_Pragma then 648 return N; 649 else 650 return Prev_Non_Pragma (N); 651 end if; 652 end Last_Non_Pragma; 653 654 --------------------- 655 -- List_Containing -- 656 --------------------- 657 658 function List_Containing (Node : Node_Or_Entity_Id) return List_Id is 659 begin 660 pragma Assert (Is_List_Member (Node)); 661 return List_Id (Nodes.Table (Node).Link); 662 end List_Containing; 663 664 ----------------- 665 -- List_Length -- 666 ----------------- 667 668 function List_Length (List : List_Id) return Nat is 669 Result : Nat; 670 Node : Node_Or_Entity_Id; 671 672 begin 673 Result := 0; 674 Node := First (List); 675 while Present (Node) loop 676 Result := Result + 1; 677 Node := Next (Node); 678 end loop; 679 680 return Result; 681 end List_Length; 682 683 ------------------- 684 -- Lists_Address -- 685 ------------------- 686 687 function Lists_Address return System.Address is 688 begin 689 return Lists.Table (First_List_Id)'Address; 690 end Lists_Address; 691 692 ---------- 693 -- Lock -- 694 ---------- 695 696 procedure Lock is 697 begin 698 Lists.Locked := True; 699 Lists.Release; 700 701 Prev_Node.Locked := True; 702 Next_Node.Locked := True; 703 704 Prev_Node.Release; 705 Next_Node.Release; 706 end Lock; 707 708 ------------------- 709 -- New_Copy_List -- 710 ------------------- 711 712 function New_Copy_List (List : List_Id) return List_Id is 713 NL : List_Id; 714 E : Node_Or_Entity_Id; 715 716 begin 717 if List = No_List then 718 return No_List; 719 720 else 721 NL := New_List; 722 E := First (List); 723 724 while Present (E) loop 725 Append (New_Copy (E), NL); 726 E := Next (E); 727 end loop; 728 729 return NL; 730 end if; 731 end New_Copy_List; 732 733 ---------------------------- 734 -- New_Copy_List_Original -- 735 ---------------------------- 736 737 function New_Copy_List_Original (List : List_Id) return List_Id is 738 NL : List_Id; 739 E : Node_Or_Entity_Id; 740 741 begin 742 if List = No_List then 743 return No_List; 744 745 else 746 NL := New_List; 747 E := First (List); 748 749 while Present (E) loop 750 if Comes_From_Source (E) then 751 Append (New_Copy (E), NL); 752 end if; 753 754 E := Next (E); 755 end loop; 756 757 return NL; 758 end if; 759 end New_Copy_List_Original; 760 761 -------------- 762 -- New_List -- 763 -------------- 764 765 function New_List return List_Id is 766 767 procedure New_List_Debug; 768 pragma Inline (New_List_Debug); 769 -- Output debugging information if Debug_Flag_N is set 770 771 -------------------- 772 -- New_List_Debug -- 773 -------------------- 774 775 procedure New_List_Debug is 776 begin 777 if Debug_Flag_N then 778 Write_Str ("Allocate new list, returned ID = "); 779 Write_Int (Int (Lists.Last)); 780 Write_Eol; 781 end if; 782 end New_List_Debug; 783 784 -- Start of processing for New_List 785 786 begin 787 Lists.Increment_Last; 788 789 declare 790 List : constant List_Id := Lists.Last; 791 792 begin 793 Set_Parent (List, Empty); 794 Set_First (List, Empty); 795 Set_Last (List, Empty); 796 797 pragma Debug (New_List_Debug); 798 return (List); 799 end; 800 end New_List; 801 802 -- Since the one argument case is common, we optimize to build the right 803 -- list directly, rather than first building an empty list and then doing 804 -- the insertion, which results in some unnecessary work. 805 806 function New_List (Node : Node_Or_Entity_Id) return List_Id is 807 808 procedure New_List_Debug; 809 pragma Inline (New_List_Debug); 810 -- Output debugging information if Debug_Flag_N is set 811 812 -------------------- 813 -- New_List_Debug -- 814 -------------------- 815 816 procedure New_List_Debug is 817 begin 818 if Debug_Flag_N then 819 Write_Str ("Allocate new list, returned ID = "); 820 Write_Int (Int (Lists.Last)); 821 Write_Eol; 822 end if; 823 end New_List_Debug; 824 825 -- Start of processing for New_List 826 827 begin 828 if Node = Error then 829 return New_List; 830 831 else 832 pragma Assert (not Is_List_Member (Node)); 833 834 Lists.Increment_Last; 835 836 declare 837 List : constant List_Id := Lists.Last; 838 839 begin 840 Set_Parent (List, Empty); 841 Set_First (List, Node); 842 Set_Last (List, Node); 843 844 Nodes.Table (Node).In_List := True; 845 Set_List_Link (Node, List); 846 Set_Prev (Node, Empty); 847 Set_Next (Node, Empty); 848 pragma Debug (New_List_Debug); 849 return List; 850 end; 851 end if; 852 end New_List; 853 854 function New_List 855 (Node1 : Node_Or_Entity_Id; 856 Node2 : Node_Or_Entity_Id) return List_Id 857 is 858 L : constant List_Id := New_List (Node1); 859 begin 860 Append (Node2, L); 861 return L; 862 end New_List; 863 864 function New_List 865 (Node1 : Node_Or_Entity_Id; 866 Node2 : Node_Or_Entity_Id; 867 Node3 : Node_Or_Entity_Id) return List_Id 868 is 869 L : constant List_Id := New_List (Node1); 870 begin 871 Append (Node2, L); 872 Append (Node3, L); 873 return L; 874 end New_List; 875 876 function New_List 877 (Node1 : Node_Or_Entity_Id; 878 Node2 : Node_Or_Entity_Id; 879 Node3 : Node_Or_Entity_Id; 880 Node4 : Node_Or_Entity_Id) return List_Id 881 is 882 L : constant List_Id := New_List (Node1); 883 begin 884 Append (Node2, L); 885 Append (Node3, L); 886 Append (Node4, L); 887 return L; 888 end New_List; 889 890 function New_List 891 (Node1 : Node_Or_Entity_Id; 892 Node2 : Node_Or_Entity_Id; 893 Node3 : Node_Or_Entity_Id; 894 Node4 : Node_Or_Entity_Id; 895 Node5 : Node_Or_Entity_Id) return List_Id 896 is 897 L : constant List_Id := New_List (Node1); 898 begin 899 Append (Node2, L); 900 Append (Node3, L); 901 Append (Node4, L); 902 Append (Node5, L); 903 return L; 904 end New_List; 905 906 function New_List 907 (Node1 : Node_Or_Entity_Id; 908 Node2 : Node_Or_Entity_Id; 909 Node3 : Node_Or_Entity_Id; 910 Node4 : Node_Or_Entity_Id; 911 Node5 : Node_Or_Entity_Id; 912 Node6 : Node_Or_Entity_Id) return List_Id 913 is 914 L : constant List_Id := New_List (Node1); 915 begin 916 Append (Node2, L); 917 Append (Node3, L); 918 Append (Node4, L); 919 Append (Node5, L); 920 Append (Node6, L); 921 return L; 922 end New_List; 923 924 ---------- 925 -- Next -- 926 ---------- 927 928 function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is 929 begin 930 pragma Assert (Is_List_Member (Node)); 931 return Next_Node.Table (Node); 932 end Next; 933 934 procedure Next (Node : in out Node_Or_Entity_Id) is 935 begin 936 Node := Next (Node); 937 end Next; 938 939 ----------------------- 940 -- Next_Node_Address -- 941 ----------------------- 942 943 function Next_Node_Address return System.Address is 944 begin 945 return Next_Node.Table (First_Node_Id)'Address; 946 end Next_Node_Address; 947 948 --------------------- 949 -- Next_Non_Pragma -- 950 --------------------- 951 952 function Next_Non_Pragma 953 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id 954 is 955 N : Node_Or_Entity_Id; 956 957 begin 958 N := Node; 959 loop 960 N := Next (N); 961 exit when not Nkind_In (N, N_Pragma, N_Null_Statement); 962 end loop; 963 964 return N; 965 end Next_Non_Pragma; 966 967 procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is 968 begin 969 Node := Next_Non_Pragma (Node); 970 end Next_Non_Pragma; 971 972 -------- 973 -- No -- 974 -------- 975 976 function No (List : List_Id) return Boolean is 977 begin 978 return List = No_List; 979 end No; 980 981 --------------- 982 -- Num_Lists -- 983 --------------- 984 985 function Num_Lists return Nat is 986 begin 987 return Int (Lists.Last) - Int (Lists.First) + 1; 988 end Num_Lists; 989 990 ------------ 991 -- Parent -- 992 ------------ 993 994 function Parent (List : List_Id) return Node_Or_Entity_Id is 995 begin 996 pragma Assert (List <= Lists.Last); 997 return Lists.Table (List).Parent; 998 end Parent; 999 1000 ---------- 1001 -- Pick -- 1002 ---------- 1003 1004 function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is 1005 Elmt : Node_Or_Entity_Id; 1006 1007 begin 1008 Elmt := First (List); 1009 for J in 1 .. Index - 1 loop 1010 Elmt := Next (Elmt); 1011 end loop; 1012 1013 return Elmt; 1014 end Pick; 1015 1016 ------------- 1017 -- Prepend -- 1018 ------------- 1019 1020 procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is 1021 F : constant Node_Or_Entity_Id := First (To); 1022 1023 procedure Prepend_Debug; 1024 pragma Inline (Prepend_Debug); 1025 -- Output debug information if Debug_Flag_N set 1026 1027 ------------------- 1028 -- Prepend_Debug -- 1029 ------------------- 1030 1031 procedure Prepend_Debug is 1032 begin 1033 if Debug_Flag_N then 1034 Write_Str ("Prepend node "); 1035 Write_Int (Int (Node)); 1036 Write_Str (" to list "); 1037 Write_Int (Int (To)); 1038 Write_Eol; 1039 end if; 1040 end Prepend_Debug; 1041 1042 -- Start of processing for Prepend_Debug 1043 1044 begin 1045 pragma Assert (not Is_List_Member (Node)); 1046 1047 if Node = Error then 1048 return; 1049 end if; 1050 1051 pragma Debug (Prepend_Debug); 1052 1053 if No (F) then 1054 Set_Last (To, Node); 1055 else 1056 Set_Prev (F, Node); 1057 end if; 1058 1059 Set_First (To, Node); 1060 1061 Nodes.Table (Node).In_List := True; 1062 1063 Set_Next (Node, F); 1064 Set_Prev (Node, Empty); 1065 Set_List_Link (Node, To); 1066 end Prepend; 1067 1068 ------------------ 1069 -- Prepend_List -- 1070 ------------------ 1071 1072 procedure Prepend_List (List : List_Id; To : List_Id) is 1073 1074 procedure Prepend_List_Debug; 1075 pragma Inline (Prepend_List_Debug); 1076 -- Output debug information if Debug_Flag_N set 1077 1078 ------------------------ 1079 -- Prepend_List_Debug -- 1080 ------------------------ 1081 1082 procedure Prepend_List_Debug is 1083 begin 1084 if Debug_Flag_N then 1085 Write_Str ("Prepend list "); 1086 Write_Int (Int (List)); 1087 Write_Str (" to list "); 1088 Write_Int (Int (To)); 1089 Write_Eol; 1090 end if; 1091 end Prepend_List_Debug; 1092 1093 -- Start of processing for Prepend_List 1094 1095 begin 1096 if Is_Empty_List (List) then 1097 return; 1098 1099 else 1100 declare 1101 F : constant Node_Or_Entity_Id := First (To); 1102 L : constant Node_Or_Entity_Id := Last (List); 1103 N : Node_Or_Entity_Id; 1104 1105 begin 1106 pragma Debug (Prepend_List_Debug); 1107 1108 N := L; 1109 loop 1110 Set_List_Link (N, To); 1111 N := Prev (N); 1112 exit when No (N); 1113 end loop; 1114 1115 if No (F) then 1116 Set_Last (To, L); 1117 else 1118 Set_Next (L, F); 1119 end if; 1120 1121 Set_Prev (F, L); 1122 Set_First (To, First (List)); 1123 1124 Set_First (List, Empty); 1125 Set_Last (List, Empty); 1126 end; 1127 end if; 1128 end Prepend_List; 1129 1130 --------------------- 1131 -- Prepend_List_To -- 1132 --------------------- 1133 1134 procedure Prepend_List_To (To : List_Id; List : List_Id) is 1135 begin 1136 Prepend_List (List, To); 1137 end Prepend_List_To; 1138 1139 ---------------- 1140 -- Prepend_To -- 1141 ---------------- 1142 1143 procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is 1144 begin 1145 Prepend (Node, To); 1146 end Prepend_To; 1147 1148 ------------- 1149 -- Present -- 1150 ------------- 1151 1152 function Present (List : List_Id) return Boolean is 1153 begin 1154 return List /= No_List; 1155 end Present; 1156 1157 ---------- 1158 -- Prev -- 1159 ---------- 1160 1161 function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is 1162 begin 1163 pragma Assert (Is_List_Member (Node)); 1164 return Prev_Node.Table (Node); 1165 end Prev; 1166 1167 procedure Prev (Node : in out Node_Or_Entity_Id) is 1168 begin 1169 Node := Prev (Node); 1170 end Prev; 1171 1172 ----------------------- 1173 -- Prev_Node_Address -- 1174 ----------------------- 1175 1176 function Prev_Node_Address return System.Address is 1177 begin 1178 return Prev_Node.Table (First_Node_Id)'Address; 1179 end Prev_Node_Address; 1180 1181 --------------------- 1182 -- Prev_Non_Pragma -- 1183 --------------------- 1184 1185 function Prev_Non_Pragma 1186 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id 1187 is 1188 N : Node_Or_Entity_Id; 1189 1190 begin 1191 N := Node; 1192 loop 1193 N := Prev (N); 1194 exit when Nkind (N) /= N_Pragma; 1195 end loop; 1196 1197 return N; 1198 end Prev_Non_Pragma; 1199 1200 procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is 1201 begin 1202 Node := Prev_Non_Pragma (Node); 1203 end Prev_Non_Pragma; 1204 1205 ------------ 1206 -- Remove -- 1207 ------------ 1208 1209 procedure Remove (Node : Node_Or_Entity_Id) is 1210 Lst : constant List_Id := List_Containing (Node); 1211 Prv : constant Node_Or_Entity_Id := Prev (Node); 1212 Nxt : constant Node_Or_Entity_Id := Next (Node); 1213 1214 procedure Remove_Debug; 1215 pragma Inline (Remove_Debug); 1216 -- Output debug information if Debug_Flag_N set 1217 1218 ------------------ 1219 -- Remove_Debug -- 1220 ------------------ 1221 1222 procedure Remove_Debug is 1223 begin 1224 if Debug_Flag_N then 1225 Write_Str ("Remove node "); 1226 Write_Int (Int (Node)); 1227 Write_Eol; 1228 end if; 1229 end Remove_Debug; 1230 1231 -- Start of processing for Remove 1232 1233 begin 1234 pragma Debug (Remove_Debug); 1235 1236 if No (Prv) then 1237 Set_First (Lst, Nxt); 1238 else 1239 Set_Next (Prv, Nxt); 1240 end if; 1241 1242 if No (Nxt) then 1243 Set_Last (Lst, Prv); 1244 else 1245 Set_Prev (Nxt, Prv); 1246 end if; 1247 1248 Nodes.Table (Node).In_List := False; 1249 Set_Parent (Node, Empty); 1250 end Remove; 1251 1252 ----------------- 1253 -- Remove_Head -- 1254 ----------------- 1255 1256 function Remove_Head (List : List_Id) return Node_Or_Entity_Id is 1257 Frst : constant Node_Or_Entity_Id := First (List); 1258 1259 procedure Remove_Head_Debug; 1260 pragma Inline (Remove_Head_Debug); 1261 -- Output debug information if Debug_Flag_N set 1262 1263 ----------------------- 1264 -- Remove_Head_Debug -- 1265 ----------------------- 1266 1267 procedure Remove_Head_Debug is 1268 begin 1269 if Debug_Flag_N then 1270 Write_Str ("Remove head of list "); 1271 Write_Int (Int (List)); 1272 Write_Eol; 1273 end if; 1274 end Remove_Head_Debug; 1275 1276 -- Start of processing for Remove_Head 1277 1278 begin 1279 pragma Debug (Remove_Head_Debug); 1280 1281 if Frst = Empty then 1282 return Empty; 1283 1284 else 1285 declare 1286 Nxt : constant Node_Or_Entity_Id := Next (Frst); 1287 1288 begin 1289 Set_First (List, Nxt); 1290 1291 if No (Nxt) then 1292 Set_Last (List, Empty); 1293 else 1294 Set_Prev (Nxt, Empty); 1295 end if; 1296 1297 Nodes.Table (Frst).In_List := False; 1298 Set_Parent (Frst, Empty); 1299 return Frst; 1300 end; 1301 end if; 1302 end Remove_Head; 1303 1304 ----------------- 1305 -- Remove_Next -- 1306 ----------------- 1307 1308 function Remove_Next 1309 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id 1310 is 1311 Nxt : constant Node_Or_Entity_Id := Next (Node); 1312 1313 procedure Remove_Next_Debug; 1314 pragma Inline (Remove_Next_Debug); 1315 -- Output debug information if Debug_Flag_N set 1316 1317 ----------------------- 1318 -- Remove_Next_Debug -- 1319 ----------------------- 1320 1321 procedure Remove_Next_Debug is 1322 begin 1323 if Debug_Flag_N then 1324 Write_Str ("Remove next node after "); 1325 Write_Int (Int (Node)); 1326 Write_Eol; 1327 end if; 1328 end Remove_Next_Debug; 1329 1330 -- Start of processing for Remove_Next 1331 1332 begin 1333 if Present (Nxt) then 1334 declare 1335 Nxt2 : constant Node_Or_Entity_Id := Next (Nxt); 1336 LC : constant List_Id := List_Containing (Node); 1337 1338 begin 1339 pragma Debug (Remove_Next_Debug); 1340 Set_Next (Node, Nxt2); 1341 1342 if No (Nxt2) then 1343 Set_Last (LC, Node); 1344 else 1345 Set_Prev (Nxt2, Node); 1346 end if; 1347 1348 Nodes.Table (Nxt).In_List := False; 1349 Set_Parent (Nxt, Empty); 1350 end; 1351 end if; 1352 1353 return Nxt; 1354 end Remove_Next; 1355 1356 --------------- 1357 -- Set_First -- 1358 --------------- 1359 1360 procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is 1361 begin 1362 Lists.Table (List).First := To; 1363 end Set_First; 1364 1365 -------------- 1366 -- Set_Last -- 1367 -------------- 1368 1369 procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is 1370 begin 1371 Lists.Table (List).Last := To; 1372 end Set_Last; 1373 1374 ------------------- 1375 -- Set_List_Link -- 1376 ------------------- 1377 1378 procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is 1379 begin 1380 Nodes.Table (Node).Link := Union_Id (To); 1381 end Set_List_Link; 1382 1383 -------------- 1384 -- Set_Next -- 1385 -------------- 1386 1387 procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is 1388 begin 1389 Next_Node.Table (Node) := To; 1390 end Set_Next; 1391 1392 ---------------- 1393 -- Set_Parent -- 1394 ---------------- 1395 1396 procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is 1397 begin 1398 pragma Assert (List <= Lists.Last); 1399 Lists.Table (List).Parent := Node; 1400 end Set_Parent; 1401 1402 -------------- 1403 -- Set_Prev -- 1404 -------------- 1405 1406 procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is 1407 begin 1408 Prev_Node.Table (Node) := To; 1409 end Set_Prev; 1410 1411 --------------- 1412 -- Tree_Read -- 1413 --------------- 1414 1415 procedure Tree_Read is 1416 begin 1417 Lists.Tree_Read; 1418 Next_Node.Tree_Read; 1419 Prev_Node.Tree_Read; 1420 end Tree_Read; 1421 1422 ---------------- 1423 -- Tree_Write -- 1424 ---------------- 1425 1426 procedure Tree_Write is 1427 begin 1428 Lists.Tree_Write; 1429 Next_Node.Tree_Write; 1430 Prev_Node.Tree_Write; 1431 end Tree_Write; 1432 1433 ------------ 1434 -- Unlock -- 1435 ------------ 1436 1437 procedure Unlock is 1438 begin 1439 Lists.Locked := False; 1440 Prev_Node.Locked := False; 1441 Next_Node.Locked := False; 1442 end Unlock; 1443 1444end Nlists; 1445