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