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