[thirdparty/gcc.git] / gcc / ada / sem_dist.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ D I S T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2003, 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 Casing;   use Casing;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Exp_Dist; use Exp_Dist;
with Exp_Tss;  use Exp_Tss;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Namet;    use Namet;
with Opt;      use Opt;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Res;  use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Stand;    use Stand;
with Stringt;  use Stringt;
with Tbuild;   use Tbuild;
with Uname;    use Uname;

package body Sem_Dist is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure RAS_E_Dereference (Pref : Node_Id);
   --  Handles explicit dereference of Remote Access to Subprograms.

   function Full_Qualified_Name (E : Entity_Id) return String_Id;
   --  returns the full qualified name of the entity in lower case.

   -------------------------
   -- Add_Stub_Constructs --
   -------------------------

   procedure Add_Stub_Constructs (N : Node_Id) is
      U    : constant Node_Id := Unit (N);
      Spec : Entity_Id        := Empty;
      Exp  : Node_Id          := U;         --  Unit that will be expanded

   begin
      pragma Assert (Distribution_Stub_Mode /= No_Stubs);

      if Nkind (U) = N_Package_Declaration then
         Spec := Defining_Entity (Specification (U));

      elsif Nkind (U) = N_Package_Body then
         Spec := Corresponding_Spec (U);

      else pragma Assert (Nkind (U) = N_Package_Instantiation);
         Exp  := Instance_Spec (U);
         Spec := Defining_Entity (Specification (Exp));
      end if;

      pragma Assert (Is_Shared_Passive (Spec)
        or else Is_Remote_Call_Interface (Spec));

      if Distribution_Stub_Mode = Generate_Caller_Stub_Body then

         if Is_Shared_Passive (Spec) then
            null;
         elsif Nkind (U) = N_Package_Body then
            Error_Msg_N
              ("Specification file expected from command line", U);
         else
            Expand_Calling_Stubs_Bodies (Exp);
         end if;

      else

         if Is_Shared_Passive (Spec) then
            Build_Passive_Partition_Stub (Exp);
         else
            Expand_Receiving_Stubs_Bodies (Exp);
         end if;

      end if;
   end Add_Stub_Constructs;

   -------------------------
   -- Full_Qualified_Name --
   -------------------------

   function Full_Qualified_Name (E : Entity_Id) return String_Id is
      Ent         : Entity_Id := E;
      Parent_Name : String_Id := No_String;

   begin
      --  Deals properly with child units

      if Nkind (Ent) = N_Defining_Program_Unit_Name then
         Ent := Defining_Identifier (Ent);
      end if;

      --  Compute recursively the qualification. Only "Standard" has no scope.

      if Present (Scope (Scope (Ent))) then
         Parent_Name := Full_Qualified_Name (Scope (Ent));
      end if;

      --  Every entity should have a name except some expanded blocks
      --  don't bother about those.

      if Chars (Ent) = No_Name then
         return Parent_Name;
      end if;

      --  Add a period between Name and qualification

      if Parent_Name /= No_String then
         Start_String (Parent_Name);
         Store_String_Char (Get_Char_Code ('.'));

      else
         Start_String;
      end if;

      --  Generates the entity name in upper case

      Get_Name_String (Chars (Ent));
      Set_Casing (All_Lower_Case);
      Store_String_Chars (Name_Buffer (1 .. Name_Len));
      return End_String;
   end Full_Qualified_Name;

   -----------------------
   -- Get_Subprogram_Id --
   -----------------------

   function Get_Subprogram_Id (E : Entity_Id) return Int is
      Current_Declaration : Node_Id;
      Result              : Int := 0;

   begin
      pragma Assert
        (Is_Remote_Call_Interface (Scope (E))
           and then
             (Nkind (Parent (E)) = N_Procedure_Specification
                or else
              Nkind (Parent (E)) = N_Function_Specification));

      Current_Declaration :=
        First (Visible_Declarations
          (Package_Specification_Of_Scope (Scope (E))));

      while Current_Declaration /= Empty loop
         if Nkind (Current_Declaration) = N_Subprogram_Declaration
           and then Comes_From_Source (Current_Declaration)
         then
            if Defining_Unit_Name
                 (Specification (Current_Declaration)) = E
            then
               return Result;
            end if;

            Result := Result + 1;
         end if;

         Next (Current_Declaration);
      end loop;

      --  Error if we do not find it

      raise Program_Error;
   end Get_Subprogram_Id;

   ------------------------
   -- Is_All_Remote_Call --
   ------------------------

   function Is_All_Remote_Call (N : Node_Id) return Boolean is
      Par : Node_Id;

   begin
      if (Nkind (N) = N_Function_Call
              or else Nkind (N) = N_Procedure_Call_Statement)
        and then Nkind (Name (N)) in N_Has_Entity
        and then Is_Remote_Call_Interface (Entity (Name (N)))
        and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
        and then Comes_From_Source (N)
      then
         Par := Parent (Entity (Name (N)));

         while Present (Par)
           and then (Nkind (Par) /= N_Package_Specification
                       or else Is_Wrapper_Package (Defining_Entity (Par)))
         loop
            Par := Parent (Par);
         end loop;

         if Present (Par) then
            return
              not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
         else
            return False;
         end if;
      else
         return False;
      end if;
   end Is_All_Remote_Call;

   ------------------------------------
   -- Package_Specification_Of_Scope --
   ------------------------------------

   function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
      N : Node_Id := Parent (E);
   begin
      while Nkind (N) /= N_Package_Specification loop
         N := Parent (N);
      end loop;

      return N;
   end Package_Specification_Of_Scope;

   --------------------------
   -- Process_Partition_ID --
   --------------------------

   procedure Process_Partition_Id (N : Node_Id) is
      Loc            : constant Source_Ptr := Sloc (N);
      Ety            : Entity_Id;
      Get_Pt_Id      : Node_Id;
      Get_Pt_Id_Call : Node_Id;
      Prefix_String  : String_Id;
      Typ            : constant Entity_Id := Etype (N);

   begin
      Ety := Entity (Prefix (N));

      --  In case prefix is not a library unit entity, get the entity
      --  of library unit.

      while (Present (Scope (Ety))
        and then Scope (Ety) /= Standard_Standard)
        and not Is_Child_Unit (Ety)
      loop
         Ety := Scope (Ety);
      end loop;

      --  Retrieve the proper function to call.

      if Is_Remote_Call_Interface (Ety) then
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Active_Partition_Id), Loc);

      elsif Is_Shared_Passive (Ety) then
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Passive_Partition_Id), Loc);

      else
         Get_Pt_Id := New_Occurrence_Of
           (RTE (RE_Get_Local_Partition_Id), Loc);
      end if;

      --  Get and store the String_Id corresponding to the name of the
      --  library unit whose Partition_Id is needed

      Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));

      --  Remove seven last character ("(spec)" or " (body)").
      --  (this is a bit nasty, should have interface for this ???)

      Name_Len := Name_Len - 7;

      Start_String;
      Store_String_Chars (Name_Buffer (1 .. Name_Len));
      Prefix_String := End_String;

      --  Build the function call which will replace the attribute

      if Is_Remote_Call_Interface (Ety)
        or else Is_Shared_Passive (Ety)
      then
         Get_Pt_Id_Call :=
           Make_Function_Call (Loc,
             Name => Get_Pt_Id,
             Parameter_Associations =>
               New_List (Make_String_Literal (Loc, Prefix_String)));

      else
         Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);

      end if;

      --  Replace the attribute node by a conversion of the function call
      --  to the target type.

      Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
      Analyze_And_Resolve (N, Typ);
   end Process_Partition_Id;

   ----------------------------------
   -- Process_Remote_AST_Attribute --
   ----------------------------------

   procedure Process_Remote_AST_Attribute
     (N        : Node_Id;
      New_Type : Entity_Id)
   is
      Loc                   : constant Source_Ptr := Sloc (N);
      Remote_Subp           : Entity_Id;
      Tick_Access_Conv_Call : Node_Id;
      Remote_Subp_Decl      : Node_Id;
      RS_Pkg_Specif         : Node_Id;
      RS_Pkg_E              : Entity_Id;
      RAS_Type              : Entity_Id;
      Async_E               : Entity_Id;
      Subp_Id               : Int;
      Attribute_Subp        : Entity_Id;
      Parameter             : Node_Id;

   begin
      --  Check if we have to expand the access attribute

      Remote_Subp := Entity (Prefix (N));

      if not Expander_Active then
         return;

      elsif Ekind (New_Type) = E_Record_Type then
         RAS_Type := New_Type;

      else
         --  If the remote type has not been constructed yet, create
         --  it and its attributes now.

         Attribute_Subp := TSS (New_Type, TSS_RAS_Access);

         if No (Attribute_Subp) then
            Add_RAST_Features (Parent (New_Type));
         end if;

         RAS_Type := Equivalent_Type (New_Type);
      end if;

      Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
      Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);

      if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
         Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
         Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
      end if;

      RS_Pkg_Specif := Parent (Remote_Subp_Decl);
      RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);

      Subp_Id := Get_Subprogram_Id (Remote_Subp);

      if Ekind (Remote_Subp) = E_Procedure
        and then Is_Asynchronous (Remote_Subp)
      then
         Async_E := Standard_True;
      else
         Async_E := Standard_False;
      end if;

      Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);

      Tick_Access_Conv_Call :=
        Make_Function_Call (Loc,
          Name => New_Occurrence_Of (Attribute_Subp, Loc),
          Parameter_Associations =>
            New_List (
              Parameter,
              Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
              Make_Integer_Literal (Loc, Subp_Id),
              New_Occurrence_Of (Async_E, Loc)));

      Rewrite (N, Tick_Access_Conv_Call);
      Analyze_And_Resolve (N, RAS_Type);
   end Process_Remote_AST_Attribute;

   ------------------------------------
   -- Process_Remote_AST_Declaration --
   ------------------------------------

   procedure Process_Remote_AST_Declaration (N : Node_Id) is
      Loc           : constant Source_Ptr := Sloc (N);
      User_Type     : constant Node_Id := Defining_Identifier (N);
      Fat_Type      : constant Entity_Id :=
                        Make_Defining_Identifier
                          (Loc, Chars (User_Type));
      New_Type_Decl : Node_Id;

   begin
      --  We add a record type declaration for the equivalent fat pointer type

      New_Type_Decl :=
        Make_Full_Type_Declaration (Loc,
          Defining_Identifier => Fat_Type,
          Type_Definition =>
            Make_Record_Definition (Loc,
              Component_List =>
                Make_Component_List (Loc,
                  Component_Items => New_List (

                    Make_Component_Declaration (Loc,
                      Defining_Identifier =>
                        Make_Defining_Identifier (Loc,
                          Chars => Name_Ras),
                      Subtype_Indication =>
                        New_Occurrence_Of
                          (RTE (RE_Unsigned_64), Loc)),

                    Make_Component_Declaration (Loc,
                      Defining_Identifier =>
                        Make_Defining_Identifier (Loc,
                          Chars => Name_Origin),
                      Subtype_Indication =>
                        New_Reference_To
                          (Standard_Integer,
                           Loc)),

                    Make_Component_Declaration (Loc,
                      Defining_Identifier =>
                        Make_Defining_Identifier (Loc,
                          Chars => Name_Receiver),
                      Subtype_Indication =>
                        New_Reference_To
                          (RTE (RE_Unsigned_64), Loc)),

                    Make_Component_Declaration (Loc,
                      Defining_Identifier =>
                        Make_Defining_Identifier (Loc,
                          Chars => Name_Subp_Id),
                      Subtype_Indication =>
                        New_Reference_To
                          (Standard_Natural,
                           Loc)),

                    Make_Component_Declaration (Loc,
                      Defining_Identifier =>
                        Make_Defining_Identifier (Loc,
                          Chars => Name_Async),
                      Subtype_Indication =>
                        New_Reference_To
                          (Standard_Boolean,
                           Loc))))));

      Insert_After (N, New_Type_Decl);
      Set_Equivalent_Type (User_Type, Fat_Type);
      Set_Corresponding_Remote_Type (Fat_Type, User_Type);

      --  The reason we suppress the initialization procedure is that we know
      --  that no initialization is required (even if Initialize_Scalars mode
      --  is active), and there are order of elaboration problems if we do try
      --  to generate an init proc for this created record type.

      Set_Suppress_Init_Proc (Fat_Type);

      if Expander_Active then
         Add_RAST_Features (Parent (User_Type));
      end if;
   end Process_Remote_AST_Declaration;

   -----------------------
   -- RAS_E_Dereference --
   -----------------------

   procedure RAS_E_Dereference (Pref : Node_Id) is
      Loc             : constant Source_Ptr := Sloc (Pref);
      Call_Node       : Node_Id;
      New_Type        : constant Entity_Id := Etype (Pref);
      RAS             : constant Entity_Id :=
                          Corresponding_Remote_Type (New_Type);
      RAS_Decl        : constant Node_Id   := Parent (RAS);
      Explicit_Deref  : constant Node_Id   := Parent (Pref);
      Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
      Deref_Proc      : Entity_Id;
      Params          : List_Id;

   begin
      if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
         Params := Parameter_Associations (Deref_Subp_Call);

         if Present (Params) then
            Prepend (Pref, Params);
         else
            Params := New_List (Pref);
         end if;

      elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then

         Params := Expressions (Deref_Subp_Call);

         if Present (Params) then
            Prepend (Pref, Params);
         else
            Params := New_List (Pref);
         end if;

      else
         --  Context is not a call.

         return;
      end if;

      Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);

      if not Expander_Active then
         return;

      elsif No (Deref_Proc) then
         Add_RAST_Features (RAS_Decl);
         Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
      end if;

      if Ekind (Deref_Proc) = E_Function then
         Call_Node :=
           Make_Function_Call (Loc,
              Name => New_Occurrence_Of (Deref_Proc, Loc),
              Parameter_Associations => Params);

      else
         Call_Node :=
           Make_Procedure_Call_Statement (Loc,
              Name => New_Occurrence_Of (Deref_Proc, Loc),
              Parameter_Associations => Params);
      end if;

      Rewrite (Deref_Subp_Call, Call_Node);
      Analyze (Deref_Subp_Call);
   end RAS_E_Dereference;

   ------------------------------
   -- Remote_AST_E_Dereference --
   ------------------------------

   function Remote_AST_E_Dereference (P : Node_Id) return Boolean
   is
      ET : constant Entity_Id  := Etype (P);

   begin
      --  Perform the changes only on original dereferences, and only if
      --  we are generating code.

      if Comes_From_Source (P)
        and then Is_Record_Type (ET)
        and then (Is_Remote_Call_Interface (ET)
                   or else Is_Remote_Types (ET))
        and then Present (Corresponding_Remote_Type (ET))
        and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
                   or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
        and then Expander_Active
      then
         RAS_E_Dereference (P);
         return True;
      else
         return False;
      end if;
   end Remote_AST_E_Dereference;

   ------------------------------
   -- Remote_AST_I_Dereference --
   ------------------------------

   function Remote_AST_I_Dereference (P : Node_Id) return Boolean
   is
      ET     : constant Entity_Id  := Etype (P);
      Deref  : Node_Id;
   begin

      if Comes_From_Source (P)
        and then (Is_Remote_Call_Interface (ET)
                   or else Is_Remote_Types (ET))
        and then Present (Corresponding_Remote_Type (ET))
        and then Ekind (Entity (P)) /= E_Function
      then
         Deref :=
           Make_Explicit_Dereference (Sloc (P),
             Prefix => Relocate_Node (P));
         Rewrite (P, Deref);
         Set_Etype (P, ET);
         RAS_E_Dereference (Prefix (P));
         return True;
      end if;

      return False;
   end Remote_AST_I_Dereference;

   ---------------------------
   -- Remote_AST_Null_Value --
   ---------------------------

   function Remote_AST_Null_Value
     (N    : Node_Id;
      Typ  : Entity_Id)
      return Boolean
   is
      Loc         : constant Source_Ptr := Sloc (N);
      Target_Type : Entity_Id;

   begin
      if not Expander_Active then
         return False;

      elsif Ekind (Typ) = E_Access_Subprogram_Type
        and then (Is_Remote_Call_Interface (Typ)
                    or else Is_Remote_Types (Typ))
        and then Comes_From_Source (N)
        and then Expander_Active
      then
         --  Any null that comes from source and is of the RAS type must
         --  be expanded, except if expansion is not active (nothing
         --  gets expanded into the equivalent record type).

         Target_Type := Equivalent_Type (Typ);

      elsif Ekind (Typ) = E_Record_Type
        and then Present (Corresponding_Remote_Type (Typ))
      then
         --  This is a record type representing a RAS type, this must be
         --  expanded.

         Target_Type := Typ;

      else
         --  We do not have to handle this case

         return False;

      end if;

      Rewrite (N,
        Make_Aggregate (Loc,
          Expressions => New_List (
            Make_Integer_Literal (Loc, 0),                  -- Ras
            Make_Integer_Literal (Loc, 0),                  -- Origin
            Make_Integer_Literal (Loc, 0),                  -- Receiver
            Make_Integer_Literal (Loc, 0),                  -- Subp_Id
            New_Occurrence_Of (Standard_False, Loc))));     -- Asyn
      Analyze_And_Resolve (N, Target_Type);
      return True;
   end Remote_AST_Null_Value;

end Sem_Dist;
Commit	Line	Data
d6f39728	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT COMPILER COMPONENTS --
	4	-- --
	5	-- S E M _ D I S T --
	6	-- --
	7	-- B o d y --
	8	-- --
9dfe12ae	9	-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
d6f39728	10	-- --
	11	-- GNAT is free software; you can redistribute it and/or modify it under --
	12	-- terms of the GNU General Public License as published by the Free Soft- --
	13	-- ware Foundation; either version 2, or (at your option) any later ver- --
	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
	16	-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
	17	-- for more details. You should have received a copy of the GNU General --
	18	-- Public License distributed with GNAT; see file COPYING. If not, write --
	19	-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
	20	-- MA 02111-1307, USA. --
	21	-- --
	22	-- GNAT was originally developed by the GNAT team at New York University. --
e78e8c8e	23	-- Extensive contributions were provided by Ada Core Technologies Inc. --
d6f39728	24	-- --
	25	------------------------------------------------------------------------------
	26
	27	with Atree; use Atree;
	28	with Casing; use Casing;
	29	with Einfo; use Einfo;
	30	with Errout; use Errout;
	31	with Exp_Dist; use Exp_Dist;
	32	with Exp_Tss; use Exp_Tss;
	33	with Nlists; use Nlists;
	34	with Nmake; use Nmake;
	35	with Namet; use Namet;
	36	with Opt; use Opt;
	37	with Rtsfind; use Rtsfind;
	38	with Sem; use Sem;
	39	with Sem_Res; use Sem_Res;
	40	with Sem_Util; use Sem_Util;
	41	with Sinfo; use Sinfo;
	42	with Snames; use Snames;
	43	with Stand; use Stand;
	44	with Stringt; use Stringt;
	45	with Tbuild; use Tbuild;
	46	with Uname; use Uname;
	47
	48	package body Sem_Dist is
	49
	50	-----------------------
	51	-- Local Subprograms --
	52	-----------------------
	53
	54	procedure RAS_E_Dereference (Pref : Node_Id);
	55	-- Handles explicit dereference of Remote Access to Subprograms.
	56
	57	function Full_Qualified_Name (E : Entity_Id) return String_Id;
	58	-- returns the full qualified name of the entity in lower case.
	59
	60	-------------------------
	61	-- Add_Stub_Constructs --
	62	-------------------------
	63
	64	procedure Add_Stub_Constructs (N : Node_Id) is
	65	U : constant Node_Id := Unit (N);
	66	Spec : Entity_Id := Empty;
	67	Exp : Node_Id := U; -- Unit that will be expanded
	68
	69	begin
	70	pragma Assert (Distribution_Stub_Mode /= No_Stubs);
	71
	72	if Nkind (U) = N_Package_Declaration then
	73	Spec := Defining_Entity (Specification (U));
	74
	75	elsif Nkind (U) = N_Package_Body then
	76	Spec := Corresponding_Spec (U);
	77
	78	else pragma Assert (Nkind (U) = N_Package_Instantiation);
	79	Exp := Instance_Spec (U);
	80	Spec := Defining_Entity (Specification (Exp));
	81	end if;
	82
	83	pragma Assert (Is_Shared_Passive (Spec)
	84	or else Is_Remote_Call_Interface (Spec));
	85
	86	if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
	87
88	if Is_Shared_Passive (Spec) then
89	null;
90	elsif Nkind (U) = N_Package_Body then
91	Error_Msg_N
92	("Specification file expected from command line", U);
93	else
94	Expand_Calling_Stubs_Bodies (Exp);
95	end if;
96
97	else
98
99	if Is_Shared_Passive (Spec) then
100	Build_Passive_Partition_Stub (Exp);
101	else
102	Expand_Receiving_Stubs_Bodies (Exp);
103	end if;
104
105	end if;
106	end Add_Stub_Constructs;
107
108	-------------------------
109	-- Full_Qualified_Name --
110	-------------------------
111
112	function Full_Qualified_Name (E : Entity_Id) return String_Id is
113	Ent : Entity_Id := E;
114	Parent_Name : String_Id := No_String;
115
116	begin
117	-- Deals properly with child units
118
119	if Nkind (Ent) = N_Defining_Program_Unit_Name then
120	Ent := Defining_Identifier (Ent);
121	end if;
122
123	-- Compute recursively the qualification. Only "Standard" has no scope.
124
125	if Present (Scope (Scope (Ent))) then
126	Parent_Name := Full_Qualified_Name (Scope (Ent));
127	end if;
128
129	-- Every entity should have a name except some expanded blocks
130	-- don't bother about those.
131
132	if Chars (Ent) = No_Name then
133	return Parent_Name;
134	end if;
135
136	-- Add a period between Name and qualification
137
138	if Parent_Name /= No_String then
139	Start_String (Parent_Name);
140	Store_String_Char (Get_Char_Code ('.'));
141
142	else
143	Start_String;
144	end if;
145
146	-- Generates the entity name in upper case
147
148	Get_Name_String (Chars (Ent));
149	Set_Casing (All_Lower_Case);
150	Store_String_Chars (Name_Buffer (1 .. Name_Len));
151	return End_String;
152	end Full_Qualified_Name;
153
154	-----------------------
155	-- Get_Subprogram_Id --
156	-----------------------
157
158	function Get_Subprogram_Id (E : Entity_Id) return Int is
159	Current_Declaration : Node_Id;
160	Result : Int := 0;
161
162	begin
163	pragma Assert
164	(Is_Remote_Call_Interface (Scope (E))
165	and then
166	(Nkind (Parent (E)) = N_Procedure_Specification
167	or else
168	Nkind (Parent (E)) = N_Function_Specification));
169
170	Current_Declaration :=
171	First (Visible_Declarations
172	(Package_Specification_Of_Scope (Scope (E))));
173
174	while Current_Declaration /= Empty loop
175	if Nkind (Current_Declaration) = N_Subprogram_Declaration
176	and then Comes_From_Source (Current_Declaration)
177	then
178	if Defining_Unit_Name
179	(Specification (Current_Declaration)) = E
180	then
181	return Result;
182	end if;
183
184	Result := Result + 1;
185	end if;
186
187	Next (Current_Declaration);
188	end loop;
189
190	-- Error if we do not find it
191
192	raise Program_Error;
193	end Get_Subprogram_Id;
194
195	------------------------
196	-- Is_All_Remote_Call --
197	------------------------
198
199	function Is_All_Remote_Call (N : Node_Id) return Boolean is
200	Par : Node_Id;
201
202	begin
203	if (Nkind (N) = N_Function_Call
204	or else Nkind (N) = N_Procedure_Call_Statement)
205	and then Nkind (Name (N)) in N_Has_Entity
206	and then Is_Remote_Call_Interface (Entity (Name (N)))
207	and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
208	and then Comes_From_Source (N)
209	then
210	Par := Parent (Entity (Name (N)));
211
212	while Present (Par)
213	and then (Nkind (Par) /= N_Package_Specification
214	or else Is_Wrapper_Package (Defining_Entity (Par)))
215	loop
216	Par := Parent (Par);
217	end loop;
218
219	if Present (Par) then
220	return
221	not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
222	else
223	return False;
224	end if;
225	else
226	return False;
227	end if;
228	end Is_All_Remote_Call;
229
230	------------------------------------
231	-- Package_Specification_Of_Scope --
232	------------------------------------
233
234	function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
235	N : Node_Id := Parent (E);
236	begin
237	while Nkind (N) /= N_Package_Specification loop
238	N := Parent (N);
239	end loop;
240
241	return N;
242	end Package_Specification_Of_Scope;
243
244	--------------------------
245	-- Process_Partition_ID --
246	--------------------------
247
248	procedure Process_Partition_Id (N : Node_Id) is
249	Loc : constant Source_Ptr := Sloc (N);
250	Ety : Entity_Id;
d6f39728	251	Get_Pt_Id : Node_Id;
	252	Get_Pt_Id_Call : Node_Id;
	253	Prefix_String : String_Id;
	254	Typ : constant Entity_Id := Etype (N);
	255
	256	begin
	257	Ety := Entity (Prefix (N));
	258
	259	-- In case prefix is not a library unit entity, get the entity
	260	-- of library unit.
	261
	262	while (Present (Scope (Ety))
	263	and then Scope (Ety) /= Standard_Standard)
	264	and not Is_Child_Unit (Ety)
	265	loop
	266	Ety := Scope (Ety);
	267	end loop;
	268
d6f39728	269	-- Retrieve the proper function to call.
	270
	271	if Is_Remote_Call_Interface (Ety) then
	272	Get_Pt_Id := New_Occurrence_Of
	273	(RTE (RE_Get_Active_Partition_Id), Loc);
	274
	275	elsif Is_Shared_Passive (Ety) then
	276	Get_Pt_Id := New_Occurrence_Of
	277	(RTE (RE_Get_Passive_Partition_Id), Loc);
	278
	279	else
	280	Get_Pt_Id := New_Occurrence_Of
	281	(RTE (RE_Get_Local_Partition_Id), Loc);
	282	end if;
	283
	284	-- Get and store the String_Id corresponding to the name of the
	285	-- library unit whose Partition_Id is needed
	286
	287	Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));
	288
	289	-- Remove seven last character ("(spec)" or " (body)").
	290	-- (this is a bit nasty, should have interface for this ???)
	291
	292	Name_Len := Name_Len - 7;
	293
	294	Start_String;
	295	Store_String_Chars (Name_Buffer (1 .. Name_Len));
	296	Prefix_String := End_String;
	297
	298	-- Build the function call which will replace the attribute
	299
	300	if Is_Remote_Call_Interface (Ety)
	301	or else Is_Shared_Passive (Ety)
	302	then
	303	Get_Pt_Id_Call :=
	304	Make_Function_Call (Loc,
	305	Name => Get_Pt_Id,
	306	Parameter_Associations =>
	307	New_List (Make_String_Literal (Loc, Prefix_String)));
	308
	309	else
	310	Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
	311
	312	end if;
	313
	314	-- Replace the attribute node by a conversion of the function call
	315	-- to the target type.
	316
	317	Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
	318	Analyze_And_Resolve (N, Typ);
d6f39728	319	end Process_Partition_Id;
	320
	321	----------------------------------
	322	-- Process_Remote_AST_Attribute --
	323	----------------------------------
	324
	325	procedure Process_Remote_AST_Attribute
	326	(N : Node_Id;
	327	New_Type : Entity_Id)
	328	is
	329	Loc : constant Source_Ptr := Sloc (N);
	330	Remote_Subp : Entity_Id;
	331	Tick_Access_Conv_Call : Node_Id;
	332	Remote_Subp_Decl : Node_Id;
d6f39728	333	RS_Pkg_Specif : Node_Id;
d6f39728	334	RS_Pkg_E : Entity_Id;
d6f39728	335	RAS_Type : Entity_Id;
d6f39728	336	Async_E : Entity_Id;
	337	Subp_Id : Int;
	338	Attribute_Subp : Entity_Id;
	339	Parameter : Node_Id;
	340
	341	begin
	342	-- Check if we have to expand the access attribute
	343
	344	Remote_Subp := Entity (Prefix (N));
	345
	346	if not Expander_Active then
	347	return;
	348
	349	elsif Ekind (New_Type) = E_Record_Type then
	350	RAS_Type := New_Type;
	351
	352	else
	353	-- If the remote type has not been constructed yet, create
	354	-- it and its attributes now.
	355
9dfe12ae	356	Attribute_Subp := TSS (New_Type, TSS_RAS_Access);
d6f39728	357
	358	if No (Attribute_Subp) then
	359	Add_RAST_Features (Parent (New_Type));
	360	end if;
	361
	362	RAS_Type := Equivalent_Type (New_Type);
	363	end if;
	364
9dfe12ae	365	Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
d6f39728	366	Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
	367
	368	if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
	369	Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
	370	Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
	371	end if;
	372
	373	RS_Pkg_Specif := Parent (Remote_Subp_Decl);
	374	RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
	375
	376	Subp_Id := Get_Subprogram_Id (Remote_Subp);
	377
	378	if Ekind (Remote_Subp) = E_Procedure
	379	and then Is_Asynchronous (Remote_Subp)
	380	then
	381	Async_E := Standard_True;
	382	else
	383	Async_E := Standard_False;
	384	end if;
	385
d6f39728	386	Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
	387
	388	Tick_Access_Conv_Call :=
	389	Make_Function_Call (Loc,
	390	Name => New_Occurrence_Of (Attribute_Subp, Loc),
	391	Parameter_Associations =>
	392	New_List (
	393	Parameter,
	394	Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
	395	Make_Integer_Literal (Loc, Subp_Id),
	396	New_Occurrence_Of (Async_E, Loc)));
	397
	398	Rewrite (N, Tick_Access_Conv_Call);
	399	Analyze_And_Resolve (N, RAS_Type);
d6f39728	400	end Process_Remote_AST_Attribute;
	401
	402	------------------------------------
	403	-- Process_Remote_AST_Declaration --
	404	------------------------------------
	405
	406	procedure Process_Remote_AST_Declaration (N : Node_Id) is
	407	Loc : constant Source_Ptr := Sloc (N);
	408	User_Type : constant Node_Id := Defining_Identifier (N);
	409	Fat_Type : constant Entity_Id :=
	410	Make_Defining_Identifier
	411	(Loc, Chars (User_Type));
	412	New_Type_Decl : Node_Id;
	413
	414	begin
	415	-- We add a record type declaration for the equivalent fat pointer type
	416
	417	New_Type_Decl :=
	418	Make_Full_Type_Declaration (Loc,
	419	Defining_Identifier => Fat_Type,
	420	Type_Definition =>
	421	Make_Record_Definition (Loc,
	422	Component_List =>
	423	Make_Component_List (Loc,
	424	Component_Items => New_List (
	425
	426	Make_Component_Declaration (Loc,
	427	Defining_Identifier =>
	428	Make_Defining_Identifier (Loc,
	429	Chars => Name_Ras),
	430	Subtype_Indication =>
	431	New_Occurrence_Of
	432	(RTE (RE_Unsigned_64), Loc)),
	433
	434	Make_Component_Declaration (Loc,
	435	Defining_Identifier =>
	436	Make_Defining_Identifier (Loc,
	437	Chars => Name_Origin),
	438	Subtype_Indication =>
	439	New_Reference_To
	440	(Standard_Integer,
	441	Loc)),
	442
	443	Make_Component_Declaration (Loc,
	444	Defining_Identifier =>
	445	Make_Defining_Identifier (Loc,
	446	Chars => Name_Receiver),
	447	Subtype_Indication =>
	448	New_Reference_To
	449	(RTE (RE_Unsigned_64), Loc)),
	450
	451	Make_Component_Declaration (Loc,
	452	Defining_Identifier =>
	453	Make_Defining_Identifier (Loc,
	454	Chars => Name_Subp_Id),
	455	Subtype_Indication =>
	456	New_Reference_To
	457	(Standard_Natural,
	458	Loc)),
	459
	460	Make_Component_Declaration (Loc,
	461	Defining_Identifier =>
	462	Make_Defining_Identifier (Loc,
	463	Chars => Name_Async),
464	Subtype_Indication =>
465	New_Reference_To
466	(Standard_Boolean,
467	Loc))))));
468
469	Insert_After (N, New_Type_Decl);
470	Set_Equivalent_Type (User_Type, Fat_Type);
471	Set_Corresponding_Remote_Type (Fat_Type, User_Type);
472
473	-- The reason we suppress the initialization procedure is that we know
474	-- that no initialization is required (even if Initialize_Scalars mode
475	-- is active), and there are order of elaboration problems if we do try
9dfe12ae	476	-- to generate an init proc for this created record type.
d6f39728	477
	478	Set_Suppress_Init_Proc (Fat_Type);
	479
	480	if Expander_Active then
	481	Add_RAST_Features (Parent (User_Type));
	482	end if;
d6f39728	483	end Process_Remote_AST_Declaration;
	484
	485	-----------------------
	486	-- RAS_E_Dereference --
	487	-----------------------
	488
	489	procedure RAS_E_Dereference (Pref : Node_Id) is
	490	Loc : constant Source_Ptr := Sloc (Pref);
	491	Call_Node : Node_Id;
	492	New_Type : constant Entity_Id := Etype (Pref);
	493	RAS : constant Entity_Id :=
	494	Corresponding_Remote_Type (New_Type);
	495	RAS_Decl : constant Node_Id := Parent (RAS);
	496	Explicit_Deref : constant Node_Id := Parent (Pref);
	497	Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
	498	Deref_Proc : Entity_Id;
	499	Params : List_Id;
	500
	501	begin
	502	if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
	503	Params := Parameter_Associations (Deref_Subp_Call);
	504
	505	if Present (Params) then
	506	Prepend (Pref, Params);
	507	else
	508	Params := New_List (Pref);
	509	end if;
	510
	511	elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
	512
	513	Params := Expressions (Deref_Subp_Call);
	514
	515	if Present (Params) then
	516	Prepend (Pref, Params);
	517	else
	518	Params := New_List (Pref);
	519	end if;
	520
	521	else
	522	-- Context is not a call.
	523
	524	return;
	525	end if;
	526
9dfe12ae	527	Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
d6f39728	528
	529	if not Expander_Active then
	530	return;
	531
	532	elsif No (Deref_Proc) then
	533	Add_RAST_Features (RAS_Decl);
9dfe12ae	534	Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
d6f39728	535	end if;
	536
	537	if Ekind (Deref_Proc) = E_Function then
	538	Call_Node :=
	539	Make_Function_Call (Loc,
	540	Name => New_Occurrence_Of (Deref_Proc, Loc),
	541	Parameter_Associations => Params);
	542
	543	else
	544	Call_Node :=
	545	Make_Procedure_Call_Statement (Loc,
	546	Name => New_Occurrence_Of (Deref_Proc, Loc),
	547	Parameter_Associations => Params);
	548	end if;
	549
	550	Rewrite (Deref_Subp_Call, Call_Node);
	551	Analyze (Deref_Subp_Call);
	552	end RAS_E_Dereference;
	553
	554	------------------------------
	555	-- Remote_AST_E_Dereference --
	556	------------------------------
	557
	558	function Remote_AST_E_Dereference (P : Node_Id) return Boolean
	559	is
	560	ET : constant Entity_Id := Etype (P);
	561
	562	begin
	563	-- Perform the changes only on original dereferences, and only if
	564	-- we are generating code.
	565
	566	if Comes_From_Source (P)
	567	and then Is_Record_Type (ET)
	568	and then (Is_Remote_Call_Interface (ET)
	569	or else Is_Remote_Types (ET))
	570	and then Present (Corresponding_Remote_Type (ET))
	571	and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
	572	or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
	573	and then Expander_Active
	574	then
	575	RAS_E_Dereference (P);
	576	return True;
	577	else
	578	return False;
	579	end if;
	580	end Remote_AST_E_Dereference;
	581
	582	------------------------------
	583	-- Remote_AST_I_Dereference --
	584	------------------------------
	585
	586	function Remote_AST_I_Dereference (P : Node_Id) return Boolean
	587	is
	588	ET : constant Entity_Id := Etype (P);
	589	Deref : Node_Id;
	590	begin
	591
	592	if Comes_From_Source (P)
	593	and then (Is_Remote_Call_Interface (ET)
	594	or else Is_Remote_Types (ET))
	595	and then Present (Corresponding_Remote_Type (ET))
	596	and then Ekind (Entity (P)) /= E_Function
	597	then
	598	Deref :=
599	Make_Explicit_Dereference (Sloc (P),
600	Prefix => Relocate_Node (P));
601	Rewrite (P, Deref);
602	Set_Etype (P, ET);
603	RAS_E_Dereference (Prefix (P));
604	return True;
605	end if;
606
607	return False;
608	end Remote_AST_I_Dereference;
609
610	---------------------------
611	-- Remote_AST_Null_Value --
612	---------------------------
613
614	function Remote_AST_Null_Value
615	(N : Node_Id;
616	Typ : Entity_Id)
617	return Boolean
618	is
619	Loc : constant Source_Ptr := Sloc (N);
620	Target_Type : Entity_Id;
621
622	begin
623	if not Expander_Active then
624	return False;
625
626	elsif Ekind (Typ) = E_Access_Subprogram_Type
627	and then (Is_Remote_Call_Interface (Typ)
628	or else Is_Remote_Types (Typ))
629	and then Comes_From_Source (N)
630	and then Expander_Active
631	then
632	-- Any null that comes from source and is of the RAS type must
633	-- be expanded, except if expansion is not active (nothing
634	-- gets expanded into the equivalent record type).
635
636	Target_Type := Equivalent_Type (Typ);
637
638	elsif Ekind (Typ) = E_Record_Type
639	and then Present (Corresponding_Remote_Type (Typ))
640	then
d6f39728	641	-- This is a record type representing a RAS type, this must be
	642	-- expanded.
	643
	644	Target_Type := Typ;
	645
	646	else
	647	-- We do not have to handle this case
	648
	649	return False;
	650
	651	end if;
	652
	653	Rewrite (N,
	654	Make_Aggregate (Loc,
	655	Expressions => New_List (
	656	Make_Integer_Literal (Loc, 0), -- Ras
	657	Make_Integer_Literal (Loc, 0), -- Origin
	658	Make_Integer_Literal (Loc, 0), -- Receiver
	659	Make_Integer_Literal (Loc, 0), -- Subp_Id
	660	New_Occurrence_Of (Standard_False, Loc)))); -- Asyn
	661	Analyze_And_Resolve (N, Target_Type);
	662	return True;
	663	end Remote_AST_Null_Value;
	664
	665	end Sem_Dist;