1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- WARNING: There is a C version of this package. Any changes to this source
36 -- file must be properly reflected in the corresponding C header a-nlists.h
39 with Atree; use Atree;
40 with Debug; use Debug;
41 with Output; use Output;
42 with Sinfo; use Sinfo;
45 package body Nlists is
47 use Atree_Private_Part;
48 -- Get access to Nodes table
50 ----------------------------------
51 -- Implementation of Node Lists --
52 ----------------------------------
54 -- A node list is represented by a list header which contains
57 type List_Header is record
59 -- Pointer to first node in list. Empty if list is empty
62 -- Pointer to last node in list. Empty if list is empty
65 -- Pointer to parent of list. Empty if list has no parent
68 -- The node lists are stored in a table indexed by List_Id values
70 package Lists is new Table.Table (
71 Table_Component_Type => List_Header,
72 Table_Index_Type => List_Id,
73 Table_Low_Bound => First_List_Id,
74 Table_Initial => Alloc.Lists_Initial,
75 Table_Increment => Alloc.Lists_Increment,
76 Table_Name => "Lists");
78 -- The nodes in the list all have the In_List flag set, and their Link
79 -- fields (which otherwise point to the parent) contain the List_Id of
80 -- the list header giving immediate access to the list containing the
81 -- node, and its parent and first and last elements.
83 -- Two auxiliary tables, indexed by Node_Id values and built in parallel
84 -- with the main nodes table and always having the same size contain the
85 -- list link values that allow locating the previous and next node in a
86 -- list. The entries in these tables are valid only if the In_List flag
87 -- is set in the corresponding node. Next_Node is Empty at the end of a
88 -- list and Prev_Node is Empty at the start of a list.
90 package Next_Node is new Table.Table (
91 Table_Component_Type => Node_Id,
92 Table_Index_Type => Node_Id,
93 Table_Low_Bound => First_Node_Id,
94 Table_Initial => Alloc.Orig_Nodes_Initial,
95 Table_Increment => Alloc.Orig_Nodes_Increment,
96 Table_Name => "Next_Node");
98 package Prev_Node is new Table.Table (
99 Table_Component_Type => Node_Id,
100 Table_Index_Type => Node_Id,
101 Table_Low_Bound => First_Node_Id,
102 Table_Initial => Alloc.Orig_Nodes_Initial,
103 Table_Increment => Alloc.Orig_Nodes_Increment,
104 Table_Name => "Prev_Node");
106 -----------------------
107 -- Local Subprograms --
108 -----------------------
110 procedure Prepend_Debug (Node : Node_Id; To : List_Id);
111 pragma Inline (Prepend_Debug);
112 -- Output debug information if Debug_Flag_N set
114 procedure Remove_Next_Debug (Node : Node_Id);
115 pragma Inline (Remove_Next_Debug);
116 -- Output debug information if Debug_Flag_N set
118 procedure Set_First (List : List_Id; To : Node_Id);
119 pragma Inline (Set_First);
120 -- Sets First field of list header List to reference To
122 procedure Set_Last (List : List_Id; To : Node_Id);
123 pragma Inline (Set_Last);
124 -- Sets Last field of list header List to reference To
126 procedure Set_List_Link (Node : Node_Id; To : List_Id);
127 pragma Inline (Set_List_Link);
128 -- Sets list link of Node to list header To
130 procedure Set_Next (Node : Node_Id; To : Node_Id);
131 pragma Inline (Set_Next);
132 -- Sets the Next_Node pointer for Node to reference To
134 procedure Set_Prev (Node : Node_Id; To : Node_Id);
135 pragma Inline (Set_Prev);
136 -- Sets the Prev_Node pointer for Node to reference To
138 --------------------------
139 -- Allocate_List_Tables --
140 --------------------------
142 procedure Allocate_List_Tables (N : Node_Id) is
144 Next_Node.Set_Last (N);
145 Prev_Node.Set_Last (N);
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
159 procedure Append_Debug is
162 Write_Str ("Append node ");
163 Write_Int (Int (Node));
164 Write_Str (" to list ");
165 Write_Int (Int (To));
170 -- Start of processing for Append
173 pragma Assert (not Is_List_Member (Node));
179 pragma Debug (Append_Debug);
182 Set_First (To, Node);
189 Nodes.Table (Node).In_List := True;
191 Set_Next (Node, Empty);
193 Set_List_Link (Node, To);
200 procedure Append_List (List : List_Id; To : List_Id) is
202 procedure Append_List_Debug;
203 pragma Inline (Append_List_Debug);
204 -- Output debug information if Debug_Flag_N set
206 procedure Append_List_Debug is
209 Write_Str ("Append list ");
210 Write_Int (Int (List));
211 Write_Str (" to list ");
212 Write_Int (Int (To));
215 end Append_List_Debug;
217 -- Start of processing for Append_List
220 if Is_Empty_List (List) then
225 L : constant Node_Id := Last (To);
226 F : constant Node_Id := First (List);
230 pragma Debug (Append_List_Debug);
234 Set_List_Link (N, To);
246 Set_Last (To, Last (List));
248 Set_First (List, Empty);
249 Set_Last (List, Empty);
258 procedure Append_List_To (To : List_Id; List : List_Id) is
260 Append_List (List, To);
267 procedure Append_To (To : List_Id; Node : Node_Id) is
276 procedure Delete_List (L : List_Id) is
280 while Is_Non_Empty_List (L) loop
281 N := Remove_Head (L);
285 -- Should recycle list header???
292 -- This subprogram is deliberately placed early on, out of alphabetical
293 -- order, so that it can be properly inlined from within this unit.
295 function First (List : List_Id) return Node_Id is
297 if List = No_List then
300 pragma Assert (List in First_List_Id .. Lists.Last);
301 return Lists.Table (List).First;
305 ----------------------
306 -- First_Non_Pragma --
307 ----------------------
309 function First_Non_Pragma (List : List_Id) return Node_Id is
310 N : constant Node_Id := First (List);
313 if Nkind (N) /= N_Pragma
315 Nkind (N) /= N_Null_Statement
319 return Next_Non_Pragma (N);
321 end First_Non_Pragma;
327 procedure Initialize is
328 E : constant List_Id := Error_List;
335 -- Allocate Error_List list header
337 Lists.Increment_Last;
338 Set_Parent (E, Empty);
339 Set_First (E, Empty);
347 procedure Insert_After (After : Node_Id; Node : Node_Id) is
349 procedure Insert_After_Debug;
350 pragma Inline (Insert_After_Debug);
351 -- Output debug information if Debug_Flag_N set
353 procedure Insert_After_Debug is
356 Write_Str ("Insert node");
357 Write_Int (Int (Node));
358 Write_Str (" after node ");
359 Write_Int (Int (After));
362 end Insert_After_Debug;
364 -- Start of processing for Insert_After
368 (Is_List_Member (After) and then not Is_List_Member (Node));
374 pragma Debug (Insert_After_Debug);
377 Before : constant Node_Id := Next (After);
378 LC : constant List_Id := List_Containing (After);
381 if Present (Before) then
382 Set_Prev (Before, Node);
387 Set_Next (After, Node);
389 Nodes.Table (Node).In_List := True;
391 Set_Prev (Node, After);
392 Set_Next (Node, Before);
393 Set_List_Link (Node, LC);
401 procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
403 procedure Insert_Before_Debug;
404 pragma Inline (Insert_Before_Debug);
405 -- Output debug information if Debug_Flag_N set
407 procedure Insert_Before_Debug is
410 Write_Str ("Insert node");
411 Write_Int (Int (Node));
412 Write_Str (" before node ");
413 Write_Int (Int (Before));
416 end Insert_Before_Debug;
418 -- Start of processing for Insert_Before
422 (Is_List_Member (Before) and then not Is_List_Member (Node));
428 pragma Debug (Insert_Before_Debug);
431 After : constant Node_Id := Prev (Before);
432 LC : constant List_Id := List_Containing (Before);
435 if Present (After) then
436 Set_Next (After, Node);
438 Set_First (LC, Node);
441 Set_Prev (Before, Node);
443 Nodes.Table (Node).In_List := True;
445 Set_Prev (Node, After);
446 Set_Next (Node, Before);
447 Set_List_Link (Node, LC);
451 -----------------------
452 -- Insert_List_After --
453 -----------------------
455 procedure Insert_List_After (After : Node_Id; List : List_Id) is
457 procedure Insert_List_After_Debug;
458 pragma Inline (Insert_List_After_Debug);
459 -- Output debug information if Debug_Flag_N set
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 procedure Insert_List_Before_Debug is
527 Write_Str ("Insert list ");
528 Write_Int (Int (List));
529 Write_Str (" before node ");
530 Write_Int (Int (Before));
533 end Insert_List_Before_Debug;
535 -- Start of prodcessing for Insert_List_Before
538 pragma Assert (Is_List_Member (Before));
540 if Is_Empty_List (List) then
545 After : constant Node_Id := Prev (Before);
546 LC : constant List_Id := List_Containing (Before);
547 F : constant Node_Id := First (List);
548 L : constant Node_Id := Last (List);
552 pragma Debug (Insert_List_Before_Debug);
556 Set_List_Link (N, LC);
561 if Present (After) then
567 Set_Prev (Before, L);
569 Set_Next (L, Before);
571 Set_First (List, Empty);
572 Set_Last (List, Empty);
575 end Insert_List_Before;
581 function Is_Empty_List (List : List_Id) return Boolean is
583 return First (List) = Empty;
590 function Is_List_Member (Node : Node_Id) return Boolean is
592 return Nodes.Table (Node).In_List;
595 -----------------------
596 -- Is_Non_Empty_List --
597 -----------------------
599 function Is_Non_Empty_List (List : List_Id) return Boolean is
601 return List /= No_List and then First (List) /= Empty;
602 end Is_Non_Empty_List;
608 -- This subprogram is deliberately placed early on, out of alphabetical
609 -- order, so that it can be properly inlined from within this unit.
611 function Last (List : List_Id) return Node_Id is
613 pragma Assert (List in First_List_Id .. Lists.Last);
614 return Lists.Table (List).Last;
621 function Last_List_Id return List_Id is
626 ---------------------
627 -- Last_Non_Pragma --
628 ---------------------
630 function Last_Non_Pragma (List : List_Id) return Node_Id is
631 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;
748 ------------------------
749 -- New_Copy_List_Tree --
750 ------------------------
752 function New_Copy_List_Tree (List : List_Id) return List_Id is
757 if List = No_List then
764 while Present (E) loop
765 Append (New_Copy_Tree (E), NL);
771 end New_Copy_List_Tree;
777 function New_List return List_Id is
779 procedure New_List_Debug;
780 pragma Inline (New_List_Debug);
781 -- Output debugging information if Debug_Flag_N is set
783 procedure New_List_Debug is
786 Write_Str ("Allocate new list, returned ID = ");
787 Write_Int (Int (Lists.Last));
792 -- Start of processing for New_List
795 Lists.Increment_Last;
798 List : constant List_Id := Lists.Last;
801 Set_Parent (List, Empty);
802 Set_First (List, Empty);
803 Set_Last (List, Empty);
805 pragma Debug (New_List_Debug);
810 -- Since the one argument case is common, we optimize to build the right
811 -- list directly, rather than first building an empty list and then doing
812 -- the insertion, which results in some unnecessary work.
814 function New_List (Node : Node_Id) return List_Id is
816 procedure New_List_Debug;
817 pragma Inline (New_List_Debug);
818 -- Output debugging information if Debug_Flag_N is set
820 procedure New_List_Debug is
823 Write_Str ("Allocate new list, returned ID = ");
824 Write_Int (Int (Lists.Last));
829 -- Start of processing for New_List
836 pragma Assert (not Is_List_Member (Node));
838 Lists.Increment_Last;
841 List : constant List_Id := Lists.Last;
844 Set_Parent (List, Empty);
845 Set_First (List, Node);
846 Set_Last (List, Node);
848 Nodes.Table (Node).In_List := True;
849 Set_List_Link (Node, List);
850 Set_Prev (Node, Empty);
851 Set_Next (Node, Empty);
852 pragma Debug (New_List_Debug);
858 function New_List (Node1, Node2 : Node_Id) return List_Id is
859 L : constant List_Id := New_List (Node1);
866 function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
867 L : constant List_Id := New_List (Node1);
875 function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
876 L : constant List_Id := New_List (Node1);
893 L : constant List_Id := New_List (Node1);
912 L : constant List_Id := New_List (Node1);
927 -- This subprogram is deliberately placed early on, out of alphabetical
928 -- order, so that it can be properly inlined from within this unit.
930 function Next (Node : Node_Id) return Node_Id is
932 pragma Assert (Is_List_Member (Node));
933 return Next_Node.Table (Node);
936 procedure Next (Node : in out Node_Id) is
941 -----------------------
942 -- Next_Node_Address --
943 -----------------------
945 function Next_Node_Address return System.Address is
947 return Next_Node.Table (First_Node_Id)'Address;
948 end Next_Node_Address;
950 ---------------------
951 -- Next_Non_Pragma --
952 ---------------------
954 function Next_Non_Pragma (Node : Node_Id) return Node_Id is
961 exit when Nkind (N) /= N_Pragma
963 Nkind (N) /= N_Null_Statement;
969 procedure Next_Non_Pragma (Node : in out Node_Id) is
971 Node := Next_Non_Pragma (Node);
978 -- This subprogram is deliberately placed early on, out of alphabetical
979 -- order, so that it can be properly inlined from within this unit.
981 function No (List : List_Id) return Boolean is
983 return List = No_List;
990 function Num_Lists return Nat is
992 return Int (Lists.Last) - Int (Lists.First) + 1;
999 function p (U : Union_Id) return Node_Id is
1001 if U in Node_Range then
1002 return Parent (Node_Id (U));
1004 elsif U in List_Range then
1005 return Parent (List_Id (U));
1016 function Parent (List : List_Id) return Node_Id is
1018 pragma Assert (List in First_List_Id .. Lists.Last);
1019 return Lists.Table (List).Parent;
1026 function Pick (List : List_Id; Index : Pos) return Node_Id is
1030 Elmt := First (List);
1031 for J in 1 .. Index - 1 loop
1032 Elmt := Next (Elmt);
1042 procedure Prepend (Node : Node_Id; To : List_Id) is
1043 F : constant Node_Id := First (To);
1046 pragma Assert (not Is_List_Member (Node));
1048 if Node = Error then
1052 pragma Debug (Prepend_Debug (Node, To));
1055 Set_Last (To, Node);
1060 Set_First (To, Node);
1062 Nodes.Table (Node).In_List := True;
1065 Set_Prev (Node, Empty);
1066 Set_List_Link (Node, To);
1073 procedure Prepend_Debug (Node : Node_Id; To : List_Id) is
1075 if Debug_Flag_N then
1076 Write_Str ("Prepend node ");
1077 Write_Int (Int (Node));
1078 Write_Str (" to list ");
1079 Write_Int (Int (To));
1088 procedure Prepend_To (To : List_Id; Node : Node_Id) is
1097 function Present (List : List_Id) return Boolean is
1099 return List /= No_List;
1106 -- This subprogram is deliberately placed early on, out of alphabetical
1107 -- order, so that it can be properly inlined from within this unit.
1109 function Prev (Node : Node_Id) return Node_Id is
1111 pragma Assert (Is_List_Member (Node));
1112 return Prev_Node.Table (Node);
1115 procedure Prev (Node : in out Node_Id) is
1117 Node := Prev (Node);
1120 -----------------------
1121 -- Prev_Node_Address --
1122 -----------------------
1124 function Prev_Node_Address return System.Address is
1126 return Prev_Node.Table (First_Node_Id)'Address;
1127 end Prev_Node_Address;
1129 ---------------------
1130 -- Prev_Non_Pragma --
1131 ---------------------
1133 function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1140 exit when Nkind (N) /= N_Pragma;
1144 end Prev_Non_Pragma;
1146 procedure Prev_Non_Pragma (Node : in out Node_Id) is
1148 Node := Prev_Non_Pragma (Node);
1149 end Prev_Non_Pragma;
1155 procedure Remove (Node : Node_Id) is
1156 Lst : constant List_Id := List_Containing (Node);
1157 Prv : constant Node_Id := Prev (Node);
1158 Nxt : constant Node_Id := Next (Node);
1160 procedure Remove_Debug;
1161 pragma Inline (Remove_Debug);
1162 -- Output debug information if Debug_Flag_N set
1164 procedure Remove_Debug is
1166 if Debug_Flag_N then
1167 Write_Str ("Remove node ");
1168 Write_Int (Int (Node));
1173 -- Start of processing for Remove
1176 pragma Debug (Remove_Debug);
1179 Set_First (Lst, Nxt);
1181 Set_Next (Prv, Nxt);
1185 Set_Last (Lst, Prv);
1187 Set_Prev (Nxt, Prv);
1190 Nodes.Table (Node).In_List := False;
1191 Set_Parent (Node, Empty);
1198 function Remove_Head (List : List_Id) return Node_Id is
1199 Frst : constant Node_Id := First (List);
1201 procedure Remove_Head_Debug;
1202 pragma Inline (Remove_Head_Debug);
1203 -- Output debug information if Debug_Flag_N set
1205 procedure Remove_Head_Debug is
1207 if Debug_Flag_N then
1208 Write_Str ("Remove head of list ");
1209 Write_Int (Int (List));
1212 end Remove_Head_Debug;
1214 -- Start of processing for Remove_Head
1217 pragma Debug (Remove_Head_Debug);
1219 if Frst = Empty then
1224 Nxt : constant Node_Id := Next (Frst);
1227 Set_First (List, Nxt);
1230 Set_Last (List, Empty);
1232 Set_Prev (Nxt, Empty);
1235 Nodes.Table (Frst).In_List := False;
1236 Set_Parent (Frst, Empty);
1246 function Remove_Next (Node : Node_Id) return Node_Id is
1247 Nxt : constant Node_Id := Next (Node);
1250 if Present (Nxt) then
1252 Nxt2 : constant Node_Id := Next (Nxt);
1253 LC : constant List_Id := List_Containing (Node);
1256 pragma Debug (Remove_Next_Debug (Node));
1257 Set_Next (Node, Nxt2);
1260 Set_Last (LC, Node);
1262 Set_Prev (Nxt2, Node);
1265 Nodes.Table (Nxt).In_List := False;
1266 Set_Parent (Nxt, Empty);
1273 -----------------------
1274 -- Remove_Next_Debug --
1275 -----------------------
1277 procedure Remove_Next_Debug (Node : Node_Id) is
1279 if Debug_Flag_N then
1280 Write_Str ("Remove next node after ");
1281 Write_Int (Int (Node));
1284 end Remove_Next_Debug;
1290 -- This subprogram is deliberately placed early on, out of alphabetical
1291 -- order, so that it can be properly inlined from within this unit.
1293 procedure Set_First (List : List_Id; To : Node_Id) is
1295 Lists.Table (List).First := To;
1302 -- This subprogram is deliberately placed early on, out of alphabetical
1303 -- order, so that it can be properly inlined from within this unit.
1305 procedure Set_Last (List : List_Id; To : Node_Id) is
1307 Lists.Table (List).Last := To;
1314 -- This subprogram is deliberately placed early on, out of alphabetical
1315 -- order, so that it can be properly inlined from within this unit.
1317 procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1319 Nodes.Table (Node).Link := Union_Id (To);
1326 -- This subprogram is deliberately placed early on, out of alphabetical
1327 -- order, so that it can be properly inlined from within this unit.
1329 procedure Set_Next (Node : Node_Id; To : Node_Id) is
1331 Next_Node.Table (Node) := To;
1338 procedure Set_Parent (List : List_Id; Node : Node_Id) is
1340 pragma Assert (List in First_List_Id .. Lists.Last);
1341 Lists.Table (List).Parent := Node;
1348 -- This subprogram is deliberately placed early on, out of alphabetical
1349 -- order, so that it can be properly inlined from within this unit.
1351 procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1353 Prev_Node.Table (Node) := To;
1360 procedure Tree_Read is
1363 Next_Node.Tree_Read;
1364 Prev_Node.Tree_Read;
1371 procedure Tree_Write is
1374 Next_Node.Tree_Write;
1375 Prev_Node.Tree_Write;