Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ T S S                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

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

with Exp_Util; use Exp_Util;

with Nlists;   use Nlists;

with Lib;      use Lib;

with Restrict; use Restrict;

with Rident;   use Rident;

with Sem_Aux;  use Sem_Aux;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

package body Exp_Tss is

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

   -- Base_Init_Proc --

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

   function Base_Init_Proc

     (Typ : Entity_Id;

      Ref : Entity_Id := Empty) return Entity_Id

   is

      Full_Type : E;

      Proc      : Entity_Id;

   begin

      pragma Assert (Is_Type (Typ));

      if Is_Private_Type (Typ) then

         Full_Type := Underlying_Type (Base_Type (Typ));

      else

         Full_Type := Typ;

      end if;

      if No (Full_Type) then

         return Empty;

      elsif Is_Concurrent_Type (Full_Type)

        and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))

      then

         --  The initialization routine to be called is that of the base type

         --  of the corresponding record type, which may itself be a subtype

         --  and possibly an itype.

         return Init_Proc

           (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),

            Ref);

      else

         Proc := Init_Proc (Base_Type (Full_Type), Ref);

         if No (Proc)

           and then Is_Composite_Type (Full_Type)

           and then Is_Derived_Type (Full_Type)

         then

            return Init_Proc (Root_Type (Full_Type), Ref);

         else

            return Proc;

         end if;

      end if;

   end Base_Init_Proc;

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

   -- Copy_TSS --

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

   --  Note: internally this routine is also used to initially set up

   --  a TSS entry for a new type (case of being called from Set_TSS)

   procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is

      FN : Node_Id;

   begin

      Ensure_Freeze_Node (Typ);

      FN := Freeze_Node (Typ);

      if No (TSS_Elist (FN)) then

         Set_TSS_Elist (FN, New_Elmt_List);

      end if;

      --  We prepend here, so that a second call overrides the first, it

      --  is not clear that this is required, but it seems reasonable.

      Prepend_Elmt (TSS, TSS_Elist (FN));

   end Copy_TSS;

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

   -- Find_Inherited_TSS --

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

   function Find_Inherited_TSS

     (Typ : Entity_Id;

      Nam : TSS_Name_Type) return Entity_Id

   is

      Btyp : Entity_Id := Typ;

      Proc : Entity_Id;

   begin

      loop

         Btyp := Base_Type (Btyp);

         Proc :=  TSS (Btyp, Nam);

         exit when Present (Proc)

           or else not Is_Derived_Type (Btyp);

         --  If Typ is a derived type, it may inherit attributes from some

         --  ancestor.

         Btyp := Etype (Btyp);

      end loop;

      if No (Proc) then

         --  If nothing else, use the TSS of the root type

         Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);

      end if;

      return Proc;

   end Find_Inherited_TSS;

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

   -- Get_TSS_Name_Type --

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

   function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is

      C1 : Character;

      C2 : Character;

      Nm : TSS_Name_Type;

   begin

      Get_Last_Two_Chars (Chars (E), C1, C2);

      if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then

         Nm := (C1, C2);

         for J in TSS_Names'Range loop

            if Nm = TSS_Names (J) then

               return Nm;

            end if;

         end loop;

      end if;

      return TSS_Null;

   end Get_TSS_Name;

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

   -- Has_Non_Null_Base_Init_Proc --

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

   --  Note: if a base Init_Proc is present, and No_Default_Initialization is

   --  present, then we must avoid testing for a null init proc, since there

   --  is no init proc present in this case.

   function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is

      BIP : constant Entity_Id := Base_Init_Proc (Typ);

   begin

      return Present (BIP)

        and then (Restriction_Active (No_Default_Initialization)

                    or else not Is_Null_Init_Proc (BIP));

   end Has_Non_Null_Base_Init_Proc;

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

   -- Init_Proc --

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

   function Init_Proc

     (Typ  : Entity_Id;

      Ref  : Entity_Id := Empty) return Entity_Id

   is

      FN   : constant Node_Id := Freeze_Node (Typ);

      Elmt : Elmt_Id;

      E1   : Entity_Id;

      E2   : Entity_Id;

   begin

      if No (FN) then

         return Empty;

      elsif No (TSS_Elist (FN)) then

         return Empty;

      elsif No (Ref) then

         Elmt := First_Elmt (TSS_Elist (FN));

         while Present (Elmt) loop

            if Is_Init_Proc (Node (Elmt)) then

               if not Is_CPP_Class (Typ) then

                  return Node (Elmt);

               --  For CPP classes, we are looking for the default constructor,

               --  and so we must skip any non-default constructor.

               elsif

                 No (Next

                      (First

                        (Parameter_Specifications (Parent (Node (Elmt))))))

               then

                  return Node (Elmt);

               end if;

            end if;

            Next_Elmt (Elmt);

         end loop;

      --  Non-default constructors are currently supported only in the context

      --  of interfacing with C++.

      else pragma Assert (Is_CPP_Class (Typ));

         --  Use the referenced function to locate the init_proc matching

         --  the C++ constructor.

         Elmt := First_Elmt (TSS_Elist (FN));

         while Present (Elmt) loop

            if Is_Init_Proc (Node (Elmt)) then

               E1 := Next_Formal (First_Formal (Node (Elmt)));

               E2 := First_Formal (Ref);

               while Present (E1) and then Present (E2) loop

                  if Chars (E1) /= Chars (E2)

                    or else Ekind (E1) /= Ekind (E2)

                  then

                     exit;

                  elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type

                    and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type

                    and then Etype (E1) /= Etype (E2)

                  then

                     exit;

                  elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type

                    and then Ekind (Etype (E2)) = E_Anonymous_Access_Type

                    and then Directly_Designated_Type (Etype (E1))

                               /= Directly_Designated_Type (Etype (E2))

                  then

                     exit;

                  end if;

                  E1 := Next_Formal (E1);

                  E2 := Next_Formal (E2);

               end loop;

               if No (E1) and then No (E2) then

                  return Node (Elmt);

               end if;

            end if;

            Next_Elmt (Elmt);

         end loop;

      end if;

      return Empty;

   end Init_Proc;

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

   -- Is_Init_Proc --

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

   function Is_Init_Proc (E : Entity_Id) return Boolean is

      C1 : Character;

      C2 : Character;

   begin

      Get_Last_Two_Chars (Chars (E), C1, C2);

      return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);

   end Is_Init_Proc;

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

   -- Is_TSS --

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

   function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is

      C1 : Character;

      C2 : Character;

   begin

      Get_Last_Two_Chars (Chars (E), C1, C2);

      return C1 = Nam (1) and then C2 = Nam (2);

   end Is_TSS;

   function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is

      C1 : Character;

      C2 : Character;

   begin

      Get_Last_Two_Chars (N, C1, C2);

      return C1 = Nam (1) and then C2 = Nam (2);

   end Is_TSS;

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

   -- Make_Init_Proc_Name --

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

   function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is

   begin

      return Make_TSS_Name (Typ, TSS_Init_Proc);

   end Make_Init_Proc_Name;

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

   -- Make_TSS_Name --

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

   function Make_TSS_Name

     (Typ : Entity_Id;

      Nam : TSS_Name_Type) return Name_Id

   is

   begin

      Get_Name_String (Chars (Typ));

      Add_Char_To_Name_Buffer (Nam (1));

      Add_Char_To_Name_Buffer (Nam (2));

      return Name_Find;

   end Make_TSS_Name;

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

   -- Make_TSS_Name_Local --

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

   function Make_TSS_Name_Local

     (Typ : Entity_Id;

      Nam : TSS_Name_Type) return Name_Id

   is

   begin

      Get_Name_String (Chars (Typ));

      Add_Char_To_Name_Buffer ('_');

      Add_Nat_To_Name_Buffer (Increment_Serial_Number);

      Add_Char_To_Name_Buffer (Nam (1));

      Add_Char_To_Name_Buffer (Nam (2));

      return Name_Find;

   end Make_TSS_Name_Local;

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

   -- Same_TSS --

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

   function Same_TSS (E1, E2 : Entity_Id) return Boolean is

      E1C1 : Character;

      E1C2 : Character;

      E2C1 : Character;

      E2C2 : Character;

   begin

      Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);

      Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);

      return

        E1C1 = E2C1

          and then

        E1C2 = E2C2

          and then

        E1C1 in 'A' .. 'Z'

          and then

        E1C2 in 'A' .. 'Z';

   end Same_TSS;

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

   -- Set_Init_Proc --

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

   procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is

   begin

      Set_TSS (Typ, Init);

   end Set_Init_Proc;

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

   -- Set_TSS --

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

   procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is

   begin

      --  Make sure body of subprogram is frozen

      --  Skip this for Init_Proc with No_Default_Initialization, since the

      --  Init proc is a dummy void entity in this case to be ignored.

      if Is_Init_Proc (TSS)

        and then Restriction_Active (No_Default_Initialization)

      then

         null;

      --  Skip this if not in the same code unit (since it means we are using

      --  an already existing TSS in another unit)

      elsif not In_Same_Code_Unit (Typ, TSS) then

         null;

      --  Otherwise make sure body is frozen

      else

         Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));

      end if;

      --  Set TSS entry

      Copy_TSS (TSS, Typ);

   end Set_TSS;

   ---------

   -- TSS --

   ---------

   function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is

      FN   : constant Node_Id := Freeze_Node (Typ);

      Elmt : Elmt_Id;

      Subp : Entity_Id;

   begin

      if No (FN) then

         return Empty;

      elsif No (TSS_Elist (FN)) then

         return Empty;

      else

         Elmt := First_Elmt (TSS_Elist (FN));

         while Present (Elmt) loop

            if Is_TSS (Node (Elmt), Nam) then

               Subp := Node (Elmt);

               --  For stream subprograms, the TSS entity may be a renaming-

               --  as-body of an already generated entity. Use that one rather

               --  the one introduced by the renaming, which is an artifact of

               --  current stream handling.

               if Nkind (Parent (Parent (Subp))) =

                                           N_Subprogram_Renaming_Declaration

                 and then

                   Present (Corresponding_Spec (Parent (Parent (Subp))))

               then

                  return Corresponding_Spec (Parent (Parent (Subp)));

               else

                  return Subp;

               end if;

            else

               Next_Elmt (Elmt);

            end if;

         end loop;

      end if;

      return Empty;

   end TSS;

   function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is

      FN   : constant Node_Id := Freeze_Node (Typ);

      Elmt : Elmt_Id;

      Subp : Entity_Id;

   begin

      if No (FN) then

         return Empty;

      elsif No (TSS_Elist (FN)) then

         return Empty;

      else

         Elmt := First_Elmt (TSS_Elist (FN));

         while Present (Elmt) loop

            if Chars (Node (Elmt)) =  Nam then

               Subp := Node (Elmt);

               --  For stream subprograms, the TSS entity may be a renaming-

               --  as-body of an already generated entity. Use that one rather

               --  the one introduced by the renaming, which is an artifact of

               --  current stream handling.

               if Nkind (Parent (Parent (Subp))) =

                                           N_Subprogram_Renaming_Declaration

                 and then

                   Present (Corresponding_Spec (Parent (Parent (Subp))))

               then

                  return Corresponding_Spec (Parent (Parent (Subp)));

               else

                  return Subp;

               end if;

            else

               Next_Elmt (Elmt);

            end if;

         end loop;

      end if;

      return Empty;

   end TSS;

end Exp_Tss;