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