1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001 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 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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
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
38 with Atree; use Atree;
39 with Debug; use Debug;
40 with Output; use Output;
41 with Sinfo; use Sinfo;
44 package body Nlists is
46 use Atree_Private_Part;
47 -- Get access to Nodes table
49 ----------------------------------
50 -- Implementation of Node Lists --
51 ----------------------------------
53 -- A node list is represented by a list header which contains
56 type List_Header is record
58 -- Pointer to first node in list. Empty if list is empty
61 -- Pointer to last node in list. Empty if list is empty
64 -- Pointer to parent of list. Empty if list has no parent
67 -- The node lists are stored in a table indexed by List_Id values
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");
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.
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.
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");
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");
105 -----------------------
106 -- Local Subprograms --
107 -----------------------
109 procedure Prepend_Debug (Node : Node_Id; To : List_Id);
110 pragma Inline (Prepend_Debug);
111 -- Output debug information if Debug_Flag_N set
113 procedure Remove_Next_Debug (Node : Node_Id);
114 pragma Inline (Remove_Next_Debug);
115 -- Output debug information if Debug_Flag_N set
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
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
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
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
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
137 --------------------------
138 -- Allocate_List_Tables --
139 --------------------------
141 procedure Allocate_List_Tables (N : Node_Id) is
143 Next_Node.Set_Last (N);
144 Prev_Node.Set_Last (N);
145 end Allocate_List_Tables;
151 procedure Append (Node : Node_Id; To : List_Id) is
152 L : constant Node_Id := Last (To);
154 procedure Append_Debug;
155 pragma Inline (Append_Debug);
156 -- Output debug information if Debug_Flag_N set
158 procedure Append_Debug is
161 Write_Str ("Append node ");
162 Write_Int (Int (Node));
163 Write_Str (" to list ");
164 Write_Int (Int (To));
169 -- Start of processing for Append
172 pragma Assert (not Is_List_Member (Node));
178 pragma Debug (Append_Debug);
181 Set_First (To, Node);
188 Nodes.Table (Node).In_List := True;
190 Set_Next (Node, Empty);
192 Set_List_Link (Node, To);
199 procedure Append_List (List : List_Id; To : List_Id) is
201 procedure Append_List_Debug;
202 pragma Inline (Append_List_Debug);
203 -- Output debug information if Debug_Flag_N set
205 procedure Append_List_Debug is
208 Write_Str ("Append list ");
209 Write_Int (Int (List));
210 Write_Str (" to list ");
211 Write_Int (Int (To));
214 end Append_List_Debug;
216 -- Start of processing for Append_List
219 if Is_Empty_List (List) then
224 L : constant Node_Id := Last (To);
225 F : constant Node_Id := First (List);
229 pragma Debug (Append_List_Debug);
233 Set_List_Link (N, To);
245 Set_Last (To, Last (List));
247 Set_First (List, Empty);
248 Set_Last (List, Empty);
257 procedure Append_List_To (To : List_Id; List : List_Id) is
259 Append_List (List, To);
266 procedure Append_To (To : List_Id; Node : Node_Id) is
275 procedure Delete_List (L : List_Id) is
279 while Is_Non_Empty_List (L) loop
280 N := Remove_Head (L);
284 -- Should recycle list header???
291 -- This subprogram is deliberately placed early on, out of alphabetical
292 -- order, so that it can be properly inlined from within this unit.
294 function First (List : List_Id) return Node_Id is
296 if List = No_List then
299 pragma Assert (List in First_List_Id .. Lists.Last);
300 return Lists.Table (List).First;
304 ----------------------
305 -- First_Non_Pragma --
306 ----------------------
308 function First_Non_Pragma (List : List_Id) return Node_Id is
309 N : constant Node_Id := First (List);
312 if Nkind (N) /= N_Pragma
314 Nkind (N) /= N_Null_Statement
318 return Next_Non_Pragma (N);
320 end First_Non_Pragma;
326 procedure Initialize is
327 E : constant List_Id := Error_List;
334 -- Allocate Error_List list header
336 Lists.Increment_Last;
337 Set_Parent (E, Empty);
338 Set_First (E, Empty);
346 procedure Insert_After (After : Node_Id; Node : Node_Id) is
348 procedure Insert_After_Debug;
349 pragma Inline (Insert_After_Debug);
350 -- Output debug information if Debug_Flag_N set
352 procedure Insert_After_Debug is
355 Write_Str ("Insert node");
356 Write_Int (Int (Node));
357 Write_Str (" after node ");
358 Write_Int (Int (After));
361 end Insert_After_Debug;
363 -- Start of processing for Insert_After
367 (Is_List_Member (After) and then not Is_List_Member (Node));
373 pragma Debug (Insert_After_Debug);
376 Before : constant Node_Id := Next (After);
377 LC : constant List_Id := List_Containing (After);
380 if Present (Before) then
381 Set_Prev (Before, Node);
386 Set_Next (After, Node);
388 Nodes.Table (Node).In_List := True;
390 Set_Prev (Node, After);
391 Set_Next (Node, Before);
392 Set_List_Link (Node, LC);
400 procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
402 procedure Insert_Before_Debug;
403 pragma Inline (Insert_Before_Debug);
404 -- Output debug information if Debug_Flag_N set
406 procedure Insert_Before_Debug is
409 Write_Str ("Insert node");
410 Write_Int (Int (Node));
411 Write_Str (" before node ");
412 Write_Int (Int (Before));
415 end Insert_Before_Debug;
417 -- Start of processing for Insert_Before
421 (Is_List_Member (Before) and then not Is_List_Member (Node));
427 pragma Debug (Insert_Before_Debug);
430 After : constant Node_Id := Prev (Before);
431 LC : constant List_Id := List_Containing (Before);
434 if Present (After) then
435 Set_Next (After, Node);
437 Set_First (LC, Node);
440 Set_Prev (Before, Node);
442 Nodes.Table (Node).In_List := True;
444 Set_Prev (Node, After);
445 Set_Next (Node, Before);
446 Set_List_Link (Node, LC);
450 -----------------------
451 -- Insert_List_After --
452 -----------------------
454 procedure Insert_List_After (After : Node_Id; List : List_Id) is
456 procedure Insert_List_After_Debug;
457 pragma Inline (Insert_List_After_Debug);
458 -- Output debug information if Debug_Flag_N set
460 procedure Insert_List_After_Debug is
463 Write_Str ("Insert list ");
464 Write_Int (Int (List));
465 Write_Str (" after node ");
466 Write_Int (Int (After));
469 end Insert_List_After_Debug;
471 -- Start of processing for Insert_List_After
474 pragma Assert (Is_List_Member (After));
476 if Is_Empty_List (List) then
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);
488 pragma Debug (Insert_List_After_Debug);
492 Set_List_Link (N, LC);
497 if Present (Before) then
498 Set_Prev (Before, L);
505 Set_Next (L, Before);
507 Set_First (List, Empty);
508 Set_Last (List, Empty);
511 end Insert_List_After;
513 ------------------------
514 -- Insert_List_Before --
515 ------------------------
517 procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
519 procedure Insert_List_Before_Debug;
520 pragma Inline (Insert_List_Before_Debug);
521 -- Output debug information if Debug_Flag_N set
523 procedure Insert_List_Before_Debug is
526 Write_Str ("Insert list ");
527 Write_Int (Int (List));
528 Write_Str (" before node ");
529 Write_Int (Int (Before));
532 end Insert_List_Before_Debug;
534 -- Start of prodcessing for Insert_List_Before
537 pragma Assert (Is_List_Member (Before));
539 if Is_Empty_List (List) then
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);
551 pragma Debug (Insert_List_Before_Debug);
555 Set_List_Link (N, LC);
560 if Present (After) then
566 Set_Prev (Before, L);
568 Set_Next (L, Before);
570 Set_First (List, Empty);
571 Set_Last (List, Empty);
574 end Insert_List_Before;
580 function Is_Empty_List (List : List_Id) return Boolean is
582 return First (List) = Empty;
589 function Is_List_Member (Node : Node_Id) return Boolean is
591 return Nodes.Table (Node).In_List;
594 -----------------------
595 -- Is_Non_Empty_List --
596 -----------------------
598 function Is_Non_Empty_List (List : List_Id) return Boolean is
600 return List /= No_List and then First (List) /= Empty;
601 end Is_Non_Empty_List;
607 -- This subprogram is deliberately placed early on, out of alphabetical
608 -- order, so that it can be properly inlined from within this unit.
610 function Last (List : List_Id) return Node_Id is
612 pragma Assert (List in First_List_Id .. Lists.Last);
613 return Lists.Table (List).Last;
620 function Last_List_Id return List_Id is
625 ---------------------
626 -- Last_Non_Pragma --
627 ---------------------
629 function Last_Non_Pragma (List : List_Id) return Node_Id is
630 N : constant Node_Id := Last (List);
633 if Nkind (N) /= N_Pragma then
636 return Prev_Non_Pragma (N);
640 ---------------------
641 -- List_Containing --
642 ---------------------
644 function List_Containing (Node : Node_Id) return List_Id is
646 pragma Assert (Is_List_Member (Node));
647 return List_Id (Nodes.Table (Node).Link);
654 function List_Length (List : List_Id) return Nat is
660 Node := First (List);
661 while Present (Node) loop
662 Result := Result + 1;
673 function Lists_Address return System.Address is
675 return Lists.Table (First_List_Id)'Address;
684 Lists.Locked := True;
687 Prev_Node.Locked := True;
688 Next_Node.Locked := True;
698 function New_Copy_List (List : List_Id) return List_Id is
703 if List = No_List then
710 while Present (E) loop
711 Append (New_Copy (E), NL);
719 ----------------------------
720 -- New_Copy_List_Original --
721 ----------------------------
723 function New_Copy_List_Original (List : List_Id) return List_Id is
728 if List = No_List then
735 while Present (E) loop
736 if Comes_From_Source (E) then
737 Append (New_Copy (E), NL);
745 end New_Copy_List_Original;
747 ------------------------
748 -- New_Copy_List_Tree --
749 ------------------------
751 function New_Copy_List_Tree (List : List_Id) return List_Id is
756 if List = No_List then
763 while Present (E) loop
764 Append (New_Copy_Tree (E), NL);
770 end New_Copy_List_Tree;
776 function New_List return List_Id is
778 procedure New_List_Debug;
779 pragma Inline (New_List_Debug);
780 -- Output debugging information if Debug_Flag_N is set
782 procedure New_List_Debug is
785 Write_Str ("Allocate new list, returned ID = ");
786 Write_Int (Int (Lists.Last));
791 -- Start of processing for New_List
794 Lists.Increment_Last;
797 List : constant List_Id := Lists.Last;
800 Set_Parent (List, Empty);
801 Set_First (List, Empty);
802 Set_Last (List, Empty);
804 pragma Debug (New_List_Debug);
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.
813 function New_List (Node : Node_Id) return List_Id is
815 procedure New_List_Debug;
816 pragma Inline (New_List_Debug);
817 -- Output debugging information if Debug_Flag_N is set
819 procedure New_List_Debug is
822 Write_Str ("Allocate new list, returned ID = ");
823 Write_Int (Int (Lists.Last));
828 -- Start of processing for New_List
835 pragma Assert (not Is_List_Member (Node));
837 Lists.Increment_Last;
840 List : constant List_Id := Lists.Last;
843 Set_Parent (List, Empty);
844 Set_First (List, Node);
845 Set_Last (List, Node);
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);
857 function New_List (Node1, Node2 : Node_Id) return List_Id is
858 L : constant List_Id := New_List (Node1);
865 function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
866 L : constant List_Id := New_List (Node1);
874 function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
875 L : constant List_Id := New_List (Node1);
892 L : constant List_Id := New_List (Node1);
911 L : constant List_Id := New_List (Node1);
926 -- This subprogram is deliberately placed early on, out of alphabetical
927 -- order, so that it can be properly inlined from within this unit.
929 function Next (Node : Node_Id) return Node_Id is
931 pragma Assert (Is_List_Member (Node));
932 return Next_Node.Table (Node);
935 procedure Next (Node : in out Node_Id) is
940 -----------------------
941 -- Next_Node_Address --
942 -----------------------
944 function Next_Node_Address return System.Address is
946 return Next_Node.Table (First_Node_Id)'Address;
947 end Next_Node_Address;
949 ---------------------
950 -- Next_Non_Pragma --
951 ---------------------
953 function Next_Non_Pragma (Node : Node_Id) return Node_Id is
960 exit when Nkind (N) /= N_Pragma
962 Nkind (N) /= N_Null_Statement;
968 procedure Next_Non_Pragma (Node : in out Node_Id) is
970 Node := Next_Non_Pragma (Node);
977 -- This subprogram is deliberately placed early on, out of alphabetical
978 -- order, so that it can be properly inlined from within this unit.
980 function No (List : List_Id) return Boolean is
982 return List = No_List;
989 function Num_Lists return Nat is
991 return Int (Lists.Last) - Int (Lists.First) + 1;
998 function p (U : Union_Id) return Node_Id is
1000 if U in Node_Range then
1001 return Parent (Node_Id (U));
1003 elsif U in List_Range then
1004 return Parent (List_Id (U));
1015 function Parent (List : List_Id) return Node_Id is
1017 pragma Assert (List in First_List_Id .. Lists.Last);
1018 return Lists.Table (List).Parent;
1025 function Pick (List : List_Id; Index : Pos) return Node_Id is
1029 Elmt := First (List);
1030 for J in 1 .. Index - 1 loop
1031 Elmt := Next (Elmt);
1041 procedure Prepend (Node : Node_Id; To : List_Id) is
1042 F : constant Node_Id := First (To);
1045 pragma Assert (not Is_List_Member (Node));
1047 if Node = Error then
1051 pragma Debug (Prepend_Debug (Node, To));
1054 Set_Last (To, Node);
1059 Set_First (To, Node);
1061 Nodes.Table (Node).In_List := True;
1064 Set_Prev (Node, Empty);
1065 Set_List_Link (Node, To);
1072 procedure Prepend_Debug (Node : Node_Id; To : List_Id) is
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));
1087 procedure Prepend_To (To : List_Id; Node : Node_Id) is
1096 function Present (List : List_Id) return Boolean is
1098 return List /= No_List;
1105 -- This subprogram is deliberately placed early on, out of alphabetical
1106 -- order, so that it can be properly inlined from within this unit.
1108 function Prev (Node : Node_Id) return Node_Id is
1110 pragma Assert (Is_List_Member (Node));
1111 return Prev_Node.Table (Node);
1114 procedure Prev (Node : in out Node_Id) is
1116 Node := Prev (Node);
1119 -----------------------
1120 -- Prev_Node_Address --
1121 -----------------------
1123 function Prev_Node_Address return System.Address is
1125 return Prev_Node.Table (First_Node_Id)'Address;
1126 end Prev_Node_Address;
1128 ---------------------
1129 -- Prev_Non_Pragma --
1130 ---------------------
1132 function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1139 exit when Nkind (N) /= N_Pragma;
1143 end Prev_Non_Pragma;
1145 procedure Prev_Non_Pragma (Node : in out Node_Id) is
1147 Node := Prev_Non_Pragma (Node);
1148 end Prev_Non_Pragma;
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);
1159 procedure Remove_Debug;
1160 pragma Inline (Remove_Debug);
1161 -- Output debug information if Debug_Flag_N set
1163 procedure Remove_Debug is
1165 if Debug_Flag_N then
1166 Write_Str ("Remove node ");
1167 Write_Int (Int (Node));
1172 -- Start of processing for Remove
1175 pragma Debug (Remove_Debug);
1178 Set_First (Lst, Nxt);
1180 Set_Next (Prv, Nxt);
1184 Set_Last (Lst, Prv);
1186 Set_Prev (Nxt, Prv);
1189 Nodes.Table (Node).In_List := False;
1190 Set_Parent (Node, Empty);
1197 function Remove_Head (List : List_Id) return Node_Id is
1198 Frst : constant Node_Id := First (List);
1200 procedure Remove_Head_Debug;
1201 pragma Inline (Remove_Head_Debug);
1202 -- Output debug information if Debug_Flag_N set
1204 procedure Remove_Head_Debug is
1206 if Debug_Flag_N then
1207 Write_Str ("Remove head of list ");
1208 Write_Int (Int (List));
1211 end Remove_Head_Debug;
1213 -- Start of processing for Remove_Head
1216 pragma Debug (Remove_Head_Debug);
1218 if Frst = Empty then
1223 Nxt : constant Node_Id := Next (Frst);
1226 Set_First (List, Nxt);
1229 Set_Last (List, Empty);
1231 Set_Prev (Nxt, Empty);
1234 Nodes.Table (Frst).In_List := False;
1235 Set_Parent (Frst, Empty);
1245 function Remove_Next (Node : Node_Id) return Node_Id is
1246 Nxt : constant Node_Id := Next (Node);
1249 if Present (Nxt) then
1251 Nxt2 : constant Node_Id := Next (Nxt);
1252 LC : constant List_Id := List_Containing (Node);
1255 pragma Debug (Remove_Next_Debug (Node));
1256 Set_Next (Node, Nxt2);
1259 Set_Last (LC, Node);
1261 Set_Prev (Nxt2, Node);
1264 Nodes.Table (Nxt).In_List := False;
1265 Set_Parent (Nxt, Empty);
1272 -----------------------
1273 -- Remove_Next_Debug --
1274 -----------------------
1276 procedure Remove_Next_Debug (Node : Node_Id) is
1278 if Debug_Flag_N then
1279 Write_Str ("Remove next node after ");
1280 Write_Int (Int (Node));
1283 end Remove_Next_Debug;
1289 -- This subprogram is deliberately placed early on, out of alphabetical
1290 -- order, so that it can be properly inlined from within this unit.
1292 procedure Set_First (List : List_Id; To : Node_Id) is
1294 Lists.Table (List).First := To;
1301 -- This subprogram is deliberately placed early on, out of alphabetical
1302 -- order, so that it can be properly inlined from within this unit.
1304 procedure Set_Last (List : List_Id; To : Node_Id) is
1306 Lists.Table (List).Last := To;
1313 -- This subprogram is deliberately placed early on, out of alphabetical
1314 -- order, so that it can be properly inlined from within this unit.
1316 procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1318 Nodes.Table (Node).Link := Union_Id (To);
1325 -- This subprogram is deliberately placed early on, out of alphabetical
1326 -- order, so that it can be properly inlined from within this unit.
1328 procedure Set_Next (Node : Node_Id; To : Node_Id) is
1330 Next_Node.Table (Node) := To;
1337 procedure Set_Parent (List : List_Id; Node : Node_Id) is
1339 pragma Assert (List in First_List_Id .. Lists.Last);
1340 Lists.Table (List).Parent := Node;
1347 -- This subprogram is deliberately placed early on, out of alphabetical
1348 -- order, so that it can be properly inlined from within this unit.
1350 procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1352 Prev_Node.Table (Node) := To;
1359 procedure Tree_Read is
1362 Next_Node.Tree_Read;
1363 Prev_Node.Tree_Read;
1370 procedure Tree_Write is
1373 Next_Node.Tree_Write;
1374 Prev_Node.Tree_Write;