-------------------------------------------------------------------------------
--
--  This file is part of AdaBrowse.
--
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    AdaBrowse is free software; you can redistribute it and/or modify it
--    under the terms of the  GNU General Public License as published by the
--    Free Software  Foundation; either version 2, or (at your option) any
--    later version. AdaBrowse is distributed in the hope that it will be
--    useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   Offers <CODE>Item_Table</CODE>s and indices on them. Used by
--   <A HREF="ad-scanner.html">AD.Scanner</A>: it gets all items of interest
--   in an item list, builds one or more indices on it, and then traverses
--   these indices to output items.
--   <BR><BR>
--   The point of this distinction is that items may be grouped: an item may
--   reference subordinate items (such as representation clauses or pragmas
--   belonging to this item), and indices usually only contain the indices of
--   the top-level items. An index alone makes no sense, it is only useful in
--   conjunction with its associated <CODE>Item_Table</CODE>.
--   <BR><BR>
--   Yes, this is not a very safe arrangement, but it is sufficient for my
--   purposes in the context of AdaBrowse. Also, it is quite a hack: this
--   package was born as an extract from stuff I had temporarily within
--   AD.Scanner, and it hasn't really been cleaned up. It's more a means to
--   split up the huge package AD.Scanner than a true proper decomposition.
--   </DL>
--
-- <!--
-- Revision History
--
--   17-FEB-2002   TW  Initial version.
--   25-MAR-2002   TW  Correction in 'Find_Items': "task type X;" returns a
--                     Nil_Element for 'Type_Declaration_View', which wasn't
--                     handled.
--   22-NOV-2002   TW  Added support for AD.Options.Private_Too.
--   04-JUN-2003   TW  Change in 'Find_Items': Private_Too also applies to
--                     task and protected types.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Unchecked_Deallocation;

with Asis;
with Asis.Clauses;
with Asis.Elements;
with Asis.Exceptions;
with Asis.Expressions;
with Asis.Text;

with Asis2.Container_Elements;
with Asis2.Declarations;
with Asis2.Naming;
with Asis2.Spans;
with Asis2.Text;

with AD.Descriptions;
with AD.Options;
with AD.Queries;

with GAL.Sorting;

package body AD.Item_Lists is

   use Asis;
   use Asis.Clauses;
   use Asis.Elements;
   use Asis.Expressions;
   use Asis.Text;

   use Asis2.Spans;

   use AD.Descriptions;

   function Smaller_Name
     (Left, Right : in Asis.Element)
     return Boolean
   is
      function Find_Name
        (Element : in Asis.Element)
        return Wide_String
      is
      begin
         case Element_Kind (Element) is
            when A_Declaration =>
               return Asis2.Text.To_Lower
                        (Asis2.Naming.Name_Definition_Image
                           (Asis2.Naming.Get_Name (Element)));
            when A_Pragma =>
               return Asis2.Text.To_Lower
                        (Pragma_Name_Image (Element));

            when An_Expression =>
               --  For attribute definition representation clauses.
               if Expression_Kind (Element) /= An_Identifier then
                  raise Program_Error;
               end if;
               return Asis2.Text.To_Lower (Name_Image (Element));

            when others =>
               return "";

         end case;
      end Find_Name;

   begin
      return Find_Name (Left) < Find_Name (Right);
   end Smaller_Name;

   function Is_Smaller
     (Left, Right : in Item_Desc)
     return Boolean
   is
      --  Visible items always before private items.
      --  Exceptions < Constants < Objects < the rest.
      --  If both in "the rest", maintain original source ordering.
   begin
      if Left.Is_Private /= Right.Is_Private then
         return Left.Is_Private < Right.Is_Private;
      elsif not Left.Is_Private then
         --  Visible items may be reordered.
         if Left.Class /= Right.Class then
            if Left.Class = Item_Exception then
               return True;
            elsif Right.Class = Item_Exception then
               return False;
            end if;
            if Left.Class = Item_Constant then
               return True;
            elsif Right.Class = Item_Constant then
               return False;
            end if;
            if Left.Class = Item_Object then
               return True;
            elsif Right.Class = Item_Object then
               return False;
            end if;
         end if;
      end if;
      --  Anything else and private items keep their original order.
      return Left.Idx < Right.Idx;
   end Is_Smaller;

   procedure Sort_Index
     (Items : in     Item_Table;
      Index : in out Index_Table)
   is
      function Before
        (L, R : in Integer)
        return Boolean
      is
      begin
         return Is_Smaller (Items (L), Items (R));
      end Before;

      procedure Sort is
         new GAL.Sorting.Sort_G (Positive, Integer, Index_Table, Before);

   begin
      Sort (Index);
   end Sort_Index;

   ----------------------------------------------------------------------------

   function Smaller_Name
     (Left, Right : in Item_Desc)
     return Boolean
   is
   begin
      return Smaller_Name (Left.Element, Right.Element);
   end Smaller_Name;

   procedure Sort_By_Name
     (Items : in     Item_Table;
      Index : in out Index_Table)
   is
      function Before
        (L, R : in Integer)
        return Boolean
      is
      begin
         return Smaller_Name (Items (L), Items (R));
      end Before;

      procedure Sort is
         new GAL.Sorting.Sort_G (Positive, Integer, Index_Table, Before);

   begin
      Sort (Index);
   end Sort_By_Name;

   ----------------------------------------------------------------------------

   procedure Sort_Subordinates
     (Index           : in out Index_Table;
      Items           : in     Item_Table;
      Contained_Items : in     Item_Table)
   is
      function Get
        (I : Integer)
        return Asis.Element
      is
      begin
         if I >= 0 then
            return Items (I).Element;
         else
            return Contained_Items (-I).Element;
         end if;
      end Get;

      function Before
        (L, R : in Integer)
        return Boolean
      is
         L_Kind : constant Element_Kinds := Element_Kind (Get (L));
         R_Kind : constant Element_Kinds := Element_Kind (Get (R));
         --  Representation clauses first, pragmas after and sorted by name.
      begin
         if L_Kind = A_Clause then
            if R_Kind /= A_Clause then
               return True;
            else
               declare
                  L_C_Kind : constant Representation_Clause_Kinds :=
                    Representation_Clause_Kind (Get (L));
                  R_C_Kind : constant Representation_Clause_Kinds :=
                    Representation_Clause_Kind (Get (R));
               begin
                  if L_C_Kind /= R_C_Kind then
                     return L_C_Kind > R_C_Kind;
                     --  at clauses, record rep clauses, enum rep clauses,
                     --  attribute clauses.
                  else
                     if L_C_Kind = An_Attribute_Definition_Clause then
                        --  Sort by the attribute
                        return
                          Smaller_Name
                          (Attribute_Designator_Identifier
                           (Representation_Clause_Name (Get (L))),
                           Attribute_Designator_Identifier
                           (Representation_Clause_Name (Get (R))));
                     else
                        return False;
                     end if;
                  end if;
               end;
            end if;
         elsif R_Kind = A_Clause then
            return True;
         else
            --  Two pragmas.
            return Smaller_Name (Get (L), Get (R));
         end if;
      end Before;

      procedure Sort is
         new GAL.Sorting.Sort_G (Positive, Integer, Index_Table, Before);

   begin --  Sort_Subordinates
      Sort (Index);
   end Sort_Subordinates;

   ----------------------------------------------------------------------------

   procedure Get_Comment
     (Item   : in out Item_Desc;
      At_End :    out Boolean)
   is
   begin
      if Item.Finder = 0 then
         --  First call: get the finders.
         Item.Finders := Get_Finders (Item.Class);
         Item.Finder := Item.Finders'First;
      end if;
      if Item.Finder <= Item.Finders'Last then
         declare
            Span : Asis.Text.Span;
         begin
            if Item.Is_Clause then
               Find (Item.Finders (Item.Finder),
                     Item.Element, Item.From, Item.To,
                     Span, Item_Context_Clause);
            else
               Find (Item.Finders (Item.Finder),
                     Item.Element, Span, Item.Class);
            end if;
            if not Is_Nil (Span) then
               --  Add the span to this item's list of comments.
               declare
                  P, Q : Comment_Ptr;
                  Pos  : constant Position := Start (Span);
               begin
                  P := Item.List;
                  while P /= null and then Start (P.Span) < Pos loop
                     Q := P; P := P.Next;
                  end loop;
                  if Q = null then
                     Item.List := new Comment_Span'(Span, P);
                  else
                     Q.Next := new Comment_Span'(Span, P);
                  end if;
               end;
            end if;
         end;
         Item.Finder := Item.Finder + 1;
      end if;
      At_End := Item.Finder > Item.Finders'Last;
   end Get_Comment;

   procedure Complete_Comments
     (Items : in out Item_Table)
   is
      Stop   : Boolean;
      At_End : Boolean;
   begin
      loop
         Stop := True;
         for I in Items'Range loop
            Get_Comment (Items (I), At_End);
            Stop := Stop and At_End;
         end loop;
         exit when Stop;
      end loop;
   end Complete_Comments;

   function Find_Items
     (The_Unit : in Compilation_Unit)
     return Item_Table
   is
      Decl    : constant Declaration := Unit_Declaration (The_Unit);
      Clauses : constant Context_Clause_List :=
        Context_Clause_Elements (The_Unit, True);
      Pragmas : constant Pragma_Element_List :=
        AD.Queries.Get_Pragmas (The_Unit);

      function Nof_Items
        (N, M : in Natural)
        return Natural
      is
      begin
         if N > 0 then
            return 1 + M;
         else
            return M;
         end if;
      end Nof_Items;

      Items : Item_Table (1 .. 1 + Nof_Items (Clauses'Length,
                                              Pragmas'Length));
      Used       : Natural := 0;
      Decl_Index : Natural;
      Done       : Boolean := True;
      At_End     : Boolean;

   begin
      if Clauses'Last >= Clauses'First then
         Used := Used + 1;
         Items (Used).Is_Clause  := True;
         Items (Used).From       :=
           Start (Get_Span (Clauses (Clauses'First)));
         Items (Used).To         :=
           Stop  (Get_Span (Clauses (Clauses'Last)));
         Items (Used).Element    := Decl;
         Items (Used).Class      := Item_Context_Clause;
         Items (Used).Finder     := 0;
         Items (Used).Belongs_To := 0;
         Get_Comment (Items (Used), At_End);
         Done := At_End;
      end if;
      Used := Used + 1;
      Items (Used).Is_Clause  := False;
      Items (Used).Element    := Decl;
      Items (Used).Class      := Item_Class (Decl);
      Items (Used).Finder     := 0;
      Items (Used).Belongs_To := 0;
      Get_Comment (Items (Used), At_End);
      Done := Done and At_End;
      Decl_Index := Used;
      for I in Pragmas'Range loop
         Used := Used + 1;
         Items (Used).Is_Clause  := False;
         Items (Used).Element    := Pragmas (I);
         Items (Used).Class      := Item_Pragma;
         Items (Used).Finder     := 0;
         Items (Used).Belongs_To := Decl_Index;
         Items (Used).Next       := Items (Decl_Index).Sub;
         Items (Decl_Index).Sub  := Used;
         Get_Comment (Items (Used), At_End);
         Done := Done and At_End;
      end loop;
      if not Done then Complete_Comments (Items (1 .. Used)); end if;
      for I in 1 .. Used loop
         Items (I).Idx := I;
      end loop;
      return Items (1 .. Used);
   end Find_Items;

   function Find_Items
     (Decl : in Declaration)
     return Item_Table
   is
      --  This is called for all containers. 'Decl' is the declaration of the
      --  container (Task (type), protected object or type, (generic) package).
      --  'Handled' is the list of items belonging to that desclaration, in
      --  particular, it may (or may not) contain pragmas inside the declara-
      --  tion that apply to the declaration.

      function Find_Items
        (Decls       : in Declarative_Item_List;
         Nof_Visible : in Natural)
        return Item_Table
      is
         Items  : Item_Table (1 .. Decls'Length);
         Used   : Natural := 0;
         Stop   : Boolean := True;
         At_End : Boolean;
         K      : Natural := 1;
      begin
         for I in Decls'Range loop
            Used := Used + 1;
            Items (Used).Is_Clause  := False;
            Items (Used).Element    := Decls (I);
            Items (Used).Class      := Item_Class (Decls (I));
            Items (Used).Finder     := 0;
            Items (Used).Is_Private := K > Nof_Visible;
            Items (Used).Belongs_To := 0;
            Get_Comment (Items (Used), At_End);
            Stop := Stop and At_End;
            K := K + 1;
         end loop;
         if not Stop then Complete_Comments (Items (1 .. Used)); end if;
         for I in 1 .. Used loop
            Items (I).Idx := I;
         end loop;
         return Items (1 .. Used);
      end Find_Items;

   begin --  Find_Items
      declare
         use Asis2.Container_Elements;
         Visible : constant Declarative_Item_List :=
           Visible_Items (Decl, True);
      begin
         if AD.Options.Private_Too then
            return Find_Items (Visible &
                               Private_Items (Decl, True),
                               Visible'Length);
         else
            return Find_Items (Visible, Visible'Length);
         end if;
      end;
   exception
      when Asis.Exceptions.ASIS_Inappropriate_Element =>
         declare
            Null_Items : Item_Table (2 .. 1);
         begin
            return Null_Items;
         end;
   end Find_Items;

   ----------------------------------------------------------------------------

   procedure Free is
      new Ada.Unchecked_Deallocation (Comment_Span, Comment_Ptr);

   procedure Clear_Table
     (Table : in out Item_Table)
   is
      P, Q : Comment_Ptr;
   begin
      for I in Table'Range loop
         P := Table (I).List;
         while P /= null loop
            Q := P; P := P.Next; Free (Q);
         end loop;
      end loop;
   end Clear_Table;

   ----------------------------------------------------------------------------

   procedure Group_Items
     (Items         : in out Item_Table;
      For_Container :    out Natural)
   is

      procedure Check
        (Expr  : in     Expression;
         Items : in out Item_Table;
         Index : in     Natural)
      is
         The_Name : Expression := Expr;
      begin
         if Expression_Kind (The_Name) = An_Attribute_Reference then
            The_Name := Prefix (The_Name);
         end if;
         if Expression_Kind (The_Name) = A_Selected_Component then
            The_Name := Selector (The_Name);
         end if;
         declare
            Name : constant Defining_Name :=
              Asis2.Declarations.Name_Definition (The_Name);
         begin
            if not Is_Nil (Name) then
               for I in Items'Range loop
                  if I /= Index and then
                     Is_Equal
                       (Asis2.Declarations.Enclosing_Declaration (Name),
                        Items (I).Element)
                  then
                     Items (Index).Belongs_To := Items (I).Idx;
                     Items (Index).Next       := Items (I).Sub;
                     Items (I).Sub            := Index;
                     exit;
                  end if;
               end loop;
            end if;
         end;
      end Check;

   begin --  Group_Items
      For_Container := 0;
      --  Go through the items and link together things that shall be grouped.
      for I in Items'Range loop
         case Element_Kind (Items (I).Element) is
            when A_Pragma =>
               case Pragma_Kind (Items (I).Element) is
                  when An_Asynchronous_Pragma |
                       An_Inline_Pragma |
                       An_Atomic_Pragma |
                       An_Atomic_Components_Pragma |
                       An_Attach_Handler_Pragma |
                       A_Controlled_Pragma |
                       A_Discard_Names_Pragma |
                       An_Interrupt_Handler_Pragma |
                       A_Pack_Pragma |
                       A_Volatile_Pragma |
                       A_Volatile_Components_Pragma =>
                     --  Get the list of associations, if length = 1, get
                     --  argument defining names, if also length 1, set
                     --  index.
                     declare
                        Params : constant Association_List :=
                          Pragma_Argument_Associations
                          (Items (I).Element);
                     begin
                        if Params'Last = Params'First then
                           Check
                             (Actual_Parameter (Params (Params'First)),
                              Items, I);
                        end if;
                     end;

                  when A_Suppress_Pragma |
                       An_Import_Pragma |
                       An_Export_Pragma |
                       A_Convention_Pragma =>
                     --  Only check the second argument.
                     declare
                        Params : constant Association_List :=
                          Pragma_Argument_Associations
                          (Items (I).Element);
                     begin
                        if Params'Length >= 2 then
                           Check
                             (Actual_Parameter (Params (Params'First + 1)),
                              Items, I);
                        end if;
                     end;

                  when An_All_Calls_Remote_Pragma |
                       An_Elaborate_Body_Pragma |
                       A_Preelaborate_Pragma |
                       A_Pure_Pragma |
                       A_Remote_Call_Interface_Pragma |
                       A_Remote_Types_Pragma |
                       A_Shared_Passive_Pragma |
                       An_Interrupt_Priority_Pragma |
                       A_Priority_Pragma |
                       A_Storage_Size_Pragma =>
                     --  These belong to the enclosing container.
                     Items (I).Belongs_To := -1;
                     Items (I).Next       := For_Container;
                     For_Container        := I;

                  when others =>
                     null;

               end case;

            when A_Clause =>
               if Clause_Kind (Items (I).Element) =
                  A_Representation_Clause
               then
                  Check (Representation_Clause_Name (Items (I).Element),
                         Items, I);
               end if;

            when others =>
               null;

         end case;
      end loop;
   end Group_Items;

   ----------------------------------------------------------------------------

   function Build_Index
     (Items : in Item_Table)
     return Index_Table
   is
      N : Natural := 0;
   begin
      --  Ok. Now anything that has a Belongs_To = 0 is a group header.
      for I in Items'Range loop
         if Items (I).Belongs_To = 0 then
            N := N + 1;
         end if;
      end loop;
      declare
         Result : Index_Table (1 .. N);
      begin
         N := 0;
         for I in Items'Range loop
            if Items (I).Belongs_To = 0 then
               N := N + 1; Result (N) := I;
            end if;
         end loop;
         return Result;
      end;
   end Build_Index;

   ----------------------------------------------------------------------------

   function Collect_Subordinates
     (Items           : in Item_Table;
      Contained_Items : in Item_Table;
      Current         : in Natural;
      For_Container   : in Natural := 0)
     return Index_Table
   is
      I, N : Natural;
   begin
      --  First count them!
      N := 0;
      I := Current;
      while I /= 0 loop
         N := N + 1;
         I := Items (I).Next;
      end loop;
      I := For_Container;
      while I /= 0 loop
         N := N + 1;
         I := Contained_Items (I).Next;
      end loop;
      declare
         Result : Index_Table (1 .. N);
      begin
         N := 0;
         I := Current;
         while I /= 0 loop
            N := N + 1; Result (N) := I;
            I := Items (I).Next;
         end loop;
         I := For_Container;
         while I /= 0 loop
            N := N + 1; Result (N) := -I;
            I := Contained_Items (I).Next;
         end loop;
         return Result;
      end;
   end Collect_Subordinates;

end AD.Item_Lists;

