Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ E L I M                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1997-2010, 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 3,  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 COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the 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 Einfo;    use Einfo;

with Errout;   use Errout;

with Lib;      use Lib;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Opt;      use Opt;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Prag; use Sem_Prag;

with Sem_Util; use Sem_Util;

with Sinput;   use Sinput;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Table;

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

      Source_Location : Name_Id;

      --  String describing the source location of subprogram defining name if

      --  Source_Location parameter present, No_Name if not

      Hash_Link : Access_Elim_Data;

      --  Link for hash table use

      Homonym : Access_Elim_Data;

      --  Pointer to next entry with same key

      Prag : Node_Id;

      --  Node_Id for Eliminate pragma

   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;

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

   -- Tables --

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

   --  The following table records the data for each pragmas, using the

   --  entity name as the hash key for retrieval. Entries in this table

   --  are set by Process_Eliminate_Pragma and read by Check_Eliminated.

   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);

   --  The following table records entities for subprograms that are

   --  eliminated, and corresponding eliminate pragmas that caused the

   --  elimination. Entries in this table are set by Check_Eliminated

   --  and read by Eliminate_Error_Msg.

   type Elim_Entity_Entry is record

      Prag : Node_Id;

      Subp : Entity_Id;

   end record;

   package Elim_Entities is new Table.Table (

     Table_Component_Type => Elim_Entity_Entry,

     Table_Index_Type     => Name_Id'Base,

     Table_Low_Bound      => First_Name_Id,

     Table_Initial        => 50,

     Table_Increment      => 200,

     Table_Name           => "Elim_Entries");

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

   -- Check_Eliminated --

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

   procedure Check_Eliminated (E : Entity_Id) is

      Elmt : Access_Elim_Data;

      Scop : Entity_Id;

      Form : Entity_Id;

      Up   : Nat;

   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;

      --  Loop through homonyms for this key

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

      while Elmt /= null loop

         Check_Homonyms : declare

            procedure Set_Eliminated;

            --  Set current subprogram entity as eliminated

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

            -- Set_Eliminated --

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

            procedure Set_Eliminated is

               Overridden : Entity_Id;

            begin

               if Is_Dispatching_Operation (E) then

                  --  If an overriding dispatching primitive is eliminated then

                  --  its parent must have been eliminated. If the parent is an

                  --  inherited operation, check the operation that it renames,

                  --  because flag Eliminated is only set on source operations.

                  Overridden := Overridden_Operation (E);

                  if Present (Overridden)

                    and then not Comes_From_Source (Overridden)

                    and then Present (Alias (Overridden))

                  then

                     Overridden := Alias (Overridden);

                  end if;

                  if Present (Overridden)

                    and then not Is_Eliminated (Overridden)

                    and then not Is_Abstract_Subprogram (Overridden)

                  then

                     Error_Msg_Name_1 := Chars (E);

                     Error_Msg_N ("cannot eliminate subprogram %", E);

                     return;

                  end if;

               end if;

               Set_Is_Eliminated (E);

               Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));

            end Set_Eliminated;

         --  Start of processing for Check_Homonyms

         begin

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

            if Elmt.Entity_Name /= Chars (E) then

               goto Continue;

            end if;

            --  Find enclosing unit, and verify that its name and those of its

            --  parents match.

            Scop := Cunit_Entity (Current_Sem_Unit);

            --  Now see if compilation unit matches

            Up := Elmt.Unit_Name'Last;

            --  If we are within a subunit, the name in the pragma has been

            --  parsed as a child unit, but the current compilation unit is in

            --  fact the parent in which the subunit is embedded. We must skip

            --  the first name which is that of the subunit to match the pragma

            --  specification. Body may be that of a package or subprogram.

            declare

               Par : Node_Id;

            begin

               Par := Parent (E);

               while Present (Par) loop

                  if Nkind (Par) = N_Subunit then

                     if Chars (Defining_Entity (Proper_Body (Par))) =

                                                         Elmt.Unit_Name (Up)

                     then

                        Up := Up - 1;

                        exit;

                     else

                        goto Continue;

                     end if;

                  end if;

                  Par := Parent (Par);

               end loop;

            end;

            for J in reverse Elmt.Unit_Name'First .. Up 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;

            if Present (Elmt.Entity_Node)

              and then Elmt.Entity_Scope /= null

            then

               --  Check that names of enclosing scopes match. Skip blocks and

               --  wrapper package of subprogram instances, which do not appear

               --  in the pragma.

               Scop := Scope (E);

               for J in reverse  Elmt.Entity_Scope'Range loop

                  while Ekind (Scop) = E_Block

                    or else

                     (Ekind (Scop) = E_Package

                       and then Is_Wrapper_Package (Scop))

                  loop

                     Scop := Scope (Scop);

                  end loop;

                  if Elmt.Entity_Scope (J) /= Chars (Scop) then

                     if Ekind (Scop) /= E_Protected_Type

                       or else Comes_From_Source (Scop)

                     then

                        goto Continue;

                     --  For simple protected declarations, retrieve the source

                     --  name of the object, which appeared in the Eliminate

                     --  pragma.

                     else

                        declare

                           Decl : constant Node_Id :=

                             Original_Node (Parent (Scop));

                        begin

                           if Elmt.Entity_Scope (J) /=

                             Chars (Defining_Identifier (Decl))

                           then

                              if J > 0 then

                                 null;

                              end if;

                              goto Continue;

                           end if;

                        end;

                     end if;

                  end if;

                  Scop := Scope (Scop);

               end loop;

            end if;

            --  If given entity is a library level subprogram and pragma had a

            --  single parameter, a match!

            if Is_Compilation_Unit (E)

              and then Is_Subprogram (E)

              and then No (Elmt.Entity_Node)

            then

               Set_Eliminated;

               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_Eliminated;

               return;

            --  Check for case of subprogram

            elsif Ekind_In (E, E_Function, E_Procedure) then

               --  If Source_Location present, then see if it matches

               if Elmt.Source_Location /= No_Name then

                  Get_Name_String (Elmt.Source_Location);

                  declare

                     Sloc_Trace : constant String :=

                                    Name_Buffer (1 .. Name_Len);

                     Idx : Natural := Sloc_Trace'First;

                     --  Index in Sloc_Trace, if equals to 0, then we have

                     --  completely traversed Sloc_Trace

                     Last : constant Natural := Sloc_Trace'Last;

                     P      : Source_Ptr;

                     Sindex : Source_File_Index;

                     function File_Name_Match return Boolean;

                     --  This function is supposed to be called when Idx points

                     --  to the beginning of the new file name, and Name_Buffer

                     --  is set to contain the name of the proper source file

                     --  from the chain corresponding to the Sloc of E. First

                     --  it checks that these two files have the same name. If

                     --  this check is successful, moves Idx to point to the

                     --  beginning of the column number.

                     function Line_Num_Match return Boolean;

                     --  This function is supposed to be called when Idx points

                     --  to the beginning of the column number, and P is

                     --  set to point to the proper Sloc the chain

                     --  corresponding to the Sloc of E. First it checks that

                     --  the line number Idx points on and the line number

                     --  corresponding to P are the same. If this check is

                     --  successful, moves Idx to point to the beginning of

                     --  the next file name in Sloc_Trace. If there is no file

                     --  name any more, Idx is set to 0.

                     function Different_Trace_Lengths return Boolean;

                     --  From Idx and P, defines if there are in both traces

                     --  more element(s) in the instantiation chains. Returns

                     --  False if one trace contains more element(s), but

                     --  another does not. If both traces contains more

                     --  elements (that is, the function returns False), moves

                     --  P ahead in the chain corresponding to E, recomputes

                     --  Sindex and sets the name of the corresponding file in

                     --  Name_Buffer

                     function Skip_Spaces return Natural;

                     --  If Sloc_Trace (Idx) is not space character, returns

                     --  Idx. Otherwise returns the index of the nearest

                     --  non-space character in Sloc_Trace to the right of Idx.

                     --  Returns 0 if there is no such character.

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

                     -- Different_Trace_Lengths --

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

                     function Different_Trace_Lengths return Boolean is

                     begin

                        P := Instantiation (Sindex);

                        if (P = No_Location and then Idx /= 0)

                          or else

                           (P /= No_Location and then Idx = 0)

                        then

                           return True;

                        else

                           if P /= No_Location then

                              Sindex := Get_Source_File_Index (P);

                              Get_Name_String (File_Name (Sindex));

                           end if;

                           return False;

                        end if;

                     end Different_Trace_Lengths;

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

                     -- File_Name_Match --

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

                     function File_Name_Match return Boolean is

                        Tmp_Idx : Natural;

                        End_Idx : Natural;

                     begin

                        if Idx = 0 then

                           return False;

                        end if;

                        --  Find first colon. If no colon, then return False.

                        --  If there is a colon, Tmp_Idx is set to point just

                        --  before the colon.

                        Tmp_Idx := Idx - 1;

                        loop

                           if Tmp_Idx >= Last then

                              return False;

                           elsif Sloc_Trace (Tmp_Idx + 1) = ':' then

                              exit;

                           else

                              Tmp_Idx := Tmp_Idx + 1;

                           end if;

                        end loop;

                        --  Find last non-space before this colon. If there is

                        --  no space character before this colon, then return

                        --  False. Otherwise, End_Idx is set to point to this

                        --  non-space character.

                        End_Idx := Tmp_Idx;

                        loop

                           if End_Idx < Idx then

                              return False;

                           elsif Sloc_Trace (End_Idx) /= ' ' then

                              exit;

                           else

                              End_Idx := End_Idx - 1;

                           end if;

                        end loop;

                        --  Now see if file name matches what is in Name_Buffer

                        --  and if so, step Idx past it and return True. If the

                        --  name does not match, return False.

                        if Sloc_Trace (Idx .. End_Idx) =

                           Name_Buffer (1 .. Name_Len)

                        then

                           Idx := Tmp_Idx + 2;

                           Idx := Skip_Spaces;

                           return True;

                        else

                           return False;

                        end if;

                     end File_Name_Match;

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

                     -- Line_Num_Match --

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

                     function Line_Num_Match return Boolean is

                        N : Int := 0;

                     begin

                        if Idx = 0 then

                           return False;

                        end if;

                        while Idx <= Last

                           and then Sloc_Trace (Idx) in '0' .. '9'

                        loop

                           N := N * 10 +

                            (Character'Pos (Sloc_Trace (Idx)) -

                             Character'Pos ('0'));

                           Idx := Idx + 1;

                        end loop;

                        if Get_Physical_Line_Number (P) =

                           Physical_Line_Number (N)

                        then

                           while Idx <= Last and then

                              Sloc_Trace (Idx) /= '['

                           loop

                              Idx := Idx + 1;

                           end loop;

                           if Idx <= Last and then

                             Sloc_Trace (Idx) = '['

                           then

                              Idx := Idx + 1;

                              Idx := Skip_Spaces;

                           else

                              Idx := 0;

                           end if;

                           return True;

                        else

                           return False;

                        end if;

                     end Line_Num_Match;

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

                     -- Skip_Spaces --

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

                     function Skip_Spaces return Natural is

                        Res : Natural;

                     begin

                        Res := Idx;

                        while Sloc_Trace (Res) = ' ' loop

                           Res := Res + 1;

                           if Res > Last then

                              Res := 0;

                              exit;

                           end if;

                        end loop;

                        return Res;

                     end Skip_Spaces;

                  begin

                     P := Sloc (E);

                     Sindex := Get_Source_File_Index (P);

                     Get_Name_String (File_Name (Sindex));

                     Idx := Skip_Spaces;

                     while Idx > 0 loop

                        if not File_Name_Match then

                           goto Continue;

                        elsif not Line_Num_Match then

                           goto Continue;

                        end if;

                        if Different_Trace_Lengths then

                           goto Continue;

                        end if;

                     end loop;

                  end;

               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'Length = 1

                    and then Elmt.Parameter_Types (1) = No_Name

                  then

                     --  Parameterless procedure matches

                     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_Eliminated;

               return;

            end if;

         end Check_Homonyms;

      <<Continue>>

         Elmt := Elmt.Homonym;

      end loop;

      return;

   end Check_Eliminated;

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

   -- Check_For_Eliminated_Subprogram --

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

   procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is

      Ultimate_Subp  : constant Entity_Id := Ultimate_Alias (S);

      Enclosing_Subp : Entity_Id;

   begin

      if Is_Eliminated (Ultimate_Subp)

        and then not Inside_A_Generic

        and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit))

      then

         Enclosing_Subp := Current_Subprogram;

         while Present (Enclosing_Subp) loop

            if Is_Eliminated (Enclosing_Subp) then

               return;

            end if;

            Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp);

         end loop;

         --  Emit error, unless we are within an instance body and the expander

         --  is disabled, indicating an instance within an enclosing generic.

         --  In an instance, the ultimate alias is an internal entity, so place

         --  the message on the original subprogram.

         if In_Instance_Body and then not Expander_Active then

            null;

         elsif Comes_From_Source (Ultimate_Subp) then

            Eliminate_Error_Msg (N, Ultimate_Subp);

         else

            Eliminate_Error_Msg (N, S);

         end if;

      end if;

   end Check_For_Eliminated_Subprogram;

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

   -- Eliminate_Error_Msg --

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

   procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is

   begin

      for J in Elim_Entities.First .. Elim_Entities.Last loop

         if E = Elim_Entities.Table (J).Subp then

            Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);

            Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E);

            return;

         end if;

      end loop;

      --  If this is an internal operation generated for a protected operation,

      --  its name does not match the source name, so just report the error.

      if not Comes_From_Source (E)

        and then Present (First_Entity (E))

        and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))

      then

         Error_Msg_NE

           ("cannot reference eliminated protected subprogram", N, E);

      --  Otherwise should not fall through, entry should be in table

      else