1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- $Revision: 1.35 $ --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 -- WARNING: There is a C version of this package. Any changes to this source
37 -- file must be properly reflected in the corresponding C header a-nlists.h
40 with Atree; use Atree;
41 with Debug; use Debug;
42 with Output; use Output;
43 with Sinfo; use Sinfo;
46 package body Nlists is
48 use Atree_Private_Part;
49 -- Get access to Nodes table
51 ----------------------------------
52 -- Implementation of Node Lists --
53 ----------------------------------
55 -- A node list is represented by a list header which contains
58 type List_Header is record
60 -- Pointer to first node in list. Empty if list is empty
63 -- Pointer to last node in list. Empty if list is empty
66 -- Pointer to parent of list. Empty if list has no parent
69 -- The node lists are stored in a table indexed by List_Id values
71 package Lists is new Table.Table (
72 Table_Component_Type => List_Header,
73 Table_Index_Type => List_Id,
74 Table_Low_Bound => First_List_Id,
75 Table_Initial => Alloc.Lists_Initial,
76 Table_Increment => Alloc.Lists_Increment,
77 Table_Name => "Lists");
79 -- The nodes in the list all have the In_List flag set, and their Link
80 -- fields (which otherwise point to the parent) contain the List_Id of
81 -- the list header giving immediate access to the list containing the
82 -- node, and its parent and first and last elements.
84 -- Two auxiliary tables, indexed by Node_Id values and built in parallel
85 -- with the main nodes table and always having the same size contain the
86 -- list link values that allow locating the previous and next node in a
87 -- list. The entries in these tables are valid only if the In_List flag
88 -- is set in the corresponding node. Next_Node is Empty at the end of a
89 -- list and Prev_Node is Empty at the start of a list.
91 package Next_Node is new Table.Table (
92 Table_Component_Type => Node_Id,
93 Table_Index_Type => Node_Id,
94 Table_Low_Bound => First_Node_Id,
95 Table_Initial => Alloc.Orig_Nodes_Initial,
96 Table_Increment => Alloc.Orig_Nodes_Increment,
97 Table_Name => "Next_Node");
99 package Prev_Node is new Table.Table (
100 Table_Component_Type => Node_Id,
101 Table_Index_Type => Node_Id,
102 Table_Low_Bound => First_Node_Id,
103 Table_Initial => Alloc.Orig_Nodes_Initial,
104 Table_Increment => Alloc.Orig_Nodes_Increment,
105 Table_Name => "Prev_Node");
107 -----------------------
108 -- Local Subprograms --
109 -----------------------
111 procedure Prepend_Debug (Node : Node_Id; To : List_Id);
112 pragma Inline (Prepend_Debug);
113 -- Output debug information if Debug_Flag_N set
115 procedure Remove_Next_Debug (Node : Node_Id);
116 pragma Inline (Remove_Next_Debug);
117 -- Output debug information if Debug_Flag_N set
119 procedure Set_First (List : List_Id; To : Node_Id);
120 pragma Inline (Set_First);
121 -- Sets First field of list header List to reference To
123 procedure Set_Last (List : List_Id; To : Node_Id);
124 pragma Inline (Set_Last);
125 -- Sets Last field of list header List to reference To
127 procedure Set_List_Link (Node : Node_Id; To : List_Id);
128 pragma Inline (Set_List_Link);
129 -- Sets list link of Node to list header To
131 procedure Set_Next (Node : Node_Id; To : Node_Id);
132 pragma Inline (Set_Next);
133 -- Sets the Next_Node pointer for Node to reference To
135 procedure Set_Prev (Node : Node_Id; To : Node_Id);
136 pragma Inline (Set_Prev);
137 -- Sets the Prev_Node pointer for Node to reference To
139 --------------------------
140 -- Allocate_List_Tables --
141 --------------------------
143 procedure Allocate_List_Tables (N : Node_Id) is
145 Next_Node.Set_Last (N);
146 Prev_Node.Set_Last (N);
147 end Allocate_List_Tables;
153 procedure Append (Node : Node_Id; To : List_Id) is
154 L : constant Node_Id := Last (To);
156 procedure Append_Debug;
157 pragma Inline (Append_Debug);
158 -- Output debug information if Debug_Flag_N set
160 procedure Append_Debug is
163 Write_Str ("Append node ");
164 Write_Int (Int (Node));
165 Write_Str (" to list ");
166 Write_Int (Int (To));
171 -- Start of processing for Append
174 pragma Assert (not Is_List_Member (Node));
180 pragma Debug (Append_Debug);
183 Set_First (To, Node);
190 Nodes.Table (Node).In_List := True;
192 Set_Next (Node, Empty);
194 Set_List_Link (Node, To);
201 procedure Append_List (List : List_Id; To : List_Id) is
203 procedure Append_List_Debug;
204 pragma Inline (Append_List_Debug);
205 -- Output debug information if Debug_Flag_N set
207 procedure Append_List_Debug is
210 Write_Str ("Append list ");
211 Write_Int (Int (List));
212 Write_Str (" to list ");
213 Write_Int (Int (To));
216 end Append_List_Debug;
218 -- Start of processing for Append_List
221 if Is_Empty_List (List) then
226 L : constant Node_Id := Last (To);
227 F : constant Node_Id := First (List);
231 pragma Debug (Append_List_Debug);
235 Set_List_Link (N, To);
247 Set_Last (To, Last (List));
249 Set_First (List, Empty);
250 Set_Last (List, Empty);
259 procedure Append_List_To (To : List_Id; List : List_Id) is
261 Append_List (List, To);
268 procedure Append_To (To : List_Id; Node : Node_Id) is
277 procedure Delete_List (L : List_Id) is
281 while Is_Non_Empty_List (L) loop
282 N := Remove_Head (L);
286 -- Should recycle list header???
293 -- This subprogram is deliberately placed early on, out of alphabetical
294 -- order, so that it can be properly inlined from within this unit.
296 function First (List : List_Id) return Node_Id is
298 if List = No_List then
301 pragma Assert (List in First_List_Id .. Lists.Last);
302 return Lists.Table (List).First;
306 ----------------------
307 -- First_Non_Pragma --
308 ----------------------
310 function First_Non_Pragma (List : List_Id) return Node_Id is
311 N : constant Node_Id := First (List);
314 if Nkind (N) /= N_Pragma
316 Nkind (N) /= N_Null_Statement
320 return Next_Non_Pragma (N);
322 end First_Non_Pragma;
328 procedure Initialize is
329 E : constant List_Id := Error_List;
336 -- Allocate Error_List list header
338 Lists.Increment_Last;
339 Set_Parent (E, Empty);
340 Set_First (E, Empty);
348 procedure Insert_After (After : Node_Id; Node : Node_Id) is
350 procedure Insert_After_Debug;
351 pragma Inline (Insert_After_Debug);
352 -- Output debug information if Debug_Flag_N set
354 procedure Insert_After_Debug is
357 Write_Str ("Insert node");
358 Write_Int (Int (Node));
359 Write_Str (" after node ");
360 Write_Int (Int (After));
363 end Insert_After_Debug;
365 -- Start of processing for Insert_After
369 (Is_List_Member (After) and then not Is_List_Member (Node));
375 pragma Debug (Insert_After_Debug);
378 Before : constant Node_Id := Next (After);
379 LC : constant List_Id := List_Containing (After);
382 if Present (Before) then
383 Set_Prev (Before, Node);
388 Set_Next (After, Node);
390 Nodes.Table (Node).In_List := True;
392 Set_Prev (Node, After);
393 Set_Next (Node, Before);
394 Set_List_Link (Node, LC);
402 procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
404 procedure Insert_Before_Debug;
405 pragma Inline (Insert_Before_Debug);
406 -- Output debug information if Debug_Flag_N set
408 procedure Insert_Before_Debug is
411 Write_Str ("Insert node");
412 Write_Int (Int (Node));
413 Write_Str (" before node ");
414 Write_Int (Int (Before));
417 end Insert_Before_Debug;
419 -- Start of processing for Insert_Before
423 (Is_List_Member (Before) and then not Is_List_Member (Node));
429 pragma Debug (Insert_Before_Debug);
432 After : constant Node_Id := Prev (Before);
433 LC : constant List_Id := List_Containing (Before);
436 if Present (After) then
437 Set_Next (After, Node);
439 Set_First (LC, Node);
442 Set_Prev (Before, Node);
444 Nodes.Table (Node).In_List := True;
446 Set_Prev (Node, After);
447 Set_Next (Node, Before);
448 Set_List_Link (Node, LC);
452 -----------------------
453 -- Insert_List_After --
454 -----------------------
456 procedure Insert_List_After (After : Node_Id; List : List_Id) is
458 procedure Insert_List_After_Debug;
459 pragma Inline (Insert_List_After_Debug);
460 -- Output debug information if Debug_Flag_N set
462 procedure Insert_List_After_Debug is
465 Write_Str ("Insert list ");
466 Write_Int (Int (List));
467 Write_Str (" after node ");
468 Write_Int (Int (After));
471 end Insert_List_After_Debug;
473 -- Start of processing for Insert_List_After
476 pragma Assert (Is_List_Member (After));
478 if Is_Empty_List (List) then
483 Before : constant Node_Id := Next (After);
484 LC : constant List_Id := List_Containing (After);
485 F : constant Node_Id := First (List);
486 L : constant Node_Id := Last (List);
490 pragma Debug (Insert_List_After_Debug);
494 Set_List_Link (N, LC);
499 if Present (Before) then
500 Set_Prev (Before, L);
507 Set_Next (L, Before);
509 Set_First (List, Empty);
510 Set_Last (List, Empty);
513 end Insert_List_After;
515 ------------------------
516 -- Insert_List_Before --
517 ------------------------
519 procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
521 procedure Insert_List_Before_Debug;
522 pragma Inline (Insert_List_Before_Debug);
523 -- Output debug information if Debug_Flag_N set
525 procedure Insert_List_Before_Debug is
528 Write_Str ("Insert list ");
529 Write_Int (Int (List));
530 Write_Str (" before node ");
531 Write_Int (Int (Before));
534 end Insert_List_Before_Debug;
536 -- Start of prodcessing for Insert_List_Before
539 pragma Assert (Is_List_Member (Before));
541 if Is_Empty_List (List) then
546 After : constant Node_Id := Prev (Before);
547 LC : constant List_Id := List_Containing (Before);
548 F : constant Node_Id := First (List);
549 L : constant Node_Id := Last (List);
553 pragma Debug (Insert_List_Before_Debug);
557 Set_List_Link (N, LC);
562 if Present (After) then
568 Set_Prev (Before, L);
570 Set_Next (L, Before);
572 Set_First (List, Empty);
573 Set_Last (List, Empty);
576 end Insert_List_Before;
582 function Is_Empty_List (List : List_Id) return Boolean is
584 return First (List) = Empty;
591 function Is_List_Member (Node : Node_Id) return Boolean is
593 return Nodes.Table (Node).In_List;
596 -----------------------
597 -- Is_Non_Empty_List --
598 -----------------------
600 function Is_Non_Empty_List (List : List_Id) return Boolean is
602 return List /= No_List and then First (List) /= Empty;
603 end Is_Non_Empty_List;
609 -- This subprogram is deliberately placed early on, out of alphabetical
610 -- order, so that it can be properly inlined from within this unit.
612 function Last (List : List_Id) return Node_Id is
614 pragma Assert (List in First_List_Id .. 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);
635 if Nkind (N) /= N_Pragma then
638 return Prev_Non_Pragma (N);
642 ---------------------
643 -- List_Containing --
644 ---------------------
646 function List_Containing (Node : Node_Id) return List_Id is
648 pragma Assert (Is_List_Member (Node));
649 return List_Id (Nodes.Table (Node).Link);
656 function List_Length (List : List_Id) return Nat is
662 Node := First (List);
663 while Present (Node) loop
664 Result := Result + 1;
675 function Lists_Address return System.Address is
677 return Lists.Table (First_List_Id)'Address;
686 Lists.Locked := True;
689 Prev_Node.Locked := True;
690 Next_Node.Locked := True;
700 function New_Copy_List (List : List_Id) return List_Id is
705 if List = No_List then
712 while Present (E) loop
713 Append (New_Copy (E), NL);
721 ----------------------------
722 -- New_Copy_List_Original --
723 ----------------------------
725 function New_Copy_List_Original (List : List_Id) return List_Id is
730 if List = No_List then
737 while Present (E) loop
738 if Comes_From_Source (E) then
739 Append (New_Copy (E), NL);
747 end New_Copy_List_Original;
749 ------------------------
750 -- New_Copy_List_Tree --
751 ------------------------
753 function New_Copy_List_Tree (List : List_Id) return List_Id is
758 if List = No_List then
765 while Present (E) loop
766 Append (New_Copy_Tree (E), NL);
772 end New_Copy_List_Tree;
778 function New_List return List_Id is
780 procedure New_List_Debug;
781 pragma Inline (New_List_Debug);
782 -- Output debugging information if Debug_Flag_N is set
784 procedure New_List_Debug is
787 Write_Str ("Allocate new list, returned ID = ");
788 Write_Int (Int (Lists.Last));
793 -- Start of processing for New_List
796 Lists.Increment_Last;
799 List : constant List_Id := Lists.Last;
802 Set_Parent (List, Empty);
803 Set_First (List, Empty);
804 Set_Last (List, Empty);
806 pragma Debug (New_List_Debug);
811 -- Since the one argument case is common, we optimize to build the right
812 -- list directly, rather than first building an empty list and then doing
813 -- the insertion, which results in some unnecessary work.
815 function New_List (Node : Node_Id) return List_Id is
817 procedure New_List_Debug;
818 pragma Inline (New_List_Debug);
819 -- Output debugging information if Debug_Flag_N is set
821 procedure New_List_Debug is
824 Write_Str ("Allocate new list, returned ID = ");
825 Write_Int (Int (Lists.Last));
830 -- Start of processing for New_List
837 pragma Assert (not Is_List_Member (Node));
839 Lists.Increment_Last;
842 List : constant List_Id := Lists.Last;
845 Set_Parent (List, Empty);
846 Set_First (List, Node);
847 Set_Last (List, Node);
849 Nodes.Table (Node).In_List := True;
850 Set_List_Link (Node, List);
851 Set_Prev (Node, Empty);
852 Set_Next (Node, Empty);
853 pragma Debug (New_List_Debug);
859 function New_List (Node1, Node2 : Node_Id) return List_Id is
860 L : constant List_Id := New_List (Node1);
867 function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
868 L : constant List_Id := New_List (Node1);
876 function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
877 L : constant List_Id := New_List (Node1);
894 L : constant List_Id := New_List (Node1);
913 L : constant List_Id := New_List (Node1);
928 -- This subprogram is deliberately placed early on, out of alphabetical
929 -- order, so that it can be properly inlined from within this unit.
931 function Next (Node : Node_Id) return Node_Id is
933 pragma Assert (Is_List_Member (Node));
934 return Next_Node.Table (Node);
937 procedure Next (Node : in out Node_Id) is
942 -----------------------
943 -- Next_Node_Address --
944 -----------------------
946 function Next_Node_Address return System.Address is
948 return Next_Node.Table (First_Node_Id)'Address;
949 end Next_Node_Address;
951 ---------------------
952 -- Next_Non_Pragma --
953 ---------------------
955 function Next_Non_Pragma (Node : Node_Id) return Node_Id is
962 exit when Nkind (N) /= N_Pragma
964 Nkind (N) /= N_Null_Statement;
970 procedure Next_Non_Pragma (Node : in out Node_Id) is
972 Node := Next_Non_Pragma (Node);
979 -- This subprogram is deliberately placed early on, out of alphabetical
980 -- order, so that it can be properly inlined from within this unit.
982 function No (List : List_Id) return Boolean is
984 return List = No_List;
991 function Num_Lists return Nat is
993 return Int (Lists.Last) - Int (Lists.First) + 1;
1000 function p (U : Union_Id) return Node_Id is
1002 if U in Node_Range then
1003 return Parent (Node_Id (U));
1005 elsif U in List_Range then
1006 return Parent (List_Id (U));
1017 function Parent (List : List_Id) return Node_Id is
1019 pragma Assert (List in First_List_Id .. Lists.Last);
1020 return Lists.Table (List).Parent;
1027 function Pick (List : List_Id; Index : Pos) return Node_Id is
1031 Elmt := First (List);
1032 for J in 1 .. Index - 1 loop
1033 Elmt := Next (Elmt);
1043 procedure Prepend (Node : Node_Id; To : List_Id) is
1044 F : constant Node_Id := First (To);
1047 pragma Assert (not Is_List_Member (Node));
1049 if Node = Error then
1053 pragma Debug (Prepend_Debug (Node, To));
1056 Set_Last (To, Node);
1061 Set_First (To, Node);
1063 Nodes.Table (Node).In_List := True;
1066 Set_Prev (Node, Empty);
1067 Set_List_Link (Node, To);
1074 procedure Prepend_Debug (Node : Node_Id; To : List_Id) is
1076 if Debug_Flag_N then
1077 Write_Str ("Prepend node ");
1078 Write_Int (Int (Node));
1079 Write_Str (" to list ");
1080 Write_Int (Int (To));
1089 procedure Prepend_To (To : List_Id; Node : Node_Id) is
1098 function Present (List : List_Id) return Boolean is
1100 return List /= No_List;
1107 -- This subprogram is deliberately placed early on, out of alphabetical
1108 -- order, so that it can be properly inlined from within this unit.
1110 function Prev (Node : Node_Id) return Node_Id is
1112 pragma Assert (Is_List_Member (Node));
1113 return Prev_Node.Table (Node);
1116 procedure Prev (Node : in out Node_Id) is
1118 Node := Prev (Node);
1121 -----------------------
1122 -- Prev_Node_Address --
1123 -----------------------
1125 function Prev_Node_Address return System.Address is
1127 return Prev_Node.Table (First_Node_Id)'Address;
1128 end Prev_Node_Address;
1130 ---------------------
1131 -- Prev_Non_Pragma --
1132 ---------------------
1134 function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1141 exit when Nkind (N) /= N_Pragma;
1145 end Prev_Non_Pragma;
1147 procedure Prev_Non_Pragma (Node : in out Node_Id) is
1149 Node := Prev_Non_Pragma (Node);
1150 end Prev_Non_Pragma;
1156 procedure Remove (Node : Node_Id) is
1157 Lst : constant List_Id := List_Containing (Node);
1158 Prv : constant Node_Id := Prev (Node);
1159 Nxt : constant Node_Id := Next (Node);
1161 procedure Remove_Debug;
1162 pragma Inline (Remove_Debug);
1163 -- Output debug information if Debug_Flag_N set
1165 procedure Remove_Debug is
1167 if Debug_Flag_N then
1168 Write_Str ("Remove node ");
1169 Write_Int (Int (Node));
1174 -- Start of processing for Remove
1177 pragma Debug (Remove_Debug);
1180 Set_First (Lst, Nxt);
1182 Set_Next (Prv, Nxt);
1186 Set_Last (Lst, Prv);
1188 Set_Prev (Nxt, Prv);
1191 Nodes.Table (Node).In_List := False;
1192 Set_Parent (Node, Empty);
1199 function Remove_Head (List : List_Id) return Node_Id is
1200 Frst : constant Node_Id := First (List);
1202 procedure Remove_Head_Debug;
1203 pragma Inline (Remove_Head_Debug);
1204 -- Output debug information if Debug_Flag_N set
1206 procedure Remove_Head_Debug is
1208 if Debug_Flag_N then
1209 Write_Str ("Remove head of list ");
1210 Write_Int (Int (List));
1213 end Remove_Head_Debug;
1215 -- Start of processing for Remove_Head
1218 pragma Debug (Remove_Head_Debug);
1220 if Frst = Empty then
1225 Nxt : constant Node_Id := Next (Frst);
1228 Set_First (List, Nxt);
1231 Set_Last (List, Empty);
1233 Set_Prev (Nxt, Empty);
1236 Nodes.Table (Frst).In_List := False;
1237 Set_Parent (Frst, Empty);
1247 function Remove_Next (Node : Node_Id) return Node_Id is
1248 Nxt : constant Node_Id := Next (Node);
1251 if Present (Nxt) then
1253 Nxt2 : constant Node_Id := Next (Nxt);
1254 LC : constant List_Id := List_Containing (Node);
1257 pragma Debug (Remove_Next_Debug (Node));
1258 Set_Next (Node, Nxt2);
1261 Set_Last (LC, Node);
1263 Set_Prev (Nxt2, Node);
1266 Nodes.Table (Nxt).In_List := False;
1267 Set_Parent (Nxt, Empty);
1274 -----------------------
1275 -- Remove_Next_Debug --
1276 -----------------------
1278 procedure Remove_Next_Debug (Node : Node_Id) is
1280 if Debug_Flag_N then
1281 Write_Str ("Remove next node after ");
1282 Write_Int (Int (Node));
1285 end Remove_Next_Debug;
1291 -- This subprogram is deliberately placed early on, out of alphabetical
1292 -- order, so that it can be properly inlined from within this unit.
1294 procedure Set_First (List : List_Id; To : Node_Id) is
1296 Lists.Table (List).First := To;
1303 -- This subprogram is deliberately placed early on, out of alphabetical
1304 -- order, so that it can be properly inlined from within this unit.
1306 procedure Set_Last (List : List_Id; To : Node_Id) is
1308 Lists.Table (List).Last := To;
1315 -- This subprogram is deliberately placed early on, out of alphabetical
1316 -- order, so that it can be properly inlined from within this unit.
1318 procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1320 Nodes.Table (Node).Link := Union_Id (To);
1327 -- This subprogram is deliberately placed early on, out of alphabetical
1328 -- order, so that it can be properly inlined from within this unit.
1330 procedure Set_Next (Node : Node_Id; To : Node_Id) is
1332 Next_Node.Table (Node) := To;
1339 procedure Set_Parent (List : List_Id; Node : Node_Id) is
1341 pragma Assert (List in First_List_Id .. Lists.Last);
1342 Lists.Table (List).Parent := Node;
1349 -- This subprogram is deliberately placed early on, out of alphabetical
1350 -- order, so that it can be properly inlined from within this unit.
1352 procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1354 Prev_Node.Table (Node) := To;
1361 procedure Tree_Read is
1364 Next_Node.Tree_Read;
1365 Prev_Node.Tree_Read;
1372 procedure Tree_Write is
1375 Next_Node.Tree_Write;
1376 Prev_Node.Tree_Write;