Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                                U N A M E                                 --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, 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 Namet;    use Namet;

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_Name; -- not a child or subunit 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) 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 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;

      for J in 1 .. Name_Len loop

         if Name_Buffer (J) = '-' then

            Name_Buffer (J) := '.';

         end if;

      end loop;

      Name_Len := Name_Len + (7 - 2);

   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;