------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . C U _ I N F O 2                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-2002, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-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 --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Exceptions; use  Asis.Exceptions;

with A4G.Int_Knds;    use A4G.Int_Knds;
with A4G.Vcheck;      use A4G.Vcheck;
with A4G.Mapping;     use A4G.Mapping;
with A4G.A_Sinput;    use A4G.A_Sinput;
with A4G.Contt;       use A4G.Contt;
with A4G.Contt.UT;    use A4G.Contt.UT;
with A4G.Contt.Dp;    use A4G.Contt.Dp;

with Atree;           use Atree;
with Sinfo;           use Sinfo;
with Einfo;           use Einfo;
with Nlists;          use Nlists;
with Sinput;          use Sinput;
with Fname;           use Fname;
with Namet;

package body A4G.CU_Info2 is

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

   LT : String renames ASIS_Line_Terminator;

   function Is_Mentioned_In_Annex_A return Boolean;
   --  This function assumes, that a normalized Ada name of a unit is set
   --  in the ASIS name buffer. It determines if this name is one of the
   --  names mentioned in the list of the names of predefined units given
   --  in RM 95 Annex A (2)

   ------------------
   -- Get_Ada_Name --
   ------------------

   procedure Get_Ada_Name (Top : Node_Id)
   is
      Temp_Node     : Node_Id;
      Unit_Name     : Node_Id;
      Parent_Prefix : Node_Id; -- only for handling a subunit!
      Is_Subunit    : Boolean := False;
   begin
      Temp_Node := Unit (Top);

      if Nkind (Temp_Node) = N_Subunit then

         Is_Subunit    := True;
         Parent_Prefix := Sinfo.Name (Temp_Node);
         Temp_Node     := Proper_Body (Temp_Node);

         if Nkind (Temp_Node) = N_Subprogram_Body then
            Unit_Name := Defining_Unit_Name  (Specification (Temp_Node));
         elsif Nkind (Temp_Node) = N_Package_Body then
            Unit_Name := Defining_Unit_Name (Temp_Node);
         else --  N_Task_Body or N_Protected_Body
            Unit_Name := Defining_Identifier (Temp_Node);
         end if;
         --  in case of a subunit Unit_Name may be only of
         --  N_Defining_Identifier kind
      else
         case Nkind (Temp_Node) is

            when   N_Subprogram_Declaration
                 | N_Subprogram_Body
                 | N_Package_Declaration
                 | N_Generic_Package_Declaration
                 | N_Generic_Subprogram_Declaration
                 | N_Subprogram_Renaming_Declaration
                 | N_Function_Instantiation
                 | N_Procedure_Instantiation =>

               Unit_Name := Defining_Unit_Name (Specification (Temp_Node));

            when   N_Package_Body
                 | N_Package_Renaming_Declaration
                 | N_Generic_Package_Renaming_Declaration
                 | N_Generic_Procedure_Renaming_Declaration
                 | N_Generic_Function_Renaming_Declaration
                 | N_Package_Instantiation                 =>

               Unit_Name := Defining_Unit_Name (Temp_Node);

            when others =>
               Raise_ASIS_Failed (Diagnosis =>
                  "A4G.CU_Info2.Get_Ada_Name: "
                &  "unexpected Node Kind for the library "
                & LT
                & "item of a compilation unit");
         end case;
      end if;

      if Is_Subunit then
         Set_Name_String (Exp_Name_Image (Parent_Prefix)
                        & '.'
                        & Identifier_Image (Unit_Name));
      else
         Set_Name_String (Exp_Name_Image (Unit_Name));
      end if;

   exception
      when ASIS_Failed =>
         Add_Call_Information ("A4G.CU_Info2.Get_Ada_Name");
         raise;
      when others =>
         Raise_ASIS_Failed (Diagnosis => "A4G.CU_Info2.Get_Ada_Name");
   end Get_Ada_Name;

   -------------
   -- Is_Main --
   -------------

   function Is_Main (Top : Node_Id; Kind : Unit_Kinds) return Boolean is
   begin
      if not (Kind = A_Procedure      or else
              Kind = A_Function       or else
              Kind = A_Procedure_Body or else
              Kind = A_Function_Body)
      then
         return False;
      elsif Present
              (Parameter_Specifications (Specification (Unit (Top))))
      then
         return False;

      elsif Kind = A_Procedure      or else
            Kind = A_Procedure_Body
      then
         return True; -- parameterless procedure

      else
         --  parameterless function, and here we should check if the
         --  returned type is an integer type

         return Is_Integer_Type
            (Entity (Sinfo.Subtype_Mark (Specification (Unit (Top)))));
      end if;
   end Is_Main;

   -----------------------------
   -- Is_Mentioned_In_Annex_A --
   -----------------------------

   function Is_Mentioned_In_Annex_A return Boolean is
      Result : Boolean := False;
      Ind    : Positive := 1;

      Max_Child_Nlen : constant Integer := 36;
      subtype Child_Name is String (1 .. Max_Child_Nlen);

      type Child_List is array (Integer range <>) of Child_Name;

      Ada_Childs : Child_List := (
         "asynchronous_task_control           ",
         "calendar                            ",
         "characters                          ",
         "command_line                        ",
         "decimal                             ",
         "direct_io                           ",
         "dynamic_priorities                  ",
         "exceptions                          ",
         "finalization                        ",
         "interrupts                          ",
         "io_exceptions                       ",
         "numerics                            ",
         "real_time                           ",
         "sequential_io                       ",
         "storage_io                          ",
         "streams                             ",
         "strings                             ",
         "synchronous_task_control            ",
         "tags                                ",
         "task_attributes                     ",
         "task_identification                 ",
         "text_io                             ",
         "unchecked_conversion                ",
         "unchecked_deallocation              ",
         "wide_text_io                        ");

      Ada_Characters_Childs : Child_List := (
         "handling                            ",
         "latin_1                             ");

      Ada_Numerics_Childs : Child_List := (
         "complex_elementary_functions        ",
         "complex_types                       ",
         "discrete_random                     ",
         "elementary_functions                ",
         "float_random                        ",
         "generic_complex_elementary_functions",
         "generic_complex_types               ",
         "generic_elementary_functions        ");

      Ada_Strings_Childs : Child_List := (
         "bounded                             ",
         "fixed                               ",
         "maps                                ",
         "unbounded                           ",
         "wide_bounded                        ",
         "wide_fixed                          ",
         "wide_maps                           ",
         "wide_unbounded                      ");

      Ada_Text_IO_Childs : Child_List := (
         "complex_io                          ",
         "editing                             ",
         "text_streams                        ");

      Interfaces_Childs : Child_List := (
         "c                                   ",
         "cobol                               ",
         "fortran                             ");

      Interfaces_C_Childs : Child_List := (
         "pointers                            ",
         "strings                             ");

      System_Childs : Child_List := (
         "address_to_access_conversions       ",
         "machine_code                        ",
         "rpc                                 ",
         "storage_elements                    ",
         "storage_pools                       ");

      function In_Child_List (Ind : Positive; L : Child_List) return Boolean;
      --  Checks if a part of a unit name which is stored in
      --  A_Name_Bufer (I .. A_Name_Len) belongs to a list of predefined
      --  child unit for a given predefined root unit

      function In_Child_List (Ind : Positive; L : Child_List) return Boolean
      is
         Padded_Unit_Name : String (1 .. Max_Child_Nlen);
         Last_Dot : Positive := 1;
      begin
         if A_Name_Len > Ind + Max_Child_Nlen then
            return False;
         end if;

         --  checking if the argument name is not a name of grandchild:
         for I in reverse 1 .. A_Name_Len loop
            if A_Name_Buffer (I) = '.' then
               Last_Dot := I;
               exit;
            end if;
         end loop;

         if Last_Dot > Ind then

            return False;

         end if;

         Padded_Unit_Name (1 .. (A_Name_Len - Ind + 1)) :=
            A_Name_Buffer (Ind .. A_Name_Len);

         Padded_Unit_Name ((A_Name_Len - Ind + 1) + 1 .. Max_Child_Nlen) :=
           (others => ' ');

         for I in L'Range loop

            if Padded_Unit_Name = L (I) then
               return True;
            end if;

         end loop;

         return False;

      end In_Child_List;

   begin
      --  no need to analyze the suffix of a normalized name:
      A_Name_Len := A_Name_Len - 2;

      --  No need to check the Standard package - its origin is set when
      --  the corresponding unit entry is created in a special way

      if A_Name_Len >= 3 and then
         A_Name_Buffer (1 .. 3) = "ada"
      then

         if A_Name_Len = 3 then
            Result := True;
         else
            Ind := 5;

            Result := In_Child_List (Ind, Ada_Childs);

            if Result = False then
               --  Checking grandchildren of Ada:
               if A_Name_Buffer (Ind .. Ind + 10) = "characters." then

                  Ind := Ind + 11;
                  Result := In_Child_List (Ind, Ada_Characters_Childs);

               elsif A_Name_Buffer (Ind .. Ind + 8) = "numerics." then

                  Ind := Ind + 9;
                  Result := In_Child_List (Ind, Ada_Numerics_Childs);

               elsif A_Name_Buffer (Ind .. A_Name_Len) = "streams.stream_io"
                  or else
                     A_Name_Buffer (Ind .. A_Name_Len) = "interrupts.names"
               then
                  --  only one grandchild is possible, no need for searching
                  Result := True;

               elsif A_Name_Buffer (Ind .. Ind + 7) = "strings." then

                  Ind := Ind + 8;
                  Result := In_Child_List (Ind, Ada_Strings_Childs);

                  if Result = False then
                     Result := A_Name_Buffer (Ind .. A_Name_Len) =
                               "maps.constants"
                        or else
                               A_Name_Buffer (Ind .. A_Name_Len) =
                               "wide_maps.wide_constants";
                  end if;

               elsif A_Name_Buffer (Ind .. Ind + 7) = "text_io." then

                  Ind := Ind + 8;
                  Result := In_Child_List (Ind, Ada_Text_IO_Childs);

               elsif A_Name_Buffer (Ind .. Ind + 12) = "wide_text_io." then

                  Ind := Ind + 13;
                  Result := In_Child_List (Ind, Ada_Text_IO_Childs);

               end if;


            end if;

         end if;

      elsif A_Name_Len >= 10 and then
         A_Name_Buffer (1 .. 10) = "interfaces"
      then

         if A_Name_Len = 10 then
            Result := True;
         else

            Ind := 12;
            Result := In_Child_List (Ind, Interfaces_Childs);

            if Result = False then
               --  Checking grandchildren of Interfaces:
               if A_Name_Buffer (Ind .. Ind + 1) = "c." then

                  Ind := Ind + 2;
                  Result := In_Child_List (Ind, Interfaces_C_Childs);

               end if;
            end if;

         end if;

      elsif A_Name_Len >= 6 and then
         A_Name_Buffer (1 .. 6) = "system"
      then
         if A_Name_Len = 6 then
            Result := True;
         else

            Ind := 8;
            Result := In_Child_List (Ind, System_Childs);

         end if;

      end if;

      return Result;

   end Is_Mentioned_In_Annex_A;

   ----------------------
   -- Set_Dependencies --
   ----------------------

   procedure Set_Dependencies
     (C   : Context_Id;
      U   : Unit_Id;
      Top : Node_Id)
   is
      Unit_Kind : Unit_Kinds := Kind (C, U);
   begin
      Set_Supporters (C, U, Top);

      if  (Unit_Kind = A_Procedure                  or else
           Unit_Kind = A_Function                   or else
           Unit_Kind = A_Package                    or else
           Unit_Kind = A_Generic_Procedure          or else
           Unit_Kind = A_Generic_Function           or else
           Unit_Kind = A_Generic_Package            or else
           Unit_Kind = A_Procedure_Instance         or else
           Unit_Kind = A_Function_Instance          or else
           Unit_Kind = A_Package_Instance           or else
           Unit_Kind = A_Procedure_Renaming         or else
           Unit_Kind = A_Function_Renaming          or else
           Unit_Kind = A_Package_Renaming           or else
           Unit_Kind = A_Generic_Procedure_Renaming or else
           Unit_Kind = A_Generic_Function_Renaming  or else
           Unit_Kind = A_Generic_Package_Renaming   or else
           Unit_Kind = A_Procedure_Body             or else
           Unit_Kind = A_Function_Body              or else
           Unit_Kind = A_Package_Body               or else
           Unit_Kind = A_Procedure_Body_Subunit     or else
           Unit_Kind = A_Function_Body_Subunit      or else
           Unit_Kind = A_Package_Body_Subunit       or else
           Unit_Kind = A_Task_Body_Subunit          or else
           Unit_Kind = A_Protected_Body_Subunit     or else
           Unit_Kind = An_Unknown_Unit)
      then
         Add_To_Parent (C, U);
      end if;

   exception
      when others =>
         Raise_ASIS_Failed ("A4G.CU_Info2.Set_Dependencies");
   end Set_Dependencies;

   ------------------------
   -- Set_Kind_and_Class --
   -------------------------

   procedure Set_Kind_and_Class
     (C   : Context_Id;
      U   : Unit_Id;
      Top : Node_Id)
   is
      Is_Private     : Boolean;
      Unit_Node      : Node_Id;
      Unit_Node_Kind : Node_Kind;

      Kind_To_Set    : Unit_Kinds   := Not_A_Unit;
      Class_To_Set   : Unit_Classes := Not_A_Class;
   begin
      Is_Private := Private_Present (Top);
      Unit_Node  := Unit (Top); --  Original_Node???

      if Is_Rewrite_Substitution (Unit_Node) then  -- For Generic
         Unit_Node := Original_Node (Unit_Node);   -- Instantiations
      end if;

      Unit_Node_Kind := Nkind (Unit_Node);

      case Unit_Node_Kind is

         when N_Subprogram_Declaration =>

            Kind_To_Set := A_Procedure;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Package_Declaration =>

            Kind_To_Set := A_Package;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Generic_Declaration =>

            if Unit_Node_Kind = N_Generic_Package_Declaration then
               Kind_To_Set :=  A_Generic_Package;
            else -- two possibilities: generic procedure or generic function
               if Asis_Internal_Element_Kind (Unit_Node) =
                  A_Generic_Procedure_Declaration
               then
                  Kind_To_Set := A_Generic_Procedure;
               else
                  Kind_To_Set := A_Generic_Function;
               end if;
            end if;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Generic_Instantiation =>

            if Unit_Node_Kind = N_Package_Instantiation then
               Kind_To_Set := A_Package_Instance;
            elsif Unit_Node_Kind = N_Procedure_Instantiation then
               Kind_To_Set := A_Procedure_Instance;
            else
               Kind_To_Set := A_Function_Instance;
            end if;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Subprogram_Renaming_Declaration =>

            if Asis_Internal_Element_Kind (Unit_Node) =
               A_Procedure_Renaming_Declaration
            then
               Kind_To_Set := A_Procedure_Renaming;
            else
               Kind_To_Set := A_Function_Renaming;
            end if;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Package_Renaming_Declaration =>

            Kind_To_Set := A_Package_Renaming;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Generic_Renaming_Declaration =>

            if Unit_Node_Kind = N_Generic_Procedure_Renaming_Declaration then
               Kind_To_Set := A_Generic_Procedure_Renaming;
            elsif Unit_Node_Kind = N_Generic_Function_Renaming_Declaration then
               Kind_To_Set := A_Generic_Function_Renaming;
            else
               Kind_To_Set := A_Generic_Package_Renaming;
            end if;

            if Is_Private then
               Class_To_Set := A_Private_Declaration;
            else
               Class_To_Set := A_Public_Declaration;
            end if;

         when N_Subprogram_Body =>

            if Asis_Internal_Element_Kind (Unit_Node) =
               A_Procedure_Body_Declaration
            then
               Kind_To_Set := A_Procedure_Body;
            else
               Kind_To_Set := A_Function_Body;
            end if;

            if Acts_As_Spec (Top) then
               Class_To_Set := A_Public_Declaration_And_Body;
            else
               if Private_Present (Library_Unit (Top)) then
                  Class_To_Set := A_Private_Body;
               else
                  Class_To_Set := A_Public_Body;
               end if;
            end if;

         when N_Package_Body    =>

            Kind_To_Set := A_Package_Body;

            if Private_Present (Library_Unit (Top)) then
               Class_To_Set := A_Private_Body;
            else
               Class_To_Set := A_Public_Body;
            end if;

         when N_Subunit         =>

            Unit_Node    := Proper_Body (Unit_Node);

            case Nkind (Unit_Node) is

               when N_Subprogram_Body =>

                  if Asis_Internal_Element_Kind (Unit_Node) =
                     A_Procedure_Body_Declaration
                  then
                     Kind_To_Set := A_Procedure_Body_Subunit;
                  else
                     Kind_To_Set := A_Function_Body_Subunit;
                  end if;

               when N_Package_Body =>
                  Kind_To_Set := A_Package_Body_Subunit;

               when N_Task_Body =>
                  Kind_To_Set := A_Task_Body_Subunit;

               when N_Protected_Body =>
                  Kind_To_Set := A_Protected_Body_Subunit;

               when others =>
                  null;
            end case;

            Class_To_Set := A_Separate_Body;

         when others =>
            Raise_ASIS_Failed
               (Diagnosis => "Unacceptable Node Kind ("
                            & Node_Kind'Image (Unit_Node_Kind)
                            & ") for the Unit Declaration of the "
                            & "Compilation_Unit," & LT
                            & "detected in A4G.CU_Info2.Set_Kind_and_Class");
      end case;

      Set_Kind  (C, U, Kind_To_Set);
      Set_Class (C, U, Class_To_Set);
   exception
      when ASIS_Failed => raise;
      when others => Raise_ASIS_Failed (Diagnosis =>
         "GNAT exception raised in A4G.CU_Info2.Set_Kind_and_Class");
   end Set_Kind_and_Class;

   -----------------------------
   -- Set_S_F_Name_and_Origin --
   -----------------------------

   procedure Set_S_F_Name_and_Origin
     (Context : Context_Id;
      Unit    : Unit_Id;
      Top     : Node_Id)
   is
      Fname     : File_Name_Type;
      Ref_Fname : File_Name_Type;

      Origin    : Unit_Origins;
   begin
      --  Setting the (full) source file name in the Unit table.
      --  The source file is the file which has been compiled

      Fname := Full_File_Name (Get_Source_File_Index (Sloc (Top)));
      Namet.Get_Name_String (Fname);
      Set_S_File_Name_String;
      Set_Source_File_Name (Unit);

      --  Setting the (full) reference file name

      Ref_Fname := Full_Ref_Name (Get_Source_File_Index (Sloc (Top)));

      if Ref_Fname = Fname then
         Set_Ref_File_As_Source_File (Unit);
      else
         Namet.Get_Name_String (Ref_Fname);
         Set_Ref_File_Name_String (Unit);
         Set_Source_File_Name (Unit, Ref => True);
      end if;
      --  to define the unit origin, we have to reset Fname to the short
      --  (that is, containing no directory information) file name

      Fname := File_Name (Get_Source_File_Index (Sloc (Top)));
      Namet.Get_Name_String (Fname);

      if Is_Predefined_File_Name (Fname) then

         Get_Name_String (Unit, Norm_Ada_Name);

         if Is_Mentioned_In_Annex_A then
            Origin := A_Predefined_Unit;
         else
            Origin := An_Implementation_Unit;
         end if;

      elsif Is_Internal_File_Name (Fname) then
         Origin := An_Implementation_Unit;
      else
         Origin := An_Application_Unit;
      end if;

      Set_Origin (Context, Unit, Origin);

   exception
      when ASIS_Failed =>
         raise;
      when others =>
         Raise_ASIS_Failed
           (Diagnosis => "A4G.CU_Info2.Set_S_F_Name_and_Origin");
   end Set_S_F_Name_and_Origin;

end A4G.CU_Info2;
