------------------------------------------------------------------------------
--                                                                          --
--                           GNATELIM COMPONENTS                            --
--                                                                          --
--                      G N A T E L I M . O U T P U T                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1998-2004 Ada Core Technologies, Inc.           --
--                                                                          --
-- GNATELIM  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. GNATELIM is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- --
-- cense for  more details.  You should  have  received  a copy of the  GNU --
-- General Public License distributed with GNAT; see file COPYING.  If not, --
-- write to  the  Free  Software  Foundation,  59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
-- The original version  of  Gnatelim  was developed by  Alain  Le  Guennec --
-- It is now maintained by Ada Core Technologies Inc  (http://www.gnat.com) --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Implementation;    use Asis.Implementation;

with Ada.Strings;            use Ada.Strings;
with Ada.Strings.Wide_Fixed; use Ada.Strings.Wide_Fixed;
with Ada.Wide_Text_IO;       use Ada.Wide_Text_IO;

with Gnatelim.Nodes;         use Gnatelim.Nodes;
with Gnatelim.Strings;       use Gnatelim.Strings;

package body Gnatelim.Output is

   pragma Warnings (Off);
   --  ??? Prototype implementation, some functions are unused.

   Nb_Unused_Subprograms : Natural;
   --  Counts unused subprograms during the iteration
   --  through registered subprogram declarations.

   type Node_List is array (Natural range <>) of Node;
   Empty_Node_List : constant Node_List (1 .. 0) := (others => Empty_Node);

   -------------------------
   --  Local subprograms  --
   -------------------------

   function Corresponding_Scopes (N : Node) return Node_List;
   --  Returns the nested Scopes in which the node is declared.
   --  The first element of the list is the compilation unit,
   --  the last element is the Entity itself.
   --  Corresponding_Scopes (Empty_Key) returns a list
   --  with Empty_Node as single element.

   function Is_Library_Level (The_Node : Node) return Boolean;
   --  Returns True if accessibility of a Node is library-level.

   procedure Output_Pragma (N : Node);
   --  Outputs the ELIMINATE pragma for the subprogram denoted by Key

   procedure Output_Text_Reference (N : Node);
   --  Outputs the source coordinates for the subprogram denoted by Key

   function Check_If_Used (N : Node) return Boolean;
   --  Subprogram acting as the Action actual
   --  for the generic procedure Iterate_For_Unused on Nodes.

   procedure Iterate_For_Unused is new Iterate
     (Action => Check_If_Used);

   --------------------------
   -- Put_Gnatelim_Version --
   --------------------------

   procedure Put_Gnatelim_Version is
   begin
      Put ("GNATELIM (built with ");
      Put (Asis.Implementation.ASIS_Implementor_Version);
      Put (")");
   end Put_Gnatelim_Version;

   ------------------------
   --  Is_Library_Level  --
   ------------------------

   function Is_Library_Level (The_Node : Node) return Boolean is
      N : Node := The_Node;
   begin
      while N.Parent_Link /= Empty_Key loop
         if N.Kind /= A_Package then
            return False;
         end if;
         N := Retrieve_Node (N.Parent_Link);
      end loop;

      --  We've reached Standard.
      return True;
   end Is_Library_Level;

   ----------------------------
   --  Corresponding_Scopes  --
   ----------------------------

   function  Corresponding_Scopes (N : Node) return Node_List is
   begin
      if N = Empty_Node then
         return Node_List '(1 => Empty_Node);
      else
         if N.Kind /= A_Package_Instance
           and then N.Kind /= A_Subprogram_Instance then
            if N.Parent_Link = Empty_Key then
               return Node_List '(1 => N);
            else
               return Corresponding_Scopes (Retrieve_Node (N.Parent_Link)) & N;
            end if;
         else
            if N.Parent_Link = Empty_Key then
               return Empty_Node_List;
            else
               return Corresponding_Scopes (Retrieve_Node (N.Parent_Link));
            end if;
         end if;
      end if;
   end Corresponding_Scopes;

   ---------------------
   --  Output_Pragma  --
   ---------------------

   procedure Output_Pragma (N : Node) is
      Scopes           : Node_List := Corresponding_Scopes (N);

      function Name_Contains_Quote return Boolean;
      --  Returns True if there are quotes in the entity name

      function Name_Contains_Quote return Boolean is
      begin
         for S in Scopes'First + 1 .. Scopes'Last loop
            declare
               Name : Wide_String := Get_String (Scopes (S).Name);
            begin
               for I in Name'Range loop
                  if Name (I) = '"' then
                     return True;
                  end if;
               end loop;
            end;
         end loop;
         return False;
      end Name_Contains_Quote;

      --  Quote_Case : constant Boolean := Name_Contains_Quote;

   begin
      pragma Assert (Scopes'Length > 0);

      --  Now output the unit name, always present.

      Put ("pragma Eliminate (" & Get_String (Scopes (Scopes'First).Name));

      if Scopes'Length > 1 then

         --  This is not a library unit.
         --  We have to output the entity name.

         Put (", ");

         for S in Scopes'First + 1 .. Scopes'Last loop
            declare
               Name : Wide_String := Get_String (Scopes (S).Name);
            begin
               Put (Name);
            end;
            if S < Scopes'Last then
               Put ('.');
            end if;
         end loop;

         if N.Homonym_Id /= Empty_String then
            Put (", ");
            Put (Get_String (N.Homonym_Id));
         end if;
      end if;

      --  Let's close the pragma.
      Put_Line (");");
   end Output_Pragma;

   -----------------------------
   --  Output_Text_Reference  --
   -----------------------------

   procedure Output_Text_Reference (N : Node) is
   begin
      Put (Get_String (N.Key.File) & ":");

      Put_Line (Ada.Strings.Wide_Fixed.Trim
                (Integer'Wide_Image (N.Key.SLOC.Line),
                 Ada.Strings.Left) &
                ":" &
                Ada.Strings.Wide_Fixed.Trim
                (Integer'Wide_Image (N.Key.SLOC.Col),
                 Ada.Strings.Left));
   end Output_Text_Reference;

   ---------------------
   --  Check_If_Used  --
   ---------------------

   function Check_If_Used (N : Node) return Boolean is
      Parent_N : Node := N;
   begin

      if not N.Flags (FLAG_USED)
        and then not N.Flags (FLAG_NEVER_ELIMINATE)
        and then N.Kind = A_Subprogram
--        and then Is_Library_Level (N)
      then

         --  We do not want to generate pragmas for a subprogram nested into
         --  some other subprogram which is itself eliminated

         if Parent_N.Parent_Link /= Empty_Key then
            Parent_N := Retrieve_Node (Parent_N.Parent_Link);
         end if;

         while Parent_N.Parent_Link /= Empty_Key and then
               Parent_N.Kind /= A_Subprogram
         loop
            Parent_N := Retrieve_Node (Parent_N.Parent_Link);
         end loop;

         if Parent_N.Kind /= A_Subprogram
           or else
            Parent_N.Flags (FLAG_USED)
         then
            Nb_Unused_Subprograms := Nb_Unused_Subprograms + 1;
            Output_Pragma (N);
         end if;

      end if;

      return True;
   end Check_If_Used;

   ---------------------------------
   --  Report_Unused_Subprograms  --
   ---------------------------------

   procedure Report_Unused_Subprograms is
   begin
      Put_Line ("---------------------------------------------------------");
      Put_Line ("--  List of unused entities to be placed in gnat.adc.  --");
      Put_Line ("---------------------------------------------------------");
      Nb_Unused_Subprograms := 0;
      Iterate_For_Unused;
      if Nb_Unused_Subprograms = 0 then
         Put_Line ("--  No unused entities.");
      end if;
   end Report_Unused_Subprograms;

end Gnatelim.Output;
