diff options
Diffstat (limited to 'gcc/ada/elists.adb')
| -rw-r--r-- | gcc/ada/elists.adb | 492 |
1 files changed, 492 insertions, 0 deletions
diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb new file mode 100644 index 000000000..58beb00d5 --- /dev/null +++ b/gcc/ada/elists.adb @@ -0,0 +1,492 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header a-elists.h. + +with Alloc; +with Debug; use Debug; +with Output; use Output; +with Table; + +package body Elists is + + ------------------------------------- + -- Implementation of Element Lists -- + ------------------------------------- + + -- Element lists are composed of three types of entities. The element + -- list header, which references the first and last elements of the + -- list, the elements themselves which are singly linked and also + -- reference the nodes on the list, and finally the nodes themselves. + -- The following diagram shows how an element list is represented: + + -- +----------------------------------------------------+ + -- | +------------------------------------------+ | + -- | | | | + -- V | V | + -- +-----|--+ +-------+ +-------+ +-------+ | + -- | Elmt | | 1st | | 2nd | | Last | | + -- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+ + -- | Header | | | | | | | | | | + -- +--------+ +---|---+ +---|---+ +---|---+ + -- | | | + -- V V V + -- +-------+ +-------+ +-------+ + -- | | | | | | + -- | Node1 | | Node2 | | Node3 | + -- | | | | | | + -- +-------+ +-------+ +-------+ + + -- The list header is an entry in the Elists table. The values used for + -- the type Elist_Id are subscripts into this table. The First_Elmt field + -- (Lfield1) points to the first element on the list, or to No_Elmt in the + -- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to + -- the last element on the list or to No_Elmt in the case of an empty list. + + -- The elements themselves are entries in the Elmts table. The Next field + -- of each entry points to the next element, or to the Elist header if this + -- is the last item in the list. The Node field points to the node which + -- is referenced by the corresponding list entry. + + ------------------------- + -- Element List Tables -- + ------------------------- + + type Elist_Header is record + First : Elmt_Id; + Last : Elmt_Id; + end record; + + package Elists is new Table.Table ( + Table_Component_Type => Elist_Header, + Table_Index_Type => Elist_Id'Base, + Table_Low_Bound => First_Elist_Id, + Table_Initial => Alloc.Elists_Initial, + Table_Increment => Alloc.Elists_Increment, + Table_Name => "Elists"); + + type Elmt_Item is record + Node : Node_Or_Entity_Id; + Next : Union_Id; + end record; + + package Elmts is new Table.Table ( + Table_Component_Type => Elmt_Item, + Table_Index_Type => Elmt_Id'Base, + Table_Low_Bound => First_Elmt_Id, + Table_Initial => Alloc.Elmts_Initial, + Table_Increment => Alloc.Elmts_Increment, + Table_Name => "Elmts"); + + ----------------- + -- Append_Elmt -- + ----------------- + + procedure Append_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + L : constant Elmt_Id := Elists.Table (To).Last; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + + if L = No_Elmt then + Elists.Table (To).First := Elmts.Last; + else + Elmts.Table (L).Next := Union_Id (Elmts.Last); + end if; + + Elists.Table (To).Last := Elmts.Last; + + if Debug_Flag_N then + Write_Str ("Append new element Elmt_Id = "); + Write_Int (Int (Elmts.Last)); + Write_Str (" to list Elist_Id = "); + Write_Int (Int (To)); + Write_Str (" referencing Node_Or_Entity_Id = "); + Write_Int (Int (N)); + Write_Eol; + end if; + end Append_Elmt; + + ------------------------ + -- Append_Unique_Elmt -- + ------------------------ + + procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + Elmt : Elmt_Id; + begin + Elmt := First_Elmt (To); + loop + if No (Elmt) then + Append_Elmt (N, To); + return; + elsif Node (Elmt) = N then + return; + else + Next_Elmt (Elmt); + end if; + end loop; + end Append_Unique_Elmt; + + -------------------- + -- Elists_Address -- + -------------------- + + function Elists_Address return System.Address is + begin + return Elists.Table (First_Elist_Id)'Address; + end Elists_Address; + + ------------------- + -- Elmts_Address -- + ------------------- + + function Elmts_Address return System.Address is + begin + return Elmts.Table (First_Elmt_Id)'Address; + end Elmts_Address; + + ---------------- + -- First_Elmt -- + ---------------- + + function First_Elmt (List : Elist_Id) return Elmt_Id is + begin + pragma Assert (List > Elist_Low_Bound); + return Elists.Table (List).First; + end First_Elmt; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Elists.Init; + Elmts.Init; + end Initialize; + + ----------------------- + -- Insert_Elmt_After -- + ----------------------- + + procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id) is + Nxt : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + pragma Assert (Elmt /= No_Elmt); + + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + Elmts.Table (Elmts.Last).Next := Nxt; + + Elmts.Table (Elmt).Next := Union_Id (Elmts.Last); + + if Nxt in Elist_Range then + Elists.Table (Elist_Id (Nxt)).Last := Elmts.Last; + end if; + end Insert_Elmt_After; + + ------------------------ + -- Is_Empty_Elmt_List -- + ------------------------ + + function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is + begin + return Elists.Table (List).First = No_Elmt; + end Is_Empty_Elmt_List; + + ------------------- + -- Last_Elist_Id -- + ------------------- + + function Last_Elist_Id return Elist_Id is + begin + return Elists.Last; + end Last_Elist_Id; + + --------------- + -- Last_Elmt -- + --------------- + + function Last_Elmt (List : Elist_Id) return Elmt_Id is + begin + return Elists.Table (List).Last; + end Last_Elmt; + + ------------------ + -- Last_Elmt_Id -- + ------------------ + + function Last_Elmt_Id return Elmt_Id is + begin + return Elmts.Last; + end Last_Elmt_Id; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Elists.Locked := True; + Elmts.Locked := True; + Elists.Release; + Elmts.Release; + end Lock; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List return Elist_Id is + begin + Elists.Increment_Last; + Elists.Table (Elists.Last).First := No_Elmt; + Elists.Table (Elists.Last).Last := No_Elmt; + + if Debug_Flag_N then + Write_Str ("Allocate new element list, returned ID = "); + Write_Int (Int (Elists.Last)); + Write_Eol; + end if; + + return Elists.Last; + end New_Elmt_List; + + --------------- + -- Next_Elmt -- + --------------- + + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is + N : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + if N in Elist_Range then + return No_Elmt; + else + return Elmt_Id (N); + end if; + end Next_Elmt; + + procedure Next_Elmt (Elmt : in out Elmt_Id) is + begin + Elmt := Next_Elmt (Elmt); + end Next_Elmt; + + -------- + -- No -- + -------- + + function No (List : Elist_Id) return Boolean is + begin + return List = No_Elist; + end No; + + function No (Elmt : Elmt_Id) return Boolean is + begin + return Elmt = No_Elmt; + end No; + + ---------- + -- Node -- + ---------- + + function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id is + begin + if Elmt = No_Elmt then + return Empty; + else + return Elmts.Table (Elmt).Node; + end if; + end Node; + + ---------------- + -- Num_Elists -- + ---------------- + + function Num_Elists return Nat is + begin + return Int (Elmts.Last) - Int (Elmts.First) + 1; + end Num_Elists; + + ------------------ + -- Prepend_Elmt -- + ------------------ + + procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + F : constant Elmt_Id := Elists.Table (To).First; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + + if F = No_Elmt then + Elists.Table (To).Last := Elmts.Last; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + else + Elmts.Table (Elmts.Last).Next := Union_Id (F); + end if; + + Elists.Table (To).First := Elmts.Last; + end Prepend_Elmt; + + ------------- + -- Present -- + ------------- + + function Present (List : Elist_Id) return Boolean is + begin + return List /= No_Elist; + end Present; + + function Present (Elmt : Elmt_Id) return Boolean is + begin + return Elmt /= No_Elmt; + end Present; + + ----------------- + -- Remove_Elmt -- + ----------------- + + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + pragma Assert (Nxt = Elmt); + + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of removing the first element in the list + + elsif Nxt = Elmt then + Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next); + + -- Case of removing second or later element in the list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Nxt = Elmt + or else Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + pragma Assert (Nxt = Elmt); + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + + if Elmts.Table (Prv).Next in Elist_Range then + Elists.Table (List).Last := Prv; + end if; + end if; + end Remove_Elmt; + + ---------------------- + -- Remove_Last_Elmt -- + ---------------------- + + procedure Remove_Last_Elmt (List : Elist_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of at least two elements in list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + Elists.Table (List).Last := Prv; + end if; + end Remove_Last_Elmt; + + ------------------ + -- Replace_Elmt -- + ------------------ + + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Or_Entity_Id) is + begin + Elmts.Table (Elmt).Node := New_Node; + end Replace_Elmt; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Elists.Tree_Read; + Elmts.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Elists.Tree_Write; + Elmts.Tree_Write; + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Elists.Locked := False; + Elmts.Locked := False; + end Unlock; + +end Elists; |