1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
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
36 with Atree; use Atree;
37 with Debug; use Debug;
38 with Output; use Output;
39 with Sinfo; use Sinfo;
42 package body Nlists is
44 use Atree_Private_Part;
45 -- Get access to Nodes table
47 ----------------------------------
48 -- Implementation of Node Lists --
49 ----------------------------------
51 -- A node list is represented by a list header which contains
54 type List_Header is record
56 -- Pointer to first node in list. Empty if list is empty
59 -- Pointer to last node in list. Empty if list is empty
62 -- Pointer to parent of list. Empty if list has no parent
65 -- The node lists are stored in a table indexed by List_Id values
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");
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.
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.
87 package Next_Node is new Table.Table (
88 Table_Component_Type => Node_Id,
89 Table_Index_Type => Node_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");
95 package Prev_Node is new Table.Table (
96 Table_Component_Type => Node_Id,
97 Table_Index_Type => Node_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");
103 -----------------------
104 -- Local Subprograms --
105 -----------------------
107 procedure Set_First (List : List_Id; To : Node_Id);
108 pragma Inline (Set_First);
109 -- Sets First field of list header List to reference To
111 procedure Set_Last (List : List_Id; To : Node_Id);
112 pragma Inline (Set_Last);
113 -- Sets Last field of list header List to reference To
115 procedure Set_List_Link (Node : Node_Id; To : List_Id);
116 pragma Inline (Set_List_Link);
117 -- Sets list link of Node to list header To
119 procedure Set_Next (Node : Node_Id; To : Node_Id);
120 pragma Inline (Set_Next);
121 -- Sets the Next_Node pointer for Node to reference To
123 procedure Set_Prev (Node : Node_Id; To : Node_Id);
124 pragma Inline (Set_Prev);
125 -- Sets the Prev_Node pointer for Node to reference To
127 --------------------------
128 -- Allocate_List_Tables --
129 --------------------------
131 procedure Allocate_List_Tables (N : Node_Id) is
132 Old_Last : constant Node_Id'Base := Next_Node.Last;
135 pragma Assert (N >= Old_Last);
136 Next_Node.Set_Last (N);
137 Prev_Node.Set_Last (N);
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.
142 for J in Old_Last + 1 .. N loop
143 Next_Node.Table (J) := Empty;
144 Prev_Node.Table (J) := Empty;
146 end Allocate_List_Tables;
152 procedure Append (Node : Node_Id; To : List_Id) is
153 L : constant Node_Id := Last (To);
155 procedure Append_Debug;
156 pragma Inline (Append_Debug);
157 -- Output debug information if Debug_Flag_N set
163 procedure Append_Debug is
166 Write_Str ("Append node ");
167 Write_Int (Int (Node));
168 Write_Str (" to list ");
169 Write_Int (Int (To));
174 -- Start of processing for Append
177 pragma Assert (not Is_List_Member (Node));
183 pragma Debug (Append_Debug);
186 Set_First (To, Node);
193 Nodes.Table (Node).In_List := True;
195 Set_Next (Node, Empty);
197 Set_List_Link (Node, To);
204 procedure Append_List (List : List_Id; To : List_Id) is
206 procedure Append_List_Debug;
207 pragma Inline (Append_List_Debug);
208 -- Output debug information if Debug_Flag_N set
210 -----------------------
211 -- Append_List_Debug --
212 -----------------------
214 procedure Append_List_Debug is
217 Write_Str ("Append list ");
218 Write_Int (Int (List));
219 Write_Str (" to list ");
220 Write_Int (Int (To));
223 end Append_List_Debug;
225 -- Start of processing for Append_List
228 if Is_Empty_List (List) then
233 L : constant Node_Id := Last (To);
234 F : constant Node_Id := First (List);
238 pragma Debug (Append_List_Debug);
242 Set_List_Link (N, To);
254 Set_Last (To, Last (List));
256 Set_First (List, Empty);
257 Set_Last (List, Empty);
266 procedure Append_List_To (To : List_Id; List : List_Id) is
268 Append_List (List, To);
275 procedure Append_To (To : List_Id; Node : Node_Id) is
284 function First (List : List_Id) return Node_Id is
286 if List = No_List then
289 pragma Assert (List <= Lists.Last);
290 return Lists.Table (List).First;
294 ----------------------
295 -- First_Non_Pragma --
296 ----------------------
298 function First_Non_Pragma (List : List_Id) return Node_Id is
299 N : constant Node_Id := First (List);
301 if Nkind (N) /= N_Pragma
303 Nkind (N) /= N_Null_Statement
307 return Next_Non_Pragma (N);
309 end First_Non_Pragma;
315 procedure Initialize is
316 E : constant List_Id := Error_List;
323 -- Allocate Error_List list header
325 Lists.Increment_Last;
326 Set_Parent (E, Empty);
327 Set_First (E, Empty);
335 procedure Insert_After (After : Node_Id; Node : Node_Id) is
337 procedure Insert_After_Debug;
338 pragma Inline (Insert_After_Debug);
339 -- Output debug information if Debug_Flag_N set
341 ------------------------
342 -- Insert_After_Debug --
343 ------------------------
345 procedure Insert_After_Debug is
348 Write_Str ("Insert node");
349 Write_Int (Int (Node));
350 Write_Str (" after node ");
351 Write_Int (Int (After));
354 end Insert_After_Debug;
356 -- Start of processing for Insert_After
360 (Is_List_Member (After) and then not Is_List_Member (Node));
366 pragma Debug (Insert_After_Debug);
369 Before : constant Node_Id := Next (After);
370 LC : constant List_Id := List_Containing (After);
373 if Present (Before) then
374 Set_Prev (Before, Node);
379 Set_Next (After, Node);
381 Nodes.Table (Node).In_List := True;
383 Set_Prev (Node, After);
384 Set_Next (Node, Before);
385 Set_List_Link (Node, LC);
393 procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
395 procedure Insert_Before_Debug;
396 pragma Inline (Insert_Before_Debug);
397 -- Output debug information if Debug_Flag_N set
399 -------------------------
400 -- Insert_Before_Debug --
401 -------------------------
403 procedure Insert_Before_Debug is
406 Write_Str ("Insert node");
407 Write_Int (Int (Node));
408 Write_Str (" before node ");
409 Write_Int (Int (Before));
412 end Insert_Before_Debug;
414 -- Start of processing for Insert_Before
418 (Is_List_Member (Before) and then not Is_List_Member (Node));
424 pragma Debug (Insert_Before_Debug);
427 After : constant Node_Id := Prev (Before);
428 LC : constant List_Id := List_Containing (Before);
431 if Present (After) then
432 Set_Next (After, Node);
434 Set_First (LC, Node);
437 Set_Prev (Before, Node);
439 Nodes.Table (Node).In_List := True;
441 Set_Prev (Node, After);
442 Set_Next (Node, Before);
443 Set_List_Link (Node, LC);
447 -----------------------
448 -- Insert_List_After --
449 -----------------------
451 procedure Insert_List_After (After : Node_Id; List : List_Id) is
453 procedure Insert_List_After_Debug;
454 pragma Inline (Insert_List_After_Debug);
455 -- Output debug information if Debug_Flag_N set
457 -----------------------------
458 -- Insert_List_After_Debug --
459 -----------------------------
461 procedure Insert_List_After_Debug is
464 Write_Str ("Insert list ");
465 Write_Int (Int (List));
466 Write_Str (" after node ");
467 Write_Int (Int (After));
470 end Insert_List_After_Debug;
472 -- Start of processing for Insert_List_After
475 pragma Assert (Is_List_Member (After));
477 if Is_Empty_List (List) then
482 Before : constant Node_Id := Next (After);
483 LC : constant List_Id := List_Containing (After);
484 F : constant Node_Id := First (List);
485 L : constant Node_Id := Last (List);
489 pragma Debug (Insert_List_After_Debug);
493 Set_List_Link (N, LC);
498 if Present (Before) then
499 Set_Prev (Before, L);
506 Set_Next (L, Before);
508 Set_First (List, Empty);
509 Set_Last (List, Empty);
512 end Insert_List_After;
514 ------------------------
515 -- Insert_List_Before --
516 ------------------------
518 procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
520 procedure Insert_List_Before_Debug;
521 pragma Inline (Insert_List_Before_Debug);
522 -- Output debug information if Debug_Flag_N set
524 ------------------------------
525 -- Insert_List_Before_Debug --
526 ------------------------------
528 procedure Insert_List_Before_Debug is
531 Write_Str ("Insert list ");
532 Write_Int (Int (List));
533 Write_Str (" before node ");
534 Write_Int (Int (Before));
537 end Insert_List_Before_Debug;
539 -- Start of processing for Insert_List_Before
542 pragma Assert (Is_List_Member (Before));
544 if Is_Empty_List (List) then
549 After : constant Node_Id := Prev (Before);
550 LC : constant List_Id := List_Containing (Before);
551 F : constant Node_Id := First (List);
552 L : constant Node_Id := Last (List);
556 pragma Debug (Insert_List_Before_Debug);
560 Set_List_Link (N, LC);
565 if Present (After) then
571 Set_Prev (Before, L);
573 Set_Next (L, Before);
575 Set_First (List, Empty);
576 Set_Last (List, Empty);
579 end Insert_List_Before;
585 function Is_Empty_List (List : List_Id) return Boolean is
587 return First (List) = Empty;
594 function Is_List_Member (Node : Node_Id) return Boolean is
596 return Nodes.Table (Node).In_List;
599 -----------------------
600 -- Is_Non_Empty_List --
601 -----------------------
603 function Is_Non_Empty_List (List : List_Id) return Boolean is
605 return First (List) /= Empty;
606 end Is_Non_Empty_List;
612 function Last (List : List_Id) return Node_Id is
614 pragma Assert (List <= Lists.Last);
615 return Lists.Table (List).Last;
622 function Last_List_Id return List_Id is
627 ---------------------
628 -- Last_Non_Pragma --
629 ---------------------
631 function Last_Non_Pragma (List : List_Id) return Node_Id is
632 N : constant Node_Id := Last (List);
634 if Nkind (N) /= N_Pragma then
637 return Prev_Non_Pragma (N);
641 ---------------------
642 -- List_Containing --
643 ---------------------
645 function List_Containing (Node : Node_Id) return List_Id is
647 pragma Assert (Is_List_Member (Node));
648 return List_Id (Nodes.Table (Node).Link);
655 function List_Length (List : List_Id) return Nat is
661 Node := First (List);
662 while Present (Node) loop
663 Result := Result + 1;
674 function Lists_Address return System.Address is
676 return Lists.Table (First_List_Id)'Address;
685 Lists.Locked := True;
688 Prev_Node.Locked := True;
689 Next_Node.Locked := True;
699 function New_Copy_List (List : List_Id) return List_Id is
704 if List = No_List then
711 while Present (E) loop
712 Append (New_Copy (E), NL);
720 ----------------------------
721 -- New_Copy_List_Original --
722 ----------------------------
724 function New_Copy_List_Original (List : List_Id) return List_Id is
729 if List = No_List then
736 while Present (E) loop
737 if Comes_From_Source (E) then
738 Append (New_Copy (E), NL);
746 end New_Copy_List_Original;
752 function New_List return List_Id is
754 procedure New_List_Debug;
755 pragma Inline (New_List_Debug);
756 -- Output debugging information if Debug_Flag_N is set
762 procedure New_List_Debug is
765 Write_Str ("Allocate new list, returned ID = ");
766 Write_Int (Int (Lists.Last));
771 -- Start of processing for New_List
774 Lists.Increment_Last;
777 List : constant List_Id := Lists.Last;
780 Set_Parent (List, Empty);
781 Set_First (List, Empty);
782 Set_Last (List, Empty);
784 pragma Debug (New_List_Debug);
789 -- Since the one argument case is common, we optimize to build the right
790 -- list directly, rather than first building an empty list and then doing
791 -- the insertion, which results in some unnecessary work.
793 function New_List (Node : Node_Id) return List_Id is
795 procedure New_List_Debug;
796 pragma Inline (New_List_Debug);
797 -- Output debugging information if Debug_Flag_N is set
803 procedure New_List_Debug is
806 Write_Str ("Allocate new list, returned ID = ");
807 Write_Int (Int (Lists.Last));
812 -- Start of processing for New_List
819 pragma Assert (not Is_List_Member (Node));
821 Lists.Increment_Last;
824 List : constant List_Id := Lists.Last;
827 Set_Parent (List, Empty);
828 Set_First (List, Node);
829 Set_Last (List, Node);
831 Nodes.Table (Node).In_List := True;
832 Set_List_Link (Node, List);
833 Set_Prev (Node, Empty);
834 Set_Next (Node, Empty);
835 pragma Debug (New_List_Debug);
841 function New_List (Node1, Node2 : Node_Id) return List_Id is
842 L : constant List_Id := New_List (Node1);
848 function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
849 L : constant List_Id := New_List (Node1);
856 function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
857 L : constant List_Id := New_List (Node1);
870 Node5 : Node_Id) return List_Id
872 L : constant List_Id := New_List (Node1);
887 Node6 : Node_Id) return List_Id
889 L : constant List_Id := New_List (Node1);
903 function Next (Node : Node_Id) return Node_Id is
905 pragma Assert (Is_List_Member (Node));
906 return Next_Node.Table (Node);
909 procedure Next (Node : in out Node_Id) is
914 -----------------------
915 -- Next_Node_Address --
916 -----------------------
918 function Next_Node_Address return System.Address is
920 return Next_Node.Table (First_Node_Id)'Address;
921 end Next_Node_Address;
923 ---------------------
924 -- Next_Non_Pragma --
925 ---------------------
927 function Next_Non_Pragma (Node : Node_Id) return Node_Id is
934 exit when Nkind (N) /= N_Pragma
936 Nkind (N) /= N_Null_Statement;
942 procedure Next_Non_Pragma (Node : in out Node_Id) is
944 Node := Next_Non_Pragma (Node);
951 function No (List : List_Id) return Boolean is
953 return List = No_List;
960 function Num_Lists return Nat is
962 return Int (Lists.Last) - Int (Lists.First) + 1;
969 function p (U : Union_Id) return Node_Id is
971 if U in Node_Range then
972 return Parent (Node_Id (U));
973 elsif U in List_Range then
974 return Parent (List_Id (U));
984 function Parent (List : List_Id) return Node_Id is
986 pragma Assert (List <= Lists.Last);
987 return Lists.Table (List).Parent;
994 function Pick (List : List_Id; Index : Pos) return Node_Id is
998 Elmt := First (List);
999 for J in 1 .. Index - 1 loop
1000 Elmt := Next (Elmt);
1010 procedure Prepend (Node : Node_Id; To : List_Id) is
1011 F : constant Node_Id := First (To);
1013 procedure Prepend_Debug;
1014 pragma Inline (Prepend_Debug);
1015 -- Output debug information if Debug_Flag_N set
1021 procedure Prepend_Debug is
1023 if Debug_Flag_N then
1024 Write_Str ("Prepend node ");
1025 Write_Int (Int (Node));
1026 Write_Str (" to list ");
1027 Write_Int (Int (To));
1032 -- Start of processing for Prepend_Debug
1035 pragma Assert (not Is_List_Member (Node));
1037 if Node = Error then
1041 pragma Debug (Prepend_Debug);
1044 Set_Last (To, Node);
1049 Set_First (To, Node);
1051 Nodes.Table (Node).In_List := True;
1054 Set_Prev (Node, Empty);
1055 Set_List_Link (Node, To);
1062 procedure Prepend_To (To : List_Id; Node : Node_Id) is
1071 function Present (List : List_Id) return Boolean is
1073 return List /= No_List;
1080 function Prev (Node : Node_Id) return Node_Id is
1082 pragma Assert (Is_List_Member (Node));
1083 return Prev_Node.Table (Node);
1086 procedure Prev (Node : in out Node_Id) is
1088 Node := Prev (Node);
1091 -----------------------
1092 -- Prev_Node_Address --
1093 -----------------------
1095 function Prev_Node_Address return System.Address is
1097 return Prev_Node.Table (First_Node_Id)'Address;
1098 end Prev_Node_Address;
1100 ---------------------
1101 -- Prev_Non_Pragma --
1102 ---------------------
1104 function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1111 exit when Nkind (N) /= N_Pragma;
1115 end Prev_Non_Pragma;
1117 procedure Prev_Non_Pragma (Node : in out Node_Id) is
1119 Node := Prev_Non_Pragma (Node);
1120 end Prev_Non_Pragma;
1126 procedure Remove (Node : Node_Id) is
1127 Lst : constant List_Id := List_Containing (Node);
1128 Prv : constant Node_Id := Prev (Node);
1129 Nxt : constant Node_Id := Next (Node);
1131 procedure Remove_Debug;
1132 pragma Inline (Remove_Debug);
1133 -- Output debug information if Debug_Flag_N set
1139 procedure Remove_Debug is
1141 if Debug_Flag_N then
1142 Write_Str ("Remove node ");
1143 Write_Int (Int (Node));
1148 -- Start of processing for Remove
1151 pragma Debug (Remove_Debug);
1154 Set_First (Lst, Nxt);
1156 Set_Next (Prv, Nxt);
1160 Set_Last (Lst, Prv);
1162 Set_Prev (Nxt, Prv);
1165 Nodes.Table (Node).In_List := False;
1166 Set_Parent (Node, Empty);
1173 function Remove_Head (List : List_Id) return Node_Id is
1174 Frst : constant Node_Id := First (List);
1176 procedure Remove_Head_Debug;
1177 pragma Inline (Remove_Head_Debug);
1178 -- Output debug information if Debug_Flag_N set
1180 -----------------------
1181 -- Remove_Head_Debug --
1182 -----------------------
1184 procedure Remove_Head_Debug is
1186 if Debug_Flag_N then
1187 Write_Str ("Remove head of list ");
1188 Write_Int (Int (List));
1191 end Remove_Head_Debug;
1193 -- Start of processing for Remove_Head
1196 pragma Debug (Remove_Head_Debug);
1198 if Frst = Empty then
1203 Nxt : constant Node_Id := Next (Frst);
1206 Set_First (List, Nxt);
1209 Set_Last (List, Empty);
1211 Set_Prev (Nxt, Empty);
1214 Nodes.Table (Frst).In_List := False;
1215 Set_Parent (Frst, Empty);
1225 function Remove_Next (Node : Node_Id) return Node_Id is
1226 Nxt : constant Node_Id := Next (Node);
1228 procedure Remove_Next_Debug;
1229 pragma Inline (Remove_Next_Debug);
1230 -- Output debug information if Debug_Flag_N set
1232 -----------------------
1233 -- Remove_Next_Debug --
1234 -----------------------
1236 procedure Remove_Next_Debug is
1238 if Debug_Flag_N then
1239 Write_Str ("Remove next node after ");
1240 Write_Int (Int (Node));
1243 end Remove_Next_Debug;
1245 -- Start of processing for Remove_Next
1248 if Present (Nxt) then
1250 Nxt2 : constant Node_Id := Next (Nxt);
1251 LC : constant List_Id := List_Containing (Node);
1254 pragma Debug (Remove_Next_Debug);
1255 Set_Next (Node, Nxt2);
1258 Set_Last (LC, Node);
1260 Set_Prev (Nxt2, Node);
1263 Nodes.Table (Nxt).In_List := False;
1264 Set_Parent (Nxt, Empty);
1275 procedure Set_First (List : List_Id; To : Node_Id) is
1277 Lists.Table (List).First := To;
1284 procedure Set_Last (List : List_Id; To : Node_Id) is
1286 Lists.Table (List).Last := To;
1293 procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1295 Nodes.Table (Node).Link := Union_Id (To);
1302 procedure Set_Next (Node : Node_Id; To : Node_Id) is
1304 Next_Node.Table (Node) := To;
1311 procedure Set_Parent (List : List_Id; Node : Node_Id) is
1313 pragma Assert (List <= Lists.Last);
1314 Lists.Table (List).Parent := Node;
1321 procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1323 Prev_Node.Table (Node) := To;
1330 procedure Tree_Read is
1333 Next_Node.Tree_Read;
1334 Prev_Node.Tree_Read;
1341 procedure Tree_Write is
1344 Next_Node.Tree_Write;
1345 Prev_Node.Tree_Write;
1354 Lists.Locked := False;
1355 Prev_Node.Locked := False;
1356 Next_Node.Locked := False;