File : nlists.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- N L I S T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
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
34
35 with Alloc;
36 with Atree; use Atree;
37 with Debug; use Debug;
38 with Output; use Output;
39 with Sinfo; use Sinfo;
40 with Table;
41
42 package body Nlists is
43
44 use Atree_Private_Part;
45 -- Get access to Nodes table
46
47 ----------------------------------
48 -- Implementation of Node Lists --
49 ----------------------------------
50
51 -- A node list is represented by a list header which contains
52 -- three fields:
53
54 type List_Header is record
55 First : Node_Or_Entity_Id;
56 -- Pointer to first node in list. Empty if list is empty
57
58 Last : Node_Or_Entity_Id;
59 -- Pointer to last node in list. Empty if list is empty
60
61 Parent : Node_Id;
62 -- Pointer to parent of list. Empty if list has no parent
63 end record;
64
65 -- The node lists are stored in a table indexed by List_Id values
66
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");
74
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.
79
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.
86
87 package Next_Node is new Table.Table (
88 Table_Component_Type => Node_Or_Entity_Id,
89 Table_Index_Type => Node_Or_Entity_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");
94
95 package Prev_Node is new Table.Table (
96 Table_Component_Type => Node_Or_Entity_Id,
97 Table_Index_Type => Node_Or_Entity_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");
102
103 -----------------------
104 -- Local Subprograms --
105 -----------------------
106
107 procedure Set_First (List : List_Id; To : Node_Or_Entity_Id);
108 pragma Inline (Set_First);
109 -- Sets First field of list header List to reference To
110
111 procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id);
112 pragma Inline (Set_Last);
113 -- Sets Last field of list header List to reference To
114
115 procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id);
116 pragma Inline (Set_List_Link);
117 -- Sets list link of Node to list header To
118
119 procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
120 pragma Inline (Set_Next);
121 -- Sets the Next_Node pointer for Node to reference To
122
123 procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
124 pragma Inline (Set_Prev);
125 -- Sets the Prev_Node pointer for Node to reference To
126
127 --------------------------
128 -- Allocate_List_Tables --
129 --------------------------
130
131 procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is
132 Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last;
133
134 begin
135 pragma Assert (N >= Old_Last);
136 Next_Node.Set_Last (N);
137 Prev_Node.Set_Last (N);
138
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.
141
142 for J in Old_Last + 1 .. N loop
143 Next_Node.Table (J) := Empty;
144 Prev_Node.Table (J) := Empty;
145 end loop;
146 end Allocate_List_Tables;
147
148 ------------
149 -- Append --
150 ------------
151
152 procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is
153 L : constant Node_Or_Entity_Id := Last (To);
154
155 procedure Append_Debug;
156 pragma Inline (Append_Debug);
157 -- Output debug information if Debug_Flag_N set
158
159 ------------------
160 -- Append_Debug --
161 ------------------
162
163 procedure Append_Debug is
164 begin
165 if Debug_Flag_N then
166 Write_Str ("Append node ");
167 Write_Int (Int (Node));
168 Write_Str (" to list ");
169 Write_Int (Int (To));
170 Write_Eol;
171 end if;
172 end Append_Debug;
173
174 -- Start of processing for Append
175
176 begin
177 pragma Assert (not Is_List_Member (Node));
178
179 if Node = Error then
180 return;
181 end if;
182
183 pragma Debug (Append_Debug);
184
185 if No (L) then
186 Set_First (To, Node);
187 else
188 Set_Next (L, Node);
189 end if;
190
191 Set_Last (To, Node);
192
193 Nodes.Table (Node).In_List := True;
194
195 Set_Next (Node, Empty);
196 Set_Prev (Node, L);
197 Set_List_Link (Node, To);
198 end Append;
199
200 -----------------
201 -- Append_List --
202 -----------------
203
204 procedure Append_List (List : List_Id; To : List_Id) is
205
206 procedure Append_List_Debug;
207 pragma Inline (Append_List_Debug);
208 -- Output debug information if Debug_Flag_N set
209
210 -----------------------
211 -- Append_List_Debug --
212 -----------------------
213
214 procedure Append_List_Debug is
215 begin
216 if Debug_Flag_N then
217 Write_Str ("Append list ");
218 Write_Int (Int (List));
219 Write_Str (" to list ");
220 Write_Int (Int (To));
221 Write_Eol;
222 end if;
223 end Append_List_Debug;
224
225 -- Start of processing for Append_List
226
227 begin
228 if Is_Empty_List (List) then
229 return;
230
231 else
232 declare
233 L : constant Node_Or_Entity_Id := Last (To);
234 F : constant Node_Or_Entity_Id := First (List);
235 N : Node_Or_Entity_Id;
236
237 begin
238 pragma Debug (Append_List_Debug);
239
240 N := F;
241 loop
242 Set_List_Link (N, To);
243 N := Next (N);
244 exit when No (N);
245 end loop;
246
247 if No (L) then
248 Set_First (To, F);
249 else
250 Set_Next (L, F);
251 end if;
252
253 Set_Prev (F, L);
254 Set_Last (To, Last (List));
255
256 Set_First (List, Empty);
257 Set_Last (List, Empty);
258 end;
259 end if;
260 end Append_List;
261
262 --------------------
263 -- Append_List_To --
264 --------------------
265
266 procedure Append_List_To (To : List_Id; List : List_Id) is
267 begin
268 Append_List (List, To);
269 end Append_List_To;
270
271 ---------------
272 -- Append_To --
273 ---------------
274
275 procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id) is
276 begin
277 Append (Node, To);
278 end Append_To;
279
280 -----------
281 -- First --
282 -----------
283
284 function First (List : List_Id) return Node_Or_Entity_Id is
285 begin
286 if List = No_List then
287 return Empty;
288 else
289 pragma Assert (List <= Lists.Last);
290 return Lists.Table (List).First;
291 end if;
292 end First;
293
294 ----------------------
295 -- First_Non_Pragma --
296 ----------------------
297
298 function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
299 N : constant Node_Or_Entity_Id := First (List);
300 begin
301 if Nkind (N) /= N_Pragma
302 and then
303 Nkind (N) /= N_Null_Statement
304 then
305 return N;
306 else
307 return Next_Non_Pragma (N);
308 end if;
309 end First_Non_Pragma;
310
311 ----------------
312 -- Initialize --
313 ----------------
314
315 procedure Initialize is
316 E : constant List_Id := Error_List;
317
318 begin
319 Lists.Init;
320 Next_Node.Init;
321 Prev_Node.Init;
322
323 -- Allocate Error_List list header
324
325 Lists.Increment_Last;
326 Set_Parent (E, Empty);
327 Set_First (E, Empty);
328 Set_Last (E, Empty);
329 end Initialize;
330
331 ------------------
332 -- In_Same_List --
333 ------------------
334
335 function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is
336 begin
337 return List_Containing (N1) = List_Containing (N2);
338 end In_Same_List;
339
340 ------------------
341 -- Insert_After --
342 ------------------
343
344 procedure Insert_After
345 (After : Node_Or_Entity_Id;
346 Node : Node_Or_Entity_Id)
347 is
348 procedure Insert_After_Debug;
349 pragma Inline (Insert_After_Debug);
350 -- Output debug information if Debug_Flag_N set
351
352 ------------------------
353 -- Insert_After_Debug --
354 ------------------------
355
356 procedure Insert_After_Debug is
357 begin
358 if Debug_Flag_N then
359 Write_Str ("Insert node");
360 Write_Int (Int (Node));
361 Write_Str (" after node ");
362 Write_Int (Int (After));
363 Write_Eol;
364 end if;
365 end Insert_After_Debug;
366
367 -- Start of processing for Insert_After
368
369 begin
370 pragma Assert
371 (Is_List_Member (After) and then not Is_List_Member (Node));
372
373 if Node = Error then
374 return;
375 end if;
376
377 pragma Debug (Insert_After_Debug);
378
379 declare
380 Before : constant Node_Or_Entity_Id := Next (After);
381 LC : constant List_Id := List_Containing (After);
382
383 begin
384 if Present (Before) then
385 Set_Prev (Before, Node);
386 else
387 Set_Last (LC, Node);
388 end if;
389
390 Set_Next (After, Node);
391
392 Nodes.Table (Node).In_List := True;
393
394 Set_Prev (Node, After);
395 Set_Next (Node, Before);
396 Set_List_Link (Node, LC);
397 end;
398 end Insert_After;
399
400 -------------------
401 -- Insert_Before --
402 -------------------
403
404 procedure Insert_Before
405 (Before : Node_Or_Entity_Id;
406 Node : Node_Or_Entity_Id)
407 is
408 procedure Insert_Before_Debug;
409 pragma Inline (Insert_Before_Debug);
410 -- Output debug information if Debug_Flag_N set
411
412 -------------------------
413 -- Insert_Before_Debug --
414 -------------------------
415
416 procedure Insert_Before_Debug is
417 begin
418 if Debug_Flag_N then
419 Write_Str ("Insert node");
420 Write_Int (Int (Node));
421 Write_Str (" before node ");
422 Write_Int (Int (Before));
423 Write_Eol;
424 end if;
425 end Insert_Before_Debug;
426
427 -- Start of processing for Insert_Before
428
429 begin
430 pragma Assert
431 (Is_List_Member (Before) and then not Is_List_Member (Node));
432
433 if Node = Error then
434 return;
435 end if;
436
437 pragma Debug (Insert_Before_Debug);
438
439 declare
440 After : constant Node_Or_Entity_Id := Prev (Before);
441 LC : constant List_Id := List_Containing (Before);
442
443 begin
444 if Present (After) then
445 Set_Next (After, Node);
446 else
447 Set_First (LC, Node);
448 end if;
449
450 Set_Prev (Before, Node);
451
452 Nodes.Table (Node).In_List := True;
453
454 Set_Prev (Node, After);
455 Set_Next (Node, Before);
456 Set_List_Link (Node, LC);
457 end;
458 end Insert_Before;
459
460 -----------------------
461 -- Insert_List_After --
462 -----------------------
463
464 procedure Insert_List_After (After : Node_Or_Entity_Id; List : List_Id) is
465
466 procedure Insert_List_After_Debug;
467 pragma Inline (Insert_List_After_Debug);
468 -- Output debug information if Debug_Flag_N set
469
470 -----------------------------
471 -- Insert_List_After_Debug --
472 -----------------------------
473
474 procedure Insert_List_After_Debug is
475 begin
476 if Debug_Flag_N then
477 Write_Str ("Insert list ");
478 Write_Int (Int (List));
479 Write_Str (" after node ");
480 Write_Int (Int (After));
481 Write_Eol;
482 end if;
483 end Insert_List_After_Debug;
484
485 -- Start of processing for Insert_List_After
486
487 begin
488 pragma Assert (Is_List_Member (After));
489
490 if Is_Empty_List (List) then
491 return;
492
493 else
494 declare
495 Before : constant Node_Or_Entity_Id := Next (After);
496 LC : constant List_Id := List_Containing (After);
497 F : constant Node_Or_Entity_Id := First (List);
498 L : constant Node_Or_Entity_Id := Last (List);
499 N : Node_Or_Entity_Id;
500
501 begin
502 pragma Debug (Insert_List_After_Debug);
503
504 N := F;
505 loop
506 Set_List_Link (N, LC);
507 exit when N = L;
508 N := Next (N);
509 end loop;
510
511 if Present (Before) then
512 Set_Prev (Before, L);
513 else
514 Set_Last (LC, L);
515 end if;
516
517 Set_Next (After, F);
518 Set_Prev (F, After);
519 Set_Next (L, Before);
520
521 Set_First (List, Empty);
522 Set_Last (List, Empty);
523 end;
524 end if;
525 end Insert_List_After;
526
527 ------------------------
528 -- Insert_List_Before --
529 ------------------------
530
531 procedure Insert_List_Before (Before : Node_Or_Entity_Id; List : List_Id) is
532
533 procedure Insert_List_Before_Debug;
534 pragma Inline (Insert_List_Before_Debug);
535 -- Output debug information if Debug_Flag_N set
536
537 ------------------------------
538 -- Insert_List_Before_Debug --
539 ------------------------------
540
541 procedure Insert_List_Before_Debug is
542 begin
543 if Debug_Flag_N then
544 Write_Str ("Insert list ");
545 Write_Int (Int (List));
546 Write_Str (" before node ");
547 Write_Int (Int (Before));
548 Write_Eol;
549 end if;
550 end Insert_List_Before_Debug;
551
552 -- Start of processing for Insert_List_Before
553
554 begin
555 pragma Assert (Is_List_Member (Before));
556
557 if Is_Empty_List (List) then
558 return;
559
560 else
561 declare
562 After : constant Node_Or_Entity_Id := Prev (Before);
563 LC : constant List_Id := List_Containing (Before);
564 F : constant Node_Or_Entity_Id := First (List);
565 L : constant Node_Or_Entity_Id := Last (List);
566 N : Node_Or_Entity_Id;
567
568 begin
569 pragma Debug (Insert_List_Before_Debug);
570
571 N := F;
572 loop
573 Set_List_Link (N, LC);
574 exit when N = L;
575 N := Next (N);
576 end loop;
577
578 if Present (After) then
579 Set_Next (After, F);
580 else
581 Set_First (LC, F);
582 end if;
583
584 Set_Prev (Before, L);
585 Set_Prev (F, After);
586 Set_Next (L, Before);
587
588 Set_First (List, Empty);
589 Set_Last (List, Empty);
590 end;
591 end if;
592 end Insert_List_Before;
593
594 -------------------
595 -- Is_Empty_List --
596 -------------------
597
598 function Is_Empty_List (List : List_Id) return Boolean is
599 begin
600 return First (List) = Empty;
601 end Is_Empty_List;
602
603 --------------------
604 -- Is_List_Member --
605 --------------------
606
607 function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is
608 begin
609 return Nodes.Table (Node).In_List;
610 end Is_List_Member;
611
612 -----------------------
613 -- Is_Non_Empty_List --
614 -----------------------
615
616 function Is_Non_Empty_List (List : List_Id) return Boolean is
617 begin
618 return First (List) /= Empty;
619 end Is_Non_Empty_List;
620
621 ----------
622 -- Last --
623 ----------
624
625 function Last (List : List_Id) return Node_Or_Entity_Id is
626 begin
627 pragma Assert (List <= Lists.Last);
628 return Lists.Table (List).Last;
629 end Last;
630
631 ------------------
632 -- Last_List_Id --
633 ------------------
634
635 function Last_List_Id return List_Id is
636 begin
637 return Lists.Last;
638 end Last_List_Id;
639
640 ---------------------
641 -- Last_Non_Pragma --
642 ---------------------
643
644 function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
645 N : constant Node_Or_Entity_Id := Last (List);
646 begin
647 if Nkind (N) /= N_Pragma then
648 return N;
649 else
650 return Prev_Non_Pragma (N);
651 end if;
652 end Last_Non_Pragma;
653
654 ---------------------
655 -- List_Containing --
656 ---------------------
657
658 function List_Containing (Node : Node_Or_Entity_Id) return List_Id is
659 begin
660 pragma Assert (Is_List_Member (Node));
661 return List_Id (Nodes.Table (Node).Link);
662 end List_Containing;
663
664 -----------------
665 -- List_Length --
666 -----------------
667
668 function List_Length (List : List_Id) return Nat is
669 Result : Nat;
670 Node : Node_Or_Entity_Id;
671
672 begin
673 Result := 0;
674 Node := First (List);
675 while Present (Node) loop
676 Result := Result + 1;
677 Node := Next (Node);
678 end loop;
679
680 return Result;
681 end List_Length;
682
683 -------------------
684 -- Lists_Address --
685 -------------------
686
687 function Lists_Address return System.Address is
688 begin
689 return Lists.Table (First_List_Id)'Address;
690 end Lists_Address;
691
692 ----------
693 -- Lock --
694 ----------
695
696 procedure Lock is
697 begin
698 Lists.Locked := True;
699 Lists.Release;
700
701 Prev_Node.Locked := True;
702 Next_Node.Locked := True;
703
704 Prev_Node.Release;
705 Next_Node.Release;
706 end Lock;
707
708 -------------------
709 -- New_Copy_List --
710 -------------------
711
712 function New_Copy_List (List : List_Id) return List_Id is
713 NL : List_Id;
714 E : Node_Or_Entity_Id;
715
716 begin
717 if List = No_List then
718 return No_List;
719
720 else
721 NL := New_List;
722 E := First (List);
723
724 while Present (E) loop
725 Append (New_Copy (E), NL);
726 E := Next (E);
727 end loop;
728
729 return NL;
730 end if;
731 end New_Copy_List;
732
733 ----------------------------
734 -- New_Copy_List_Original --
735 ----------------------------
736
737 function New_Copy_List_Original (List : List_Id) return List_Id is
738 NL : List_Id;
739 E : Node_Or_Entity_Id;
740
741 begin
742 if List = No_List then
743 return No_List;
744
745 else
746 NL := New_List;
747
748 E := First (List);
749 while Present (E) loop
750 if Comes_From_Source (E) then
751 Append (New_Copy (E), NL);
752 end if;
753
754 E := Next (E);
755 end loop;
756
757 return NL;
758 end if;
759 end New_Copy_List_Original;
760
761 --------------
762 -- New_List --
763 --------------
764
765 function New_List return List_Id is
766
767 procedure New_List_Debug;
768 pragma Inline (New_List_Debug);
769 -- Output debugging information if Debug_Flag_N is set
770
771 --------------------
772 -- New_List_Debug --
773 --------------------
774
775 procedure New_List_Debug is
776 begin
777 if Debug_Flag_N then
778 Write_Str ("Allocate new list, returned ID = ");
779 Write_Int (Int (Lists.Last));
780 Write_Eol;
781 end if;
782 end New_List_Debug;
783
784 -- Start of processing for New_List
785
786 begin
787 Lists.Increment_Last;
788
789 declare
790 List : constant List_Id := Lists.Last;
791
792 begin
793 Set_Parent (List, Empty);
794 Set_First (List, Empty);
795 Set_Last (List, Empty);
796
797 pragma Debug (New_List_Debug);
798 return (List);
799 end;
800 end New_List;
801
802 -- Since the one argument case is common, we optimize to build the right
803 -- list directly, rather than first building an empty list and then doing
804 -- the insertion, which results in some unnecessary work.
805
806 function New_List (Node : Node_Or_Entity_Id) return List_Id is
807
808 procedure New_List_Debug;
809 pragma Inline (New_List_Debug);
810 -- Output debugging information if Debug_Flag_N is set
811
812 --------------------
813 -- New_List_Debug --
814 --------------------
815
816 procedure New_List_Debug is
817 begin
818 if Debug_Flag_N then
819 Write_Str ("Allocate new list, returned ID = ");
820 Write_Int (Int (Lists.Last));
821 Write_Eol;
822 end if;
823 end New_List_Debug;
824
825 -- Start of processing for New_List
826
827 begin
828 if Node = Error then
829 return New_List;
830
831 else
832 pragma Assert (not Is_List_Member (Node));
833
834 Lists.Increment_Last;
835
836 declare
837 List : constant List_Id := Lists.Last;
838
839 begin
840 Set_Parent (List, Empty);
841 Set_First (List, Node);
842 Set_Last (List, Node);
843
844 Nodes.Table (Node).In_List := True;
845 Set_List_Link (Node, List);
846 Set_Prev (Node, Empty);
847 Set_Next (Node, Empty);
848 pragma Debug (New_List_Debug);
849 return List;
850 end;
851 end if;
852 end New_List;
853
854 function New_List
855 (Node1 : Node_Or_Entity_Id;
856 Node2 : Node_Or_Entity_Id) return List_Id
857 is
858 L : constant List_Id := New_List (Node1);
859 begin
860 Append (Node2, L);
861 return L;
862 end New_List;
863
864 function New_List
865 (Node1 : Node_Or_Entity_Id;
866 Node2 : Node_Or_Entity_Id;
867 Node3 : Node_Or_Entity_Id) return List_Id
868 is
869 L : constant List_Id := New_List (Node1);
870 begin
871 Append (Node2, L);
872 Append (Node3, L);
873 return L;
874 end New_List;
875
876 function New_List
877 (Node1 : Node_Or_Entity_Id;
878 Node2 : Node_Or_Entity_Id;
879 Node3 : Node_Or_Entity_Id;
880 Node4 : Node_Or_Entity_Id) return List_Id
881 is
882 L : constant List_Id := New_List (Node1);
883 begin
884 Append (Node2, L);
885 Append (Node3, L);
886 Append (Node4, L);
887 return L;
888 end New_List;
889
890 function New_List
891 (Node1 : Node_Or_Entity_Id;
892 Node2 : Node_Or_Entity_Id;
893 Node3 : Node_Or_Entity_Id;
894 Node4 : Node_Or_Entity_Id;
895 Node5 : Node_Or_Entity_Id) return List_Id
896 is
897 L : constant List_Id := New_List (Node1);
898 begin
899 Append (Node2, L);
900 Append (Node3, L);
901 Append (Node4, L);
902 Append (Node5, L);
903 return L;
904 end New_List;
905
906 function New_List
907 (Node1 : Node_Or_Entity_Id;
908 Node2 : Node_Or_Entity_Id;
909 Node3 : Node_Or_Entity_Id;
910 Node4 : Node_Or_Entity_Id;
911 Node5 : Node_Or_Entity_Id;
912 Node6 : Node_Or_Entity_Id) return List_Id
913 is
914 L : constant List_Id := New_List (Node1);
915 begin
916 Append (Node2, L);
917 Append (Node3, L);
918 Append (Node4, L);
919 Append (Node5, L);
920 Append (Node6, L);
921 return L;
922 end New_List;
923
924 ----------
925 -- Next --
926 ----------
927
928 function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
929 begin
930 pragma Assert (Is_List_Member (Node));
931 return Next_Node.Table (Node);
932 end Next;
933
934 procedure Next (Node : in out Node_Or_Entity_Id) is
935 begin
936 Node := Next (Node);
937 end Next;
938
939 -----------------------
940 -- Next_Node_Address --
941 -----------------------
942
943 function Next_Node_Address return System.Address is
944 begin
945 return Next_Node.Table (First_Node_Id)'Address;
946 end Next_Node_Address;
947
948 ---------------------
949 -- Next_Non_Pragma --
950 ---------------------
951
952 function Next_Non_Pragma
953 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
954 is
955 N : Node_Or_Entity_Id;
956
957 begin
958 N := Node;
959 loop
960 N := Next (N);
961 exit when not Nkind_In (N, N_Pragma, N_Null_Statement);
962 end loop;
963
964 return N;
965 end Next_Non_Pragma;
966
967 procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is
968 begin
969 Node := Next_Non_Pragma (Node);
970 end Next_Non_Pragma;
971
972 --------
973 -- No --
974 --------
975
976 function No (List : List_Id) return Boolean is
977 begin
978 return List = No_List;
979 end No;
980
981 ---------------
982 -- Num_Lists --
983 ---------------
984
985 function Num_Lists return Nat is
986 begin
987 return Int (Lists.Last) - Int (Lists.First) + 1;
988 end Num_Lists;
989
990 ------------
991 -- Parent --
992 ------------
993
994 function Parent (List : List_Id) return Node_Or_Entity_Id is
995 begin
996 pragma Assert (List <= Lists.Last);
997 return Lists.Table (List).Parent;
998 end Parent;
999
1000 ----------
1001 -- Pick --
1002 ----------
1003
1004 function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is
1005 Elmt : Node_Or_Entity_Id;
1006
1007 begin
1008 Elmt := First (List);
1009 for J in 1 .. Index - 1 loop
1010 Elmt := Next (Elmt);
1011 end loop;
1012
1013 return Elmt;
1014 end Pick;
1015
1016 -------------
1017 -- Prepend --
1018 -------------
1019
1020 procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is
1021 F : constant Node_Or_Entity_Id := First (To);
1022
1023 procedure Prepend_Debug;
1024 pragma Inline (Prepend_Debug);
1025 -- Output debug information if Debug_Flag_N set
1026
1027 -------------------
1028 -- Prepend_Debug --
1029 -------------------
1030
1031 procedure Prepend_Debug is
1032 begin
1033 if Debug_Flag_N then
1034 Write_Str ("Prepend node ");
1035 Write_Int (Int (Node));
1036 Write_Str (" to list ");
1037 Write_Int (Int (To));
1038 Write_Eol;
1039 end if;
1040 end Prepend_Debug;
1041
1042 -- Start of processing for Prepend_Debug
1043
1044 begin
1045 pragma Assert (not Is_List_Member (Node));
1046
1047 if Node = Error then
1048 return;
1049 end if;
1050
1051 pragma Debug (Prepend_Debug);
1052
1053 if No (F) then
1054 Set_Last (To, Node);
1055 else
1056 Set_Prev (F, Node);
1057 end if;
1058
1059 Set_First (To, Node);
1060
1061 Nodes.Table (Node).In_List := True;
1062
1063 Set_Next (Node, F);
1064 Set_Prev (Node, Empty);
1065 Set_List_Link (Node, To);
1066 end Prepend;
1067
1068 ------------------
1069 -- Prepend_List --
1070 ------------------
1071
1072 procedure Prepend_List (List : List_Id; To : List_Id) is
1073
1074 procedure Prepend_List_Debug;
1075 pragma Inline (Prepend_List_Debug);
1076 -- Output debug information if Debug_Flag_N set
1077
1078 ------------------------
1079 -- Prepend_List_Debug --
1080 ------------------------
1081
1082 procedure Prepend_List_Debug is
1083 begin
1084 if Debug_Flag_N then
1085 Write_Str ("Prepend list ");
1086 Write_Int (Int (List));
1087 Write_Str (" to list ");
1088 Write_Int (Int (To));
1089 Write_Eol;
1090 end if;
1091 end Prepend_List_Debug;
1092
1093 -- Start of processing for Prepend_List
1094
1095 begin
1096 if Is_Empty_List (List) then
1097 return;
1098
1099 else
1100 declare
1101 F : constant Node_Or_Entity_Id := First (To);
1102 L : constant Node_Or_Entity_Id := Last (List);
1103 N : Node_Or_Entity_Id;
1104
1105 begin
1106 pragma Debug (Prepend_List_Debug);
1107
1108 N := L;
1109 loop
1110 Set_List_Link (N, To);
1111 N := Prev (N);
1112 exit when No (N);
1113 end loop;
1114
1115 if No (F) then
1116 Set_Last (To, L);
1117 else
1118 Set_Next (L, F);
1119 end if;
1120
1121 Set_Prev (F, L);
1122 Set_First (To, First (List));
1123
1124 Set_First (List, Empty);
1125 Set_Last (List, Empty);
1126 end;
1127 end if;
1128 end Prepend_List;
1129
1130 ---------------------
1131 -- Prepend_List_To --
1132 ---------------------
1133
1134 procedure Prepend_List_To (To : List_Id; List : List_Id) is
1135 begin
1136 Prepend_List (List, To);
1137 end Prepend_List_To;
1138
1139 ----------------
1140 -- Prepend_To --
1141 ----------------
1142
1143 procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is
1144 begin
1145 Prepend (Node, To);
1146 end Prepend_To;
1147
1148 -------------
1149 -- Present --
1150 -------------
1151
1152 function Present (List : List_Id) return Boolean is
1153 begin
1154 return List /= No_List;
1155 end Present;
1156
1157 ----------
1158 -- Prev --
1159 ----------
1160
1161 function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
1162 begin
1163 pragma Assert (Is_List_Member (Node));
1164 return Prev_Node.Table (Node);
1165 end Prev;
1166
1167 procedure Prev (Node : in out Node_Or_Entity_Id) is
1168 begin
1169 Node := Prev (Node);
1170 end Prev;
1171
1172 -----------------------
1173 -- Prev_Node_Address --
1174 -----------------------
1175
1176 function Prev_Node_Address return System.Address is
1177 begin
1178 return Prev_Node.Table (First_Node_Id)'Address;
1179 end Prev_Node_Address;
1180
1181 ---------------------
1182 -- Prev_Non_Pragma --
1183 ---------------------
1184
1185 function Prev_Non_Pragma
1186 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1187 is
1188 N : Node_Or_Entity_Id;
1189
1190 begin
1191 N := Node;
1192 loop
1193 N := Prev (N);
1194 exit when Nkind (N) /= N_Pragma;
1195 end loop;
1196
1197 return N;
1198 end Prev_Non_Pragma;
1199
1200 procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1201 begin
1202 Node := Prev_Non_Pragma (Node);
1203 end Prev_Non_Pragma;
1204
1205 ------------
1206 -- Remove --
1207 ------------
1208
1209 procedure Remove (Node : Node_Or_Entity_Id) is
1210 Lst : constant List_Id := List_Containing (Node);
1211 Prv : constant Node_Or_Entity_Id := Prev (Node);
1212 Nxt : constant Node_Or_Entity_Id := Next (Node);
1213
1214 procedure Remove_Debug;
1215 pragma Inline (Remove_Debug);
1216 -- Output debug information if Debug_Flag_N set
1217
1218 ------------------
1219 -- Remove_Debug --
1220 ------------------
1221
1222 procedure Remove_Debug is
1223 begin
1224 if Debug_Flag_N then
1225 Write_Str ("Remove node ");
1226 Write_Int (Int (Node));
1227 Write_Eol;
1228 end if;
1229 end Remove_Debug;
1230
1231 -- Start of processing for Remove
1232
1233 begin
1234 pragma Debug (Remove_Debug);
1235
1236 if No (Prv) then
1237 Set_First (Lst, Nxt);
1238 else
1239 Set_Next (Prv, Nxt);
1240 end if;
1241
1242 if No (Nxt) then
1243 Set_Last (Lst, Prv);
1244 else
1245 Set_Prev (Nxt, Prv);
1246 end if;
1247
1248 Nodes.Table (Node).In_List := False;
1249 Set_Parent (Node, Empty);
1250 end Remove;
1251
1252 -----------------
1253 -- Remove_Head --
1254 -----------------
1255
1256 function Remove_Head (List : List_Id) return Node_Or_Entity_Id is
1257 Frst : constant Node_Or_Entity_Id := First (List);
1258
1259 procedure Remove_Head_Debug;
1260 pragma Inline (Remove_Head_Debug);
1261 -- Output debug information if Debug_Flag_N set
1262
1263 -----------------------
1264 -- Remove_Head_Debug --
1265 -----------------------
1266
1267 procedure Remove_Head_Debug is
1268 begin
1269 if Debug_Flag_N then
1270 Write_Str ("Remove head of list ");
1271 Write_Int (Int (List));
1272 Write_Eol;
1273 end if;
1274 end Remove_Head_Debug;
1275
1276 -- Start of processing for Remove_Head
1277
1278 begin
1279 pragma Debug (Remove_Head_Debug);
1280
1281 if Frst = Empty then
1282 return Empty;
1283
1284 else
1285 declare
1286 Nxt : constant Node_Or_Entity_Id := Next (Frst);
1287
1288 begin
1289 Set_First (List, Nxt);
1290
1291 if No (Nxt) then
1292 Set_Last (List, Empty);
1293 else
1294 Set_Prev (Nxt, Empty);
1295 end if;
1296
1297 Nodes.Table (Frst).In_List := False;
1298 Set_Parent (Frst, Empty);
1299 return Frst;
1300 end;
1301 end if;
1302 end Remove_Head;
1303
1304 -----------------
1305 -- Remove_Next --
1306 -----------------
1307
1308 function Remove_Next
1309 (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1310 is
1311 Nxt : constant Node_Or_Entity_Id := Next (Node);
1312
1313 procedure Remove_Next_Debug;
1314 pragma Inline (Remove_Next_Debug);
1315 -- Output debug information if Debug_Flag_N set
1316
1317 -----------------------
1318 -- Remove_Next_Debug --
1319 -----------------------
1320
1321 procedure Remove_Next_Debug is
1322 begin
1323 if Debug_Flag_N then
1324 Write_Str ("Remove next node after ");
1325 Write_Int (Int (Node));
1326 Write_Eol;
1327 end if;
1328 end Remove_Next_Debug;
1329
1330 -- Start of processing for Remove_Next
1331
1332 begin
1333 if Present (Nxt) then
1334 declare
1335 Nxt2 : constant Node_Or_Entity_Id := Next (Nxt);
1336 LC : constant List_Id := List_Containing (Node);
1337
1338 begin
1339 pragma Debug (Remove_Next_Debug);
1340 Set_Next (Node, Nxt2);
1341
1342 if No (Nxt2) then
1343 Set_Last (LC, Node);
1344 else
1345 Set_Prev (Nxt2, Node);
1346 end if;
1347
1348 Nodes.Table (Nxt).In_List := False;
1349 Set_Parent (Nxt, Empty);
1350 end;
1351 end if;
1352
1353 return Nxt;
1354 end Remove_Next;
1355
1356 ---------------
1357 -- Set_First --
1358 ---------------
1359
1360 procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
1361 begin
1362 Lists.Table (List).First := To;
1363 end Set_First;
1364
1365 --------------
1366 -- Set_Last --
1367 --------------
1368
1369 procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
1370 begin
1371 Lists.Table (List).Last := To;
1372 end Set_Last;
1373
1374 -------------------
1375 -- Set_List_Link --
1376 -------------------
1377
1378 procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
1379 begin
1380 Nodes.Table (Node).Link := Union_Id (To);
1381 end Set_List_Link;
1382
1383 --------------
1384 -- Set_Next --
1385 --------------
1386
1387 procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1388 begin
1389 Next_Node.Table (Node) := To;
1390 end Set_Next;
1391
1392 ----------------
1393 -- Set_Parent --
1394 ----------------
1395
1396 procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
1397 begin
1398 pragma Assert (List <= Lists.Last);
1399 Lists.Table (List).Parent := Node;
1400 end Set_Parent;
1401
1402 --------------
1403 -- Set_Prev --
1404 --------------
1405
1406 procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1407 begin
1408 Prev_Node.Table (Node) := To;
1409 end Set_Prev;
1410
1411 ---------------
1412 -- Tree_Read --
1413 ---------------
1414
1415 procedure Tree_Read is
1416 begin
1417 Lists.Tree_Read;
1418 Next_Node.Tree_Read;
1419 Prev_Node.Tree_Read;
1420 end Tree_Read;
1421
1422 ----------------
1423 -- Tree_Write --
1424 ----------------
1425
1426 procedure Tree_Write is
1427 begin
1428 Lists.Tree_Write;
1429 Next_Node.Tree_Write;
1430 Prev_Node.Tree_Write;
1431 end Tree_Write;
1432
1433 ------------
1434 -- Unlock --
1435 ------------
1436
1437 procedure Unlock is
1438 begin
1439 Lists.Locked := False;
1440 Prev_Node.Locked := False;
1441 Next_Node.Locked := False;
1442 end Unlock;
1443
1444 end Nlists;