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