path: root/gcc/ada/uname.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                U N A M E                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2007, 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 2,  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.  See the GNU General Public License --
-- 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,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, 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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Casing;   use Casing;
with Einfo;    use Einfo;
with Hostparm;
with Lib;      use Lib;
with Nlists;   use Nlists;
with Output;   use Output;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;

package body Uname is

   -------------------
   -- Get_Body_Name --
   -------------------

   function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
   begin
      Get_Name_String (N);

      pragma Assert (Name_Len > 2
                       and then Name_Buffer (Name_Len - 1) = '%'
                       and then Name_Buffer (Name_Len) = 's');

      Name_Buffer (Name_Len) := 'b';
      return Name_Find;
   end Get_Body_Name;

   -----------------------------------
   -- Get_External_Unit_Name_String --
   -----------------------------------

   procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is
      Pcount : Natural;
      Newlen : Natural;

   begin
      --  Get unit name and eliminate trailing %s or %b

      Get_Name_String (N);
      Name_Len := Name_Len - 2;

      --  Find number of components

      Pcount := 0;
      for J in 1 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Pcount := Pcount + 1;
         end if;
      end loop;

      --  If simple name, nothing to do

      if Pcount = 0 then
         return;
      end if;

      --  If name has multiple components, replace dots by double underscore

      Newlen := Name_Len + Pcount;

      for J in reverse 1 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Name_Buffer (Newlen) := '_';
            Name_Buffer (Newlen - 1) := '_';
            Newlen := Newlen - 2;

         else
            Name_Buffer (Newlen) := Name_Buffer (J);
            Newlen := Newlen - 1;
         end if;
      end loop;

      Name_Len := Name_Len + Pcount;
   end Get_External_Unit_Name_String;

   --------------------------
   -- Get_Parent_Body_Name --
   --------------------------

   function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
   begin
      Get_Name_String (N);

      while Name_Buffer (Name_Len) /= '.' loop
         pragma Assert (Name_Len > 1); -- not a child or subunit name
         Name_Len := Name_Len - 1;
      end loop;

      Name_Buffer (Name_Len) := '%';
      Name_Len := Name_Len + 1;
      Name_Buffer (Name_Len) := 'b';
      return Name_Find;

   end Get_Parent_Body_Name;

   --------------------------
   -- Get_Parent_Spec_Name --
   --------------------------

   function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
   begin
      Get_Name_String (N);

      while Name_Buffer (Name_Len) /= '.' loop
         if Name_Len = 1 then
            return No_Unit_Name;
         else
            Name_Len := Name_Len - 1;
         end if;
      end loop;

      Name_Buffer (Name_Len) := '%';
      Name_Len := Name_Len + 1;
      Name_Buffer (Name_Len) := 's';
      return Name_Find;

   end Get_Parent_Spec_Name;

   -------------------
   -- Get_Spec_Name --
   -------------------

   function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
   begin
      Get_Name_String (N);

      pragma Assert (Name_Len > 2
                       and then Name_Buffer (Name_Len - 1) = '%'
                       and then Name_Buffer (Name_Len) = 'b');

      Name_Buffer (Name_Len) := 's';
      return Name_Find;
   end Get_Spec_Name;

   -------------------
   -- Get_Unit_Name --
   -------------------

   function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is

      Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
      --  Buffer used to build name of unit. Note that we cannot use the
      --  Name_Buffer in package Name_Table because we use it to read
      --  component names.

      Unit_Name_Length : Natural := 0;
      --  Length of name stored in Unit_Name_Buffer

      Node : Node_Id;
      --  Program unit node

      procedure Add_Char (C : Character);
      --  Add a single character to stored unit name

      procedure Add_Name (Name : Name_Id);
      --  Add the characters of a names table entry to stored unit name

      procedure Add_Node_Name (Node : Node_Id);
      --  Recursive procedure adds characters associated with Node

      function Get_Parent (Node : Node_Id) return Node_Id;
      --  Get parent compilation unit of a stub

      --------------
      -- Add_Char --
      --------------

      procedure Add_Char (C : Character) is
      begin
         --  Should really check for max length exceeded here???
         Unit_Name_Length := Unit_Name_Length + 1;
         Unit_Name_Buffer (Unit_Name_Length) := C;
      end Add_Char;

      --------------
      -- Add_Name --
      --------------

      procedure Add_Name (Name : Name_Id) is
      begin
         Get_Name_String (Name);

         for J in 1 .. Name_Len loop
            Add_Char (Name_Buffer (J));
         end loop;
      end Add_Name;

      -------------------
      -- Add_Node_Name --
      -------------------

      procedure Add_Node_Name (Node : Node_Id) is
         Kind : constant Node_Kind := Nkind (Node);

      begin
         --  Just ignore an error node (someone else will give a message)

         if Node = Error then
            return;

         --  Otherwise see what kind of node we have

         else
            case Kind is

               when N_Identifier                      |
                    N_Defining_Identifier             |
                    N_Defining_Operator_Symbol        =>

                  --  Note: it is of course an error to have a defining
                  --  operator symbol at this point, but this is not where
                  --  the error is signalled, so we handle it nicely here!

                  Add_Name (Chars (Node));

               when N_Defining_Program_Unit_Name      =>
                  Add_Node_Name (Name (Node));
                  Add_Char ('.');
                  Add_Node_Name (Defining_Identifier (Node));

               when N_Selected_Component              |
                    N_Expanded_Name                   =>
                  Add_Node_Name (Prefix (Node));
                  Add_Char ('.');
                  Add_Node_Name (Selector_Name (Node));

               when N_Subprogram_Specification        |
                    N_Package_Specification           =>
                  Add_Node_Name (Defining_Unit_Name (Node));

               when N_Subprogram_Body                 |
                    N_Subprogram_Declaration          |
                    N_Package_Declaration             |
                    N_Generic_Declaration             =>
                  Add_Node_Name (Specification (Node));

               when N_Generic_Instantiation           =>
                  Add_Node_Name (Defining_Unit_Name (Node));

               when N_Package_Body                    =>
                  Add_Node_Name (Defining_Unit_Name (Node));

               when N_Task_Body                       |
                    N_Protected_Body                  =>
                  Add_Node_Name (Defining_Identifier (Node));

               when N_Package_Renaming_Declaration    =>
                  Add_Node_Name (Defining_Unit_Name (Node));

               when N_Subprogram_Renaming_Declaration =>
                  Add_Node_Name (Specification (Node));

               when N_Generic_Renaming_Declaration   =>
                  Add_Node_Name (Defining_Unit_Name (Node));

               when N_Subprogram_Body_Stub            =>
                  Add_Node_Name (Get_Parent (Node));
                  Add_Char ('.');
                  Add_Node_Name (Specification (Node));

               when N_Compilation_Unit                =>
                  Add_Node_Name (Unit (Node));

               when N_Package_Body_Stub               =>
                  Add_Node_Name (Get_Parent (Node));
                  Add_Char ('.');
                  Add_Node_Name (Defining_Identifier (Node));

               when N_Task_Body_Stub                  |
                    N_Protected_Body_Stub             =>
                  Add_Node_Name (Get_Parent (Node));
                  Add_Char ('.');
                  Add_Node_Name (Defining_Identifier (Node));

               when N_Subunit                         =>
                  Add_Node_Name (Name (Node));
                  Add_Char ('.');
                  Add_Node_Name (Proper_Body (Node));

               when N_With_Clause                     =>
                  Add_Node_Name (Name (Node));

               when N_Pragma                          =>
                  Add_Node_Name (Expression (First
                    (Pragma_Argument_Associations (Node))));

               --  Tasks and protected stuff appear only in an error context,
               --  but the error has been posted elsewhere, so we deal nicely
               --  with these error situations here, and produce a reasonable
               --  unit name using the defining identifier.

               when N_Task_Type_Declaration           |
                    N_Single_Task_Declaration         |
                    N_Protected_Type_Declaration      |
                    N_Single_Protected_Declaration    =>
                  Add_Node_Name (Defining_Identifier (Node));

               when others =>
                  raise Program_Error;

            end case;
         end if;
      end Add_Node_Name;

      ----------------
      -- Get_Parent --
      ----------------

      function Get_Parent (Node : Node_Id) return Node_Id is
         N : Node_Id := Node;

      begin
         while Nkind (N) /= N_Compilation_Unit loop
            N := Parent (N);
         end loop;

         return N;
      end Get_Parent;

   -------------------------------------------
   -- Start of Processing for Get_Unit_Name --
   -------------------------------------------

   begin
      Node := N;

      --  If we have Defining_Identifier, find the associated unit node

      if Nkind (Node) = N_Defining_Identifier then
         Node := Declaration_Node (Node);

      --  If an expanded name, it is an already analyzed child unit, find
      --  unit node.

      elsif Nkind (Node) = N_Expanded_Name then
         Node := Declaration_Node (Entity (Node));
      end if;

      if Nkind (Node) = N_Package_Specification
        or else Nkind (Node) in N_Subprogram_Specification
      then
         Node := Parent (Node);
      end if;

      --  Node points to the unit, so get its name and add proper suffix

      Add_Node_Name (Node);
      Add_Char ('%');

      case Nkind (Node) is
         when N_Generic_Declaration             |
              N_Subprogram_Declaration          |
              N_Package_Declaration             |
              N_With_Clause                     |
              N_Pragma                          |
              N_Generic_Instantiation           |
              N_Package_Renaming_Declaration    |
              N_Subprogram_Renaming_Declaration |
              N_Generic_Renaming_Declaration    |
              N_Single_Task_Declaration         |
              N_Single_Protected_Declaration    |
              N_Task_Type_Declaration           |
              N_Protected_Type_Declaration      =>

            Add_Char ('s');

         when N_Subprogram_Body                 |
              N_Package_Body                    |
              N_Subunit                         |
              N_Body_Stub                       |
              N_Task_Body                       |
              N_Protected_Body                  |
              N_Identifier                      |
              N_Selected_Component              =>

            Add_Char ('b');

         when others =>
            raise Program_Error;
      end case;

      Name_Buffer (1 .. Unit_Name_Length) :=
        Unit_Name_Buffer (1 .. Unit_Name_Length);
      Name_Len := Unit_Name_Length;
      return Name_Find;

   end Get_Unit_Name;

   --------------------------
   -- Get_Unit_Name_String --
   --------------------------

   procedure Get_Unit_Name_String
     (N      : Unit_Name_Type;
      Suffix : Boolean := True)
   is
      Unit_Is_Body : Boolean;

   begin
      Get_Decoded_Name_String (N);
      Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
      Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);

      --  A special fudge, normally we don't have operator symbols present,
      --  since it is always an error to do so. However, if we do, at this
      --  stage it has the form:

      --    "and"

      --  and the %s or %b has already been eliminated so put 2 chars back

      if Name_Buffer (1) = '"' then
         Name_Len := Name_Len + 2;
      end if;

      --  Now adjust the %s or %b to (spec) or (body)

      if Suffix then
         if Unit_Is_Body then
            Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
         else
            Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
         end if;
      end if;

      for J in 1 .. Name_Len loop
         if Name_Buffer (J) = '-' then
            Name_Buffer (J) := '.';
         end if;
      end loop;

      --  Adjust Name_Len

      if Suffix then
         Name_Len := Name_Len + (7 - 2);
      else
         Name_Len := Name_Len - 2;
      end if;
   end Get_Unit_Name_String;

   ------------------
   -- Is_Body_Name --
   ------------------

   function Is_Body_Name (N : Unit_Name_Type) return Boolean is
   begin
      Get_Name_String (N);
      return Name_Len > 2
        and then Name_Buffer (Name_Len - 1) = '%'
        and then Name_Buffer (Name_Len) = 'b';
   end Is_Body_Name;

   -------------------
   -- Is_Child_Name --
   -------------------

   function Is_Child_Name (N : Unit_Name_Type) return Boolean is
      J : Natural;

   begin
      Get_Name_String (N);
      J := Name_Len;

      while Name_Buffer (J) /= '.' loop
         if J = 1 then
            return False; -- not a child or subunit name
         else
            J := J - 1;
         end if;
      end loop;

      return True;
   end Is_Child_Name;

   ------------------
   -- Is_Spec_Name --
   ------------------

   function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
   begin
      Get_Name_String (N);
      return Name_Len > 2
        and then Name_Buffer (Name_Len - 1) = '%'
        and then Name_Buffer (Name_Len) = 's';
   end Is_Spec_Name;

   -----------------------
   -- Name_To_Unit_Name --
   -----------------------

   function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
   begin
      Get_Name_String (N);
      Name_Buffer (Name_Len + 1) := '%';
      Name_Buffer (Name_Len + 2) := 's';
      Name_Len := Name_Len + 2;
      return Name_Find;
   end Name_To_Unit_Name;

   ---------------
   -- New_Child --
   ---------------

   function New_Child
     (Old  : Unit_Name_Type;
      Newp : Unit_Name_Type) return Unit_Name_Type
   is
      P : Natural;

   begin
      Get_Name_String (Old);

      declare
         Child : constant String := Name_Buffer (1 .. Name_Len);

      begin
         Get_Name_String (Newp);
         Name_Len := Name_Len - 2;

         P := Child'Last;
         while Child (P) /= '.' loop
            P := P - 1;
         end loop;

         while P <= Child'Last loop
            Name_Len := Name_Len + 1;
            Name_Buffer (Name_Len) := Child (P);
            P := P + 1;
         end loop;

         return Name_Find;
      end;
   end New_Child;

   --------------
   -- Uname_Ge --
   --------------

   function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is
   begin
      return Left = Right or else Uname_Gt (Left, Right);
   end Uname_Ge;

   --------------
   -- Uname_Gt --
   --------------

   function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is
   begin
      return Left /= Right and then not Uname_Lt (Left, Right);
   end Uname_Gt;

   --------------
   -- Uname_Le --
   --------------

   function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is
   begin
      return Left = Right or else Uname_Lt (Left, Right);
   end Uname_Le;

   --------------
   -- Uname_Lt --
   --------------

   function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is
      Left_Name    : String (1 .. Hostparm.Max_Name_Length);
      Left_Length  : Natural;
      Right_Name   : String renames Name_Buffer;
      Right_Length : Natural renames Name_Len;
      J            : Natural;

   begin
      pragma Warnings (Off, Right_Length);
      --  Suppress warnings on Right_Length, used in pragma Assert

      if Left = Right then
         return False;
      end if;

      Get_Name_String (Left);
      Left_Name  (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1);
      Left_Length := Name_Len;
      Get_Name_String (Right);
      J := 1;

      loop
         exit when Left_Name (J) = '%';

         if Right_Name (J) = '%' then
            return False; -- left name is longer
         end if;

         pragma Assert (J <= Left_Length and then J <= Right_Length);

         if Left_Name (J) /= Right_Name (J) then
            return Left_Name (J) < Right_Name (J); -- parent names different
         end if;

         J := J + 1;
      end loop;

      --  Come here pointing to % in left name

      if Right_Name (J) /= '%' then
         return True; -- right name is longer
      end if;

      --  Here the parent names are the same and specs sort low. If neither is
      --  a spec, then we are comparing the same name and we want a result of
      --  False in any case.

      return Left_Name (J + 1) = 's';
   end Uname_Lt;

   ---------------------
   -- Write_Unit_Name --
   ---------------------

   procedure Write_Unit_Name (N : Unit_Name_Type) is
   begin
      Get_Unit_Name_String (N);
      Write_Str (Name_Buffer (1 .. Name_Len));
   end Write_Unit_Name;

end Uname;