1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 Set_First (List : List_Id; To : Node_Id);
110 pragma Inline (Set_First);
111 -- Sets First field of list header List to reference To
113 procedure Set_Last (List : List_Id; To : Node_Id);
114 pragma Inline (Set_Last);
115 -- Sets Last field of list header List to reference To
117 procedure Set_List_Link (Node : Node_Id; To : List_Id);
118 pragma Inline (Set_List_Link);
119 -- Sets list link of Node to list header To
121 procedure Set_Next (Node : Node_Id; To : Node_Id);
122 pragma Inline (Set_Next);
123 -- Sets the Next_Node pointer for Node to reference To
125 procedure Set_Prev (Node : Node_Id; To : Node_Id);
126 pragma Inline (Set_Prev);
127 -- Sets the Prev_Node pointer for Node to reference To
129 --------------------------
130 -- Allocate_List_Tables --
131 --------------------------
133 procedure Allocate_List_Tables (N : Node_Id) is
135 Next_Node.Set_Last (N);
136 Prev_Node.Set_Last (N);
137 end Allocate_List_Tables;
143 procedure Append (Node : Node_Id; To : List_Id) is
144 L : constant Node_Id := Last (To);
146 procedure Append_Debug;
147 pragma Inline (Append_Debug);
148 -- Output debug information if Debug_Flag_N set
154 procedure Append_Debug is
157 Write_Str ("Append node ");
158 Write_Int (Int (Node));
159 Write_Str (" to list ");
160 Write_Int (Int (To));
165 -- Start of processing for Append
168 pragma Assert (not Is_List_Member (Node));
174 pragma Debug (Append_Debug);
177 Set_First (To, Node);
184 Nodes.Table (Node).In_List := True;
186 Set_Next (Node, Empty);
188 Set_List_Link (Node, To);
195 procedure Append_List (List : List_Id; To : List_Id) is
197 procedure Append_List_Debug;
198 pragma Inline (Append_List_Debug);
199 -- Output debug information if Debug_Flag_N set
201 -----------------------
202 -- Append_List_Debug --
203 -----------------------
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 function First (List : List_Id) return Node_Id is
293 if List = No_List then
296 pragma Assert (List in First_List_Id .. Lists.Last);
297 return Lists.Table (List).First;
301 ----------------------
302 -- First_Non_Pragma --
303 ----------------------
305 function First_Non_Pragma (List : List_Id) return Node_Id is
306 N : constant Node_Id := First (List);
309 if Nkind (N) /= N_Pragma
311 Nkind (N) /= N_Null_Statement
315 return Next_Non_Pragma (N);
317 end First_Non_Pragma;
323 procedure Initialize is
324 E : constant List_Id := Error_List;
331 -- Allocate Error_List list header
333 Lists.Increment_Last;
334 Set_Parent (E, Empty);
335 Set_First (E, Empty);
343 procedure Insert_After (After : Node_Id; Node : Node_Id) is
345 procedure Insert_After_Debug;
346 pragma Inline (Insert_After_Debug);
347 -- Output debug information if Debug_Flag_N set
349 ------------------------
350 -- Insert_After_Debug --
351 ------------------------
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 -------------------------
408 -- Insert_Before_Debug --
409 -------------------------
411 procedure Insert_Before_Debug is
414 Write_Str ("Insert node");
415 Write_Int (Int (Node));
416 Write_Str (" before node ");
417 Write_Int (Int (Before));
420 end Insert_Before_Debug;
422 -- Start of processing for Insert_Before
426 (Is_List_Member (Before) and then not Is_List_Member (Node));
432 pragma Debug (Insert_Before_Debug);
435 After : constant Node_Id := Prev (Before);
436 LC : constant List_Id := List_Containing (Before);
439 if Present (After) then
440 Set_Next (After, Node);
442 Set_First (LC, Node);
445 Set_Prev (Before, Node);
447 Nodes.Table (Node).In_List := True;
449 Set_Prev (Node, After);
450 Set_Next (Node, Before);
451 Set_List_Link (Node, LC);
455 -----------------------
456 -- Insert_List_After --
457 -----------------------
459 procedure Insert_List_After (After : Node_Id; List : List_Id) is
461 procedure Insert_List_After_Debug;
462 pragma Inline (Insert_List_After_Debug);
463 -- Output debug information if Debug_Flag_N set
465 -----------------------------
466 -- Insert_List_After_Debug --
467 -----------------------------
469 procedure Insert_List_After_Debug is
472 Write_Str ("Insert list ");
473 Write_Int (Int (List));
474 Write_Str (" after node ");
475 Write_Int (Int (After));
478 end Insert_List_After_Debug;
480 -- Start of processing for Insert_List_After
483 pragma Assert (Is_List_Member (After));
485 if Is_Empty_List (List) then
490 Before : constant Node_Id := Next (After);
491 LC : constant List_Id := List_Containing (After);
492 F : constant Node_Id := First (List);
493 L : constant Node_Id := Last (List);
497 pragma Debug (Insert_List_After_Debug);
501 Set_List_Link (N, LC);
506 if Present (Before) then
507 Set_Prev (Before, L);
514 Set_Next (L, Before);
516 Set_First (List, Empty);
517 Set_Last (List, Empty);
520 end Insert_List_After;
522 ------------------------
523 -- Insert_List_Before --
524 ------------------------
526 procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
528 procedure Insert_List_Before_Debug;
529 pragma Inline (Insert_List_Before_Debug);
530 -- Output debug information if Debug_Flag_N set
532 ------------------------------
533 -- Insert_List_Before_Debug --
534 ------------------------------
536 procedure Insert_List_Before_Debug is
539 Write_Str ("Insert list ");
540 Write_Int (Int (List));
541 Write_Str (" before node ");
542 Write_Int (Int (Before));
545 end Insert_List_Before_Debug;
547 -- Start of prodcessing for Insert_List_Before
550 pragma Assert (Is_List_Member (Before));
552 if Is_Empty_List (List) then
557 After : constant Node_Id := Prev (Before);
558 LC : constant List_Id := List_Containing (Before);
559 F : constant Node_Id := First (List);
560 L : constant Node_Id := Last (List);
564 pragma Debug (Insert_List_Before_Debug);
568 Set_List_Link (N, LC);
573 if Present (After) then
579 Set_Prev (Before, L);
581 Set_Next (L, Before);
583 Set_First (List, Empty);
584 Set_Last (List, Empty);
587 end Insert_List_Before;
593 function Is_Empty_List (List : List_Id) return Boolean is
595 return First (List) = Empty;
602 function Is_List_Member (Node : Node_Id) return Boolean is
604 return Nodes.Table (Node).In_List;
607 -----------------------
608 -- Is_Non_Empty_List --
609 -----------------------
611 function Is_Non_Empty_List (List : List_Id) return Boolean is
613 return List /= No_List and then First (List) /= Empty;
614 end Is_Non_Empty_List;
620 function Last (List : List_Id) return Node_Id is
622 pragma Assert (List in First_List_Id .. Lists.Last);
623 return Lists.Table (List).Last;
630 function Last_List_Id return List_Id is
635 ---------------------
636 -- Last_Non_Pragma --
637 ---------------------
639 function Last_Non_Pragma (List : List_Id) return Node_Id is
640 N : constant Node_Id := Last (List);
643 if Nkind (N) /= N_Pragma then
646 return Prev_Non_Pragma (N);
650 ---------------------
651 -- List_Containing --
652 ---------------------
654 function List_Containing (Node : Node_Id) return List_Id is
656 pragma Assert (Is_List_Member (Node));
657 return List_Id (Nodes.Table (Node).Link);
664 function List_Length (List : List_Id) return Nat is
670 Node := First (List);
671 while Present (Node) loop
672 Result := Result + 1;
683 function Lists_Address return System.Address is
685 return Lists.Table (First_List_Id)'Address;
694 Lists.Locked := True;
697 Prev_Node.Locked := True;
698 Next_Node.Locked := True;
708 function New_Copy_List (List : List_Id) return List_Id is
713 if List = No_List then
720 while Present (E) loop
721 Append (New_Copy (E), NL);
729 ----------------------------
730 -- New_Copy_List_Original --
731 ----------------------------
733 function New_Copy_List_Original (List : List_Id) return List_Id is
738 if List = No_List then
745 while Present (E) loop
746 if Comes_From_Source (E) then
747 Append (New_Copy (E), NL);
755 end New_Copy_List_Original;
757 ------------------------
758 -- New_Copy_List_Tree --
759 ------------------------
761 function New_Copy_List_Tree (List : List_Id) return List_Id is
766 if List = No_List then
773 while Present (E) loop
774 Append (New_Copy_Tree (E), NL);
780 end New_Copy_List_Tree;
786 function New_List return List_Id is
788 procedure New_List_Debug;
789 pragma Inline (New_List_Debug);
790 -- Output debugging information if Debug_Flag_N is set
796 procedure New_List_Debug is
799 Write_Str ("Allocate new list, returned ID = ");
800 Write_Int (Int (Lists.Last));
805 -- Start of processing for New_List
808 Lists.Increment_Last;
811 List : constant List_Id := Lists.Last;
814 Set_Parent (List, Empty);
815 Set_First (List, Empty);
816 Set_Last (List, Empty);
818 pragma Debug (New_List_Debug);
823 -- Since the one argument case is common, we optimize to build the right
824 -- list directly, rather than first building an empty list and then doing
825 -- the insertion, which results in some unnecessary work.
827 function New_List (Node : Node_Id) return List_Id is
829 procedure New_List_Debug;
830 pragma Inline (New_List_Debug);
831 -- Output debugging information if Debug_Flag_N is set
837 procedure New_List_Debug is
840 Write_Str ("Allocate new list, returned ID = ");
841 Write_Int (Int (Lists.Last));
846 -- Start of processing for New_List
853 pragma Assert (not Is_List_Member (Node));
855 Lists.Increment_Last;
858 List : constant List_Id := Lists.Last;
861 Set_Parent (List, Empty);
862 Set_First (List, Node);
863 Set_Last (List, Node);
865 Nodes.Table (Node).In_List := True;
866 Set_List_Link (Node, List);
867 Set_Prev (Node, Empty);
868 Set_Next (Node, Empty);
869 pragma Debug (New_List_Debug);
875 function New_List (Node1, Node2 : Node_Id) return List_Id is
876 L : constant List_Id := New_List (Node1);
882 function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
883 L : constant List_Id := New_List (Node1);
890 function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
891 L : constant List_Id := New_List (Node1);
904 Node5 : Node_Id) return List_Id
906 L : constant List_Id := New_List (Node1);
921 Node6 : Node_Id) return List_Id
923 L : constant List_Id := New_List (Node1);
937 function Next (Node : Node_Id) return Node_Id is
939 pragma Assert (Is_List_Member (Node));
940 return Next_Node.Table (Node);
943 procedure Next (Node : in out Node_Id) is
948 -----------------------
949 -- Next_Node_Address --
950 -----------------------
952 function Next_Node_Address return System.Address is
954 return Next_Node.Table (First_Node_Id)'Address;
955 end Next_Node_Address;
957 ---------------------
958 -- Next_Non_Pragma --
959 ---------------------
961 function Next_Non_Pragma (Node : Node_Id) return Node_Id is
968 exit when Nkind (N) /= N_Pragma
970 Nkind (N) /= N_Null_Statement;
976 procedure Next_Non_Pragma (Node : in out Node_Id) is
978 Node := Next_Non_Pragma (Node);
985 function No (List : List_Id) return Boolean is
987 return List = No_List;
994 function Num_Lists return Nat is
996 return Int (Lists.Last) - Int (Lists.First) + 1;
1003 function p (U : Union_Id) return Node_Id is
1005 if U in Node_Range then
1006 return Parent (Node_Id (U));
1007 elsif U in List_Range then
1008 return Parent (List_Id (U));
1018 function Parent (List : List_Id) return Node_Id is
1020 pragma Assert (List in First_List_Id .. Lists.Last);
1021 return Lists.Table (List).Parent;
1028 function Pick (List : List_Id; Index : Pos) return Node_Id is
1032 Elmt := First (List);
1033 for J in 1 .. Index - 1 loop
1034 Elmt := Next (Elmt);
1044 procedure Prepend (Node : Node_Id; To : List_Id) is
1045 F : constant Node_Id := First (To);
1047 procedure Prepend_Debug;
1048 pragma Inline (Prepend_Debug);
1049 -- Output debug information if Debug_Flag_N set
1055 procedure Prepend_Debug is
1057 if Debug_Flag_N then
1058 Write_Str ("Prepend node ");
1059 Write_Int (Int (Node));
1060 Write_Str (" to list ");
1061 Write_Int (Int (To));
1066 -- Start of processing for Prepend_Debug
1069 pragma Assert (not Is_List_Member (Node));
1071 if Node = Error then
1075 pragma Debug (Prepend_Debug);
1078 Set_Last (To, Node);
1083 Set_First (To, Node);
1085 Nodes.Table (Node).In_List := True;
1088 Set_Prev (Node, Empty);
1089 Set_List_Link (Node, To);
1096 procedure Prepend_To (To : List_Id; Node : Node_Id) is
1105 function Present (List : List_Id) return Boolean is
1107 return List /= No_List;
1114 function Prev (Node : Node_Id) return Node_Id is
1116 pragma Assert (Is_List_Member (Node));
1117 return Prev_Node.Table (Node);
1120 procedure Prev (Node : in out Node_Id) is
1122 Node := Prev (Node);
1125 -----------------------
1126 -- Prev_Node_Address --
1127 -----------------------
1129 function Prev_Node_Address return System.Address is
1131 return Prev_Node.Table (First_Node_Id)'Address;
1132 end Prev_Node_Address;
1134 ---------------------
1135 -- Prev_Non_Pragma --
1136 ---------------------
1138 function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1145 exit when Nkind (N) /= N_Pragma;
1149 end Prev_Non_Pragma;
1151 procedure Prev_Non_Pragma (Node : in out Node_Id) is
1153 Node := Prev_Non_Pragma (Node);
1154 end Prev_Non_Pragma;
1160 procedure Remove (Node : Node_Id) is
1161 Lst : constant List_Id := List_Containing (Node);
1162 Prv : constant Node_Id := Prev (Node);
1163 Nxt : constant Node_Id := Next (Node);
1165 procedure Remove_Debug;
1166 pragma Inline (Remove_Debug);
1167 -- Output debug information if Debug_Flag_N set
1173 procedure Remove_Debug is
1175 if Debug_Flag_N then
1176 Write_Str ("Remove node ");
1177 Write_Int (Int (Node));
1182 -- Start of processing for Remove
1185 pragma Debug (Remove_Debug);
1188 Set_First (Lst, Nxt);
1190 Set_Next (Prv, Nxt);
1194 Set_Last (Lst, Prv);
1196 Set_Prev (Nxt, Prv);
1199 Nodes.Table (Node).In_List := False;
1200 Set_Parent (Node, Empty);
1207 function Remove_Head (List : List_Id) return Node_Id is
1208 Frst : constant Node_Id := First (List);
1210 procedure Remove_Head_Debug;
1211 pragma Inline (Remove_Head_Debug);
1212 -- Output debug information if Debug_Flag_N set
1214 -----------------------
1215 -- Remove_Head_Debug --
1216 -----------------------
1218 procedure Remove_Head_Debug is
1220 if Debug_Flag_N then
1221 Write_Str ("Remove head of list ");
1222 Write_Int (Int (List));
1225 end Remove_Head_Debug;
1227 -- Start of processing for Remove_Head
1230 pragma Debug (Remove_Head_Debug);
1232 if Frst = Empty then
1237 Nxt : constant Node_Id := Next (Frst);
1240 Set_First (List, Nxt);
1243 Set_Last (List, Empty);
1245 Set_Prev (Nxt, Empty);
1248 Nodes.Table (Frst).In_List := False;
1249 Set_Parent (Frst, Empty);
1259 function Remove_Next (Node : Node_Id) return Node_Id is
1260 Nxt : constant Node_Id := Next (Node);
1262 procedure Remove_Next_Debug;
1263 pragma Inline (Remove_Next_Debug);
1264 -- Output debug information if Debug_Flag_N set
1266 -----------------------
1267 -- Remove_Next_Debug --
1268 -----------------------
1270 procedure Remove_Next_Debug is
1272 if Debug_Flag_N then
1273 Write_Str ("Remove next node after ");
1274 Write_Int (Int (Node));
1277 end Remove_Next_Debug;
1279 -- Start of processing for Remove_Next
1282 if Present (Nxt) then
1284 Nxt2 : constant Node_Id := Next (Nxt);
1285 LC : constant List_Id := List_Containing (Node);
1288 pragma Debug (Remove_Next_Debug);
1289 Set_Next (Node, Nxt2);
1292 Set_Last (LC, Node);
1294 Set_Prev (Nxt2, Node);
1297 Nodes.Table (Nxt).In_List := False;
1298 Set_Parent (Nxt, Empty);
1309 procedure Set_First (List : List_Id; To : Node_Id) is
1311 Lists.Table (List).First := To;
1318 procedure Set_Last (List : List_Id; To : Node_Id) is
1320 Lists.Table (List).Last := To;
1327 procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1329 Nodes.Table (Node).Link := Union_Id (To);
1336 procedure Set_Next (Node : Node_Id; To : Node_Id) is
1338 Next_Node.Table (Node) := To;
1345 procedure Set_Parent (List : List_Id; Node : Node_Id) is
1347 pragma Assert (List in First_List_Id .. Lists.Last);
1348 Lists.Table (List).Parent := Node;
1355 procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1357 Prev_Node.Table (Node) := To;
1364 procedure Tree_Read is
1367 Next_Node.Tree_Read;
1368 Prev_Node.Tree_Read;
1375 procedure Tree_Write is
1378 Next_Node.Tree_Write;
1379 Prev_Node.Tree_Write;