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