sem_elim.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ E L I M                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--          Copyright (C) 1997-2001 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- 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 Einfo;   use Einfo;
with Errout;  use Errout;
with Namet;   use Namet;
with Nlists;  use Nlists;
with Sinfo;   use Sinfo;
with Snames;  use Snames;
with Stand;   use Stand;
with Stringt; use Stringt;
with Uintp;   use Uintp;

with GNAT.HTable; use GNAT.HTable;
package body Sem_Elim is

   No_Elimination : Boolean;
   --  Set True if no Eliminate pragmas active

   ---------------------
   -- Data Structures --
   ---------------------

   --  A single pragma Eliminate is represented by the following record

   type Elim_Data;
   type Access_Elim_Data is access Elim_Data;

   type Names is array (Nat range <>) of Name_Id;
   --  Type used to represent set of names. Used for names in Unit_Name
   --  and also the set of names in Argument_Types.

   type Access_Names is access Names;

   type Elim_Data is record

      Unit_Name : Access_Names;
      --  Unit name, broken down into a set of names (e.g. A.B.C is
      --  represented as Name_Id values for A, B, C in sequence).

      Entity_Name : Name_Id;
      --  Entity name if Entity parameter if present. If no Entity parameter
      --  was supplied, then Entity_Node is set to Empty, and the Entity_Name
      --  field contains the last identifier name in the Unit_Name.

      Entity_Scope : Access_Names;
      --  Static scope of the entity within the compilation unit represented by
      --  Unit_Name.

      Entity_Node : Node_Id;
      --  Save node of entity argument, for posting error messages. Set
      --  to Empty if there is no entity argument.

      Parameter_Types : Access_Names;
      --  Set to set of names given for parameter types. If no parameter
      --  types argument is present, this argument is set to null.

      Result_Type : Name_Id;
      --  Result type name if Result_Types parameter present, No_Name if not

      Homonym_Number : Uint;
      --  Homonyn number if Homonym_Number parameter present, No_Uint if not.

      Hash_Link : Access_Elim_Data;
      --  Link for hash table use

      Homonym : Access_Elim_Data;
      --  Pointer to next entry with same key

   end record;

   ----------------
   -- Hash_Table --
   ----------------

   --  Setup hash table using the Entity_Name field as the hash key

   subtype Element is Elim_Data;
   subtype Elmt_Ptr is Access_Elim_Data;

   subtype Key is Name_Id;

   type Header_Num is range 0 .. 1023;

   Null_Ptr : constant Elmt_Ptr := null;

   ----------------------
   -- Hash_Subprograms --
   ----------------------

   package Hash_Subprograms is

      function Equal (F1, F2 : Key) return Boolean;
      pragma Inline (Equal);

      function Get_Key (E : Elmt_Ptr) return Key;
      pragma Inline (Get_Key);

      function Hash (F : Key) return Header_Num;
      pragma Inline (Hash);

      function Next (E : Elmt_Ptr) return Elmt_Ptr;
      pragma Inline (Next);

      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
      pragma Inline (Set_Next);

   end Hash_Subprograms;

   package body Hash_Subprograms is

      -----------
      -- Equal --
      -----------

      function Equal (F1, F2 : Key) return Boolean is
      begin
         return F1 = F2;
      end Equal;

      -------------
      -- Get_Key --
      -------------

      function Get_Key (E : Elmt_Ptr) return Key is
      begin
         return E.Entity_Name;
      end Get_Key;

      ----------
      -- Hash --
      ----------

      function Hash (F : Key) return Header_Num is
      begin
         return Header_Num (Int (F) mod 1024);
      end Hash;

      ----------
      -- Next --
      ----------

      function Next (E : Elmt_Ptr) return Elmt_Ptr is
      begin
         return E.Hash_Link;
      end Next;

      --------------
      -- Set_Next --
      --------------

      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
      begin
         E.Hash_Link := Next;
      end Set_Next;
   end Hash_Subprograms;

   package Elim_Hash_Table is new Static_HTable (
      Header_Num => Header_Num,
      Element    => Element,
      Elmt_Ptr   => Elmt_Ptr,
      Null_Ptr   => Null_Ptr,
      Set_Next   => Hash_Subprograms.Set_Next,
      Next       => Hash_Subprograms.Next,
      Key        => Key,
      Get_Key    => Hash_Subprograms.Get_Key,
      Hash       => Hash_Subprograms.Hash,
      Equal      => Hash_Subprograms.Equal);

   ----------------------
   -- Check_Eliminated --
   ----------------------

   procedure Check_Eliminated (E : Entity_Id) is
      Elmt : Access_Elim_Data;
      Scop : Entity_Id;
      Form : Entity_Id;
      Ctr  : Nat;
      Ent  : Entity_Id;

   begin
      if No_Elimination then
         return;

      --  Elimination of objects and types is not implemented yet.

      elsif Ekind (E) not in Subprogram_Kind then
         return;
      end if;

      Elmt := Elim_Hash_Table.Get (Chars (E));

      --  Loop through homonyms for this key

      while Elmt /= null loop

         --  First we check that the name of the entity matches

         if Elmt.Entity_Name /= Chars (E) then
            goto Continue;
         end if;

         --  Then we need to see if the static scope matches within the
         --  compilation unit.

         Scop := Scope (E);
         if Elmt.Entity_Scope /= null then
            for J in reverse Elmt.Entity_Scope'Range loop
               if Elmt.Entity_Scope (J) /= Chars (Scop) then
                  goto Continue;
               end if;

               Scop := Scope (Scop);

               if not Is_Compilation_Unit (Scop) and then J = 1 then
                  goto Continue;
               end if;
            end loop;
         end if;

         --  Now see if compilation unit matches

         for J in reverse Elmt.Unit_Name'Range loop
            if Elmt.Unit_Name (J) /= Chars (Scop) then
               goto Continue;
            end if;

            Scop := Scope (Scop);

            if Scop /= Standard_Standard and then J = 1 then
               goto Continue;
            end if;
         end loop;

         if Scop /= Standard_Standard then
            goto Continue;
         end if;

         --  Check for case of given entity is a library level subprogram
         --  and we have the single parameter Eliminate case, a match!

         if Is_Compilation_Unit (E)
           and then Is_Subprogram (E)
           and then No (Elmt.Entity_Node)
         then
            Set_Is_Eliminated (E);
            return;

         --  Check for case of type or object with two parameter case

         elsif (Is_Type (E) or else Is_Object (E))
           and then Elmt.Result_Type = No_Name
           and then Elmt.Parameter_Types = null
         then
            Set_Is_Eliminated (E);
            return;

         --  Check for case of subprogram

         elsif Ekind (E) = E_Function
           or else Ekind (E) = E_Procedure
         then
            --  If Homonym_Number present, then see if it matches

            if Elmt.Homonym_Number /= No_Uint then
               Ctr := 1;

               Ent := E;
               while Present (Homonym (Ent))
                 and then Scope (Ent) = Scope (Homonym (Ent))
               loop
                  Ctr := Ctr + 1;
                  Ent := Homonym (Ent);
               end loop;

               if Ctr /= Elmt.Homonym_Number then
                  goto Continue;
               end if;
            end if;

            --  If we have a Result_Type, then we must have a function
            --  with the proper result type

            if Elmt.Result_Type /= No_Name then
               if Ekind (E) /= E_Function
                 or else Chars (Etype (E)) /= Elmt.Result_Type
               then
                  goto Continue;
               end if;
            end if;

            --  If we have Parameter_Types, they must match

            if Elmt.Parameter_Types /= null then
               Form := First_Formal (E);

               if No (Form) and then Elmt.Parameter_Types = null then
                  null;

               elsif Elmt.Parameter_Types = null then
                  goto Continue;

               else
                  for J in Elmt.Parameter_Types'Range loop
                     if No (Form)
                       or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
                     then
                        goto Continue;
                     else
                        Next_Formal (Form);
                     end if;
                  end loop;

                  if Present (Form) then
                     goto Continue;
                  end if;
               end if;
            end if;

            --  If we fall through, this is match

            Set_Is_Eliminated (E);
            return;
         end if;

         <<Continue>> Elmt := Elmt.Homonym;
      end loop;

      return;
   end Check_Eliminated;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Elim_Hash_Table.Reset;
      No_Elimination := True;
   end Initialize;

   ------------------------------
   -- Process_Eliminate_Pragma --
   ------------------------------

   procedure Process_Eliminate_Pragma
     (Arg_Unit_Name       : Node_Id;
      Arg_Entity          : Node_Id;
      Arg_Parameter_Types : Node_Id;
      Arg_Result_Type     : Node_Id;
      Arg_Homonym_Number  : Node_Id)
   is
      Data : constant Access_Elim_Data := new Elim_Data;
      --  Build result data here

      Elmt : Access_Elim_Data;

      Num_Names : Nat := 0;
      --  Number of names in unit name

      Lit       : Node_Id;
      Arg_Ent   : Entity_Id;
      Arg_Uname : Node_Id;

      function OK_Selected_Component (N : Node_Id) return Boolean;
      --  Test if N is a selected component with all identifiers, or a
      --  selected component whose selector is an operator symbol. As a
      --  side effect if result is True, sets Num_Names to the number
      --  of names present (identifiers and operator if any).

      ---------------------------
      -- OK_Selected_Component --
      ---------------------------

      function OK_Selected_Component (N : Node_Id) return Boolean is
      begin
         if Nkind (N) = N_Identifier
           or else Nkind (N) = N_Operator_Symbol
         then
            Num_Names := Num_Names + 1;
            return True;

         elsif Nkind (N) = N_Selected_Component then
            return OK_Selected_Component (Prefix (N))
              and then OK_Selected_Component (Selector_Name (N));

         else
            return False;
         end if;
      end OK_Selected_Component;

   --  Start of processing for Process_Eliminate_Pragma

   begin
      Error_Msg_Name_1 := Name_Eliminate;

      --  Process Unit_Name argument

      if Nkind (Arg_Unit_Name) = N_Identifier then
         Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
         Num_Names := 1;

      elsif OK_Selected_Component (Arg_Unit_Name) then
         Data.Unit_Name := new Names (1 .. Num_Names);

         Arg_Uname := Arg_Unit_Name;
         for J in reverse 2 .. Num_Names loop
            Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
            Arg_Uname := Prefix (Arg_Uname);
         end loop;

         Data.Unit_Name (1) := Chars (Arg_Uname);

      else
         Error_Msg_N
           ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
         return;
      end if;

      --  Process Entity argument

      if Present (Arg_Entity) then
         Num_Names := 0;

         if Nkind (Arg_Entity) = N_Identifier
           or else Nkind (Arg_Entity) = N_Operator_Symbol
         then
            Data.Entity_Name  := Chars (Arg_Entity);
            Data.Entity_Node  := Arg_Entity;
            Data.Entity_Scope := null;

         elsif OK_Selected_Component (Arg_Entity) then
            Data.Entity_Scope := new Names (1 .. Num_Names - 1);
            Data.Entity_Name  := Chars (Selector_Name (Arg_Entity));
            Data.Entity_Node  := Arg_Entity;

            Arg_Ent := Prefix (Arg_Entity);
            for J in reverse 2 .. Num_Names - 1 loop
               Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
               Arg_Ent := Prefix (Arg_Ent);
            end loop;

            Data.Entity_Scope (1) := Chars (Arg_Ent);

         elsif Nkind (Arg_Entity) = N_String_Literal then
            String_To_Name_Buffer (Strval (Arg_Entity));
            Data.Entity_Name := Name_Find;
            Data.Entity_Node := Arg_Entity;

         else
            Error_Msg_N
              ("wrong form for Entity_Argument parameter of pragma%",
               Arg_Unit_Name);
            return;
         end if;
      else
         Data.Entity_Node := Empty;
         Data.Entity_Name := Data.Unit_Name (Num_Names);
      end if;

      --  Process Parameter_Types argument

      if Present (Arg_Parameter_Types) then

         --  Case of one name, which looks like a parenthesized literal
         --  rather than an aggregate.

         if Nkind (Arg_Parameter_Types) = N_String_Literal
           and then Paren_Count (Arg_Parameter_Types) = 1
         then
            String_To_Name_Buffer (Strval (Arg_Parameter_Types));
            Data.Parameter_Types := new Names'(1 => Name_Find);

         --  Otherwise must be an aggregate

         elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
           or else Present (Component_Associations (Arg_Parameter_Types))
           or else No (Expressions (Arg_Parameter_Types))
         then
            Error_Msg_N
              ("Parameter_Types for pragma% must be list of string literals",
               Arg_Parameter_Types);
            return;

         --  Here for aggregate case

         else
            Data.Parameter_Types :=
              new Names
                (1 .. List_Length (Expressions (Arg_Parameter_Types)));

            Lit := First (Expressions (Arg_Parameter_Types));
            for J in Data.Parameter_Types'Range loop
               if Nkind (Lit) /= N_String_Literal then
                  Error_Msg_N
                    ("parameter types for pragma% must be string literals",
                     Lit);
                  return;
               end if;

               String_To_Name_Buffer (Strval (Lit));
               Data.Parameter_Types (J) := Name_Find;
               Next (Lit);
            end loop;
         end if;
      end if;

      --  Process Result_Types argument

      if Present (Arg_Result_Type) then

         if Nkind (Arg_Result_Type) /= N_String_Literal then
            Error_Msg_N
              ("Result_Type argument for pragma% must be string literal",
               Arg_Result_Type);
            return;
         end if;

         String_To_Name_Buffer (Strval (Arg_Result_Type));
         Data.Result_Type := Name_Find;

      else
         Data.Result_Type := No_Name;
      end if;

      --  Process Homonym_Number argument

      if Present (Arg_Homonym_Number) then

         if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then
            Error_Msg_N
              ("Homonym_Number argument for pragma% must be integer literal",
               Arg_Homonym_Number);
            return;
         end if;

         Data.Homonym_Number := Intval (Arg_Homonym_Number);

      else
         Data.Homonym_Number := No_Uint;
      end if;

      --  Now link this new entry into the hash table

      Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));

      --  If we already have an entry with this same key, then link
      --  it into the chain of entries for this key.

      if Elmt /= null then
         Data.Homonym := Elmt.Homonym;
         Elmt.Homonym := Data;

      --  Otherwise create a new entry

      else
         Elim_Hash_Table.Set (Data);
      end if;

      No_Elimination := False;
   end Process_Eliminate_Pragma;

end Sem_Elim;