1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- WARNING: There is a C version of this package. Any changes to this
36 -- source file must be properly reflected in the C header a-elists.h.
39 with Debug
; use Debug
;
40 with Output
; use Output
;
43 package body Elists
is
45 -------------------------------------
46 -- Implementation of Element Lists --
47 -------------------------------------
49 -- Element lists are composed of three types of entities. The element
50 -- list header, which references the first and last elements of the
51 -- list, the elements themselves which are singly linked and also
52 -- reference the nodes on the list, and finally the nodes themselves.
53 -- The following diagram shows how an element list is represented:
55 -- +----------------------------------------------------+
56 -- | +------------------------------------------+ |
59 -- +-----|--+ +-------+ +-------+ +-------+ |
60 -- | Elmt | | 1st | | 2nd | | Last | |
61 -- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+
62 -- | Header | | | | | | | | | |
63 -- +--------+ +---|---+ +---|---+ +---|---+
66 -- +-------+ +-------+ +-------+
68 -- | Node1 | | Node2 | | Node3 |
70 -- +-------+ +-------+ +-------+
72 -- The list header is an entry in the Elists table. The values used for
73 -- the type Elist_Id are subscripts into this table. The First_Elmt field
74 -- (Lfield1) points to the first element on the list, or to No_Elmt in the
75 -- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to
76 -- the last element on the list or to No_Elmt in the case of an empty list.
78 -- The elements themselves are entries in the Elmts table. The Next field
79 -- of each entry points to the next element, or to the Elist header if this
80 -- is the last item in the list. The Node field points to the node which
81 -- is referenced by the corresponding list entry.
83 --------------------------
84 -- Element List Tables --
85 --------------------------
87 type Elist_Header
is record
92 package Elists
is new Table
.Table
(
93 Table_Component_Type
=> Elist_Header
,
94 Table_Index_Type
=> Elist_Id
,
95 Table_Low_Bound
=> First_Elist_Id
,
96 Table_Initial
=> Alloc
.Elists_Initial
,
97 Table_Increment
=> Alloc
.Elists_Increment
,
98 Table_Name
=> "Elists");
100 type Elmt_Item
is record
105 package Elmts
is new Table
.Table
(
106 Table_Component_Type
=> Elmt_Item
,
107 Table_Index_Type
=> Elmt_Id
,
108 Table_Low_Bound
=> First_Elmt_Id
,
109 Table_Initial
=> Alloc
.Elmts_Initial
,
110 Table_Increment
=> Alloc
.Elmts_Increment
,
111 Table_Name
=> "Elmts");
117 procedure Append_Elmt
(Node
: Node_Id
; To
: Elist_Id
) is
118 L
: constant Elmt_Id
:= Elists
.Table
(To
).Last
;
121 Elmts
.Increment_Last
;
122 Elmts
.Table
(Elmts
.Last
).Node
:= Node
;
123 Elmts
.Table
(Elmts
.Last
).Next
:= Union_Id
(To
);
126 Elists
.Table
(To
).First
:= Elmts
.Last
;
128 Elmts
.Table
(L
).Next
:= Union_Id
(Elmts
.Last
);
131 Elists
.Table
(To
).Last
:= Elmts
.Last
;
134 Write_Str
("Append new element Elmt_Id = ");
135 Write_Int
(Int
(Elmts
.Last
));
136 Write_Str
(" to list Elist_Id = ");
137 Write_Int
(Int
(To
));
138 Write_Str
(" referencing Node_Id = ");
139 Write_Int
(Int
(Node
));
148 function Elists_Address
return System
.Address
is
150 return Elists
.Table
(First_Elist_Id
)'Address;
157 function Elmts_Address
return System
.Address
is
159 return Elmts
.Table
(First_Elmt_Id
)'Address;
166 function First_Elmt
(List
: Elist_Id
) return Elmt_Id
is
168 pragma Assert
(List
> Elist_Low_Bound
);
169 return Elists
.Table
(List
).First
;
176 procedure Initialize
is
182 -----------------------
183 -- Insert_Elmt_After --
184 -----------------------
186 procedure Insert_Elmt_After
(Node
: Node_Id
; Elmt
: Elmt_Id
) is
187 N
: constant Union_Id
:= Elmts
.Table
(Elmt
).Next
;
191 pragma Assert
(Elmt
/= No_Elmt
);
193 Elmts
.Increment_Last
;
194 Elmts
.Table
(Elmts
.Last
).Node
:= Node
;
195 Elmts
.Table
(Elmts
.Last
).Next
:= N
;
197 Elmts
.Table
(Elmt
).Next
:= Union_Id
(Elmts
.Last
);
199 if N
in Elist_Range
then
200 Elists
.Table
(Elist_Id
(N
)).Last
:= Elmts
.Last
;
202 end Insert_Elmt_After
;
204 ------------------------
205 -- Is_Empty_Elmt_List --
206 ------------------------
208 function Is_Empty_Elmt_List
(List
: Elist_Id
) return Boolean is
210 return Elists
.Table
(List
).First
= No_Elmt
;
211 end Is_Empty_Elmt_List
;
217 function Last_Elist_Id
return Elist_Id
is
226 function Last_Elmt
(List
: Elist_Id
) return Elmt_Id
is
228 return Elists
.Table
(List
).Last
;
235 function Last_Elmt_Id
return Elmt_Id
is
246 Elists
.Locked
:= True;
247 Elmts
.Locked
:= True;
256 function New_Elmt_List
return Elist_Id
is
258 Elists
.Increment_Last
;
259 Elists
.Table
(Elists
.Last
).First
:= No_Elmt
;
260 Elists
.Table
(Elists
.Last
).Last
:= No_Elmt
;
263 Write_Str
("Allocate new element list, returned ID = ");
264 Write_Int
(Int
(Elists
.Last
));
275 function Next_Elmt
(Elmt
: Elmt_Id
) return Elmt_Id
is
276 N
: constant Union_Id
:= Elmts
.Table
(Elmt
).Next
;
279 if N
in Elist_Range
then
286 procedure Next_Elmt
(Elmt
: in out Elmt_Id
) is
288 Elmt
:= Next_Elmt
(Elmt
);
295 function No
(List
: Elist_Id
) return Boolean is
297 return List
= No_Elist
;
300 function No
(Elmt
: Elmt_Id
) return Boolean is
302 return Elmt
= No_Elmt
;
309 function Node
(Elmt
: Elmt_Id
) return Node_Id
is
311 if Elmt
= No_Elmt
then
314 return Elmts
.Table
(Elmt
).Node
;
322 function Num_Elists
return Nat
is
324 return Int
(Elmts
.Last
) - Int
(Elmts
.First
) + 1;
331 procedure Prepend_Elmt
(Node
: Node_Id
; To
: Elist_Id
) is
332 F
: constant Elmt_Id
:= Elists
.Table
(To
).First
;
335 Elmts
.Increment_Last
;
336 Elmts
.Table
(Elmts
.Last
).Node
:= Node
;
339 Elists
.Table
(To
).Last
:= Elmts
.Last
;
340 Elmts
.Table
(Elmts
.Last
).Next
:= Union_Id
(To
);
342 Elmts
.Table
(Elmts
.Last
).Next
:= Union_Id
(F
);
345 Elists
.Table
(To
).First
:= Elmts
.Last
;
353 function Present
(List
: Elist_Id
) return Boolean is
355 return List
/= No_Elist
;
358 function Present
(Elmt
: Elmt_Id
) return Boolean is
360 return Elmt
/= No_Elmt
;
367 procedure Remove_Elmt
(List
: Elist_Id
; Elmt
: Elmt_Id
) is
372 Nxt
:= Elists
.Table
(List
).First
;
374 -- Case of removing only element in the list
376 if Elmts
.Table
(Nxt
).Next
in Elist_Range
then
378 pragma Assert
(Nxt
= Elmt
);
380 Elists
.Table
(List
).First
:= No_Elmt
;
381 Elists
.Table
(List
).Last
:= No_Elmt
;
383 -- Case of removing the first element in the list
385 elsif Nxt
= Elmt
then
386 Elists
.Table
(List
).First
:= Elmt_Id
(Elmts
.Table
(Nxt
).Next
);
388 -- Case of removing second or later element in the list
393 Nxt
:= Elmt_Id
(Elmts
.Table
(Prv
).Next
);
395 or else Elmts
.Table
(Nxt
).Next
in Elist_Range
;
398 pragma Assert
(Nxt
= Elmt
);
400 Elmts
.Table
(Prv
).Next
:= Elmts
.Table
(Nxt
).Next
;
402 if Elmts
.Table
(Prv
).Next
in Elist_Range
then
403 Elists
.Table
(List
).Last
:= Prv
;
408 ----------------------
409 -- Remove_Last_Elmt --
410 ----------------------
412 procedure Remove_Last_Elmt
(List
: Elist_Id
) is
417 Nxt
:= Elists
.Table
(List
).First
;
419 -- Case of removing only element in the list
421 if Elmts
.Table
(Nxt
).Next
in Elist_Range
then
422 Elists
.Table
(List
).First
:= No_Elmt
;
423 Elists
.Table
(List
).Last
:= No_Elmt
;
425 -- Case of at least two elements in list
430 Nxt
:= Elmt_Id
(Elmts
.Table
(Prv
).Next
);
431 exit when Elmts
.Table
(Nxt
).Next
in Elist_Range
;
434 Elmts
.Table
(Prv
).Next
:= Elmts
.Table
(Nxt
).Next
;
435 Elists
.Table
(List
).Last
:= Prv
;
437 end Remove_Last_Elmt
;
443 procedure Replace_Elmt
(Elmt
: Elmt_Id
; New_Node
: Node_Id
) is
445 Elmts
.Table
(Elmt
).Node
:= New_Node
;
452 procedure Tree_Read
is
462 procedure Tree_Write
is