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