-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
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;
+with Uintp; use Uintp;
package body Sem_Dist is
-----------------------
procedure RAS_E_Dereference (Pref : Node_Id);
- -- Handles explicit dereference of Remote Access to Subprograms.
+ -- 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.
+ -- 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
+
+ Exp : Node_Id := U;
+ -- Unit that will be expanded
begin
pragma Assert (Distribution_Stub_Mode /= No_Stubs);
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
end if;
else
-
if Is_Shared_Passive (Spec) then
Build_Passive_Partition_Stub (Exp);
else
end if;
end Add_Stub_Constructs;
+ ---------------------------------------
+ -- Build_RAS_Primitive_Specification --
+ ---------------------------------------
+
+ function Build_RAS_Primitive_Specification
+ (Subp_Spec : Node_Id;
+ Remote_Object_Type : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Spec);
+
+ Primitive_Spec : constant Node_Id :=
+ Copy_Specification (Loc,
+ Spec => Subp_Spec,
+ New_Name => Name_uCall);
+
+ Subtype_Mark_For_Self : Node_Id;
+
+ begin
+ if No (Parameter_Specifications (Primitive_Spec)) then
+ Set_Parameter_Specifications (Primitive_Spec, New_List);
+ end if;
+
+ if Nkind (Remote_Object_Type) in N_Entity then
+ Subtype_Mark_For_Self :=
+ New_Occurrence_Of (Remote_Object_Type, Loc);
+ else
+ Subtype_Mark_For_Self := Remote_Object_Type;
+ end if;
+
+ Prepend_To (
+ Parameter_Specifications (Primitive_Spec),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ Subtype_Mark_For_Self)));
+
+ -- Trick later semantic analysis into considering this operation as a
+ -- primitive (dispatching) operation of tagged type Obj_Type.
+
+ Set_Comes_From_Source (
+ Defining_Unit_Name (Primitive_Spec), True);
+
+ return Primitive_Spec;
+ end Build_RAS_Primitive_Specification;
+
-------------------------
-- Full_Qualified_Name --
-------------------------
Ent := Defining_Identifier (Ent);
end if;
- -- Compute recursively the qualification. Only "Standard" has no scope.
+ -- 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.
+ -- Every entity should have a name except some expanded blocks. Do not
+ -- bother about those.
if Chars (Ent) = No_Name then
return Parent_Name;
if Parent_Name /= No_String then
Start_String (Parent_Name);
Store_String_Char (Get_Char_Code ('.'));
-
else
Start_String;
end if;
return End_String;
end Full_Qualified_Name;
+ ------------------
+ -- Get_PCS_Name --
+ ------------------
+
+ function Get_PCS_Name return PCS_Names is
+ begin
+ return
+ Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation)))));
+ end Get_PCS_Name;
+
+ ---------------------
+ -- Get_PCS_Version --
+ ---------------------
+
+ function Get_PCS_Version return Int is
+ PCS_Version_Entity : Entity_Id;
+ PCS_Version : Int;
+
+ begin
+ if RTE_Available (RE_PCS_Version) then
+ PCS_Version_Entity := RTE (RE_PCS_Version);
+ pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer);
+ PCS_Version :=
+ UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity)));
+
+ else
+ -- Case of System.Partition_Interface.PCS_Version not found:
+ -- return a null version.
+
+ PCS_Version := 0;
+ end if;
+
+ return PCS_Version;
+ end Get_PCS_Version;
+
------------------------
-- Is_All_Remote_Call --
------------------------
Par : Node_Id;
begin
- if (Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement)
+ if Nkind_In (N, N_Function_Call, 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)))
end if;
end Is_All_Remote_Call;
+ ---------------------------------
+ -- Is_RACW_Stub_Type_Operation --
+ ---------------------------------
+
+ function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
+ Dispatching_Type : Entity_Id;
+
+ begin
+ case Ekind (Op) is
+ when E_Function | E_Procedure =>
+ Dispatching_Type := Find_Dispatching_Type (Op);
+ return Present (Dispatching_Type)
+ and then Is_RACW_Stub_Type (Dispatching_Type)
+ and then not Is_Internal (Op);
+
+ when others =>
+ return False;
+ end case;
+ end Is_RACW_Stub_Type_Operation;
+
------------------------------------
-- Package_Specification_Of_Scope --
------------------------------------
function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
- N : Node_Id := Parent (E);
+ N : Node_Id;
+
begin
+ N := Parent (E);
while Nkind (N) /= N_Package_Specification loop
N := Parent (N);
end loop;
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.
+ Ety := Entity (Prefix (N));
while (Present (Scope (Ety))
and then Scope (Ety) /= Standard_Standard)
and not Is_Child_Unit (Ety)
Ety := Scope (Ety);
end loop;
- -- Retrieve the proper function to call.
+ -- Retrieve the proper function to call
if Is_Remote_Call_Interface (Ety) then
Get_Pt_Id := New_Occurrence_Of
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;
+ -- library unit whose Partition_Id is needed.
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Prefix_String := End_String;
+ Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
+ Prefix_String := String_From_Name_Buffer;
-- Build the function call which will replace the attribute
- if Is_Remote_Call_Interface (Ety)
- or else Is_Shared_Passive (Ety)
- then
+ 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,
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
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
- Local_Addr : Node_Id;
begin
-- Check if we have to expand the access attribute
Remote_Subp := Entity (Prefix (N));
- if not Expander_Active then
+ if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return;
end if;
All_Calls_Remote_E :=
Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
- Local_Addr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Remote_Subp, Loc),
- Attribute_Name => Name_Address);
-
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Attribute_Subp, Loc),
+ Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
- Local_Addr,
- Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
+ Make_String_Literal (Loc,
+ Strval => Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
New_Occurrence_Of (All_Calls_Remote_E, Loc)));
------------------------------------
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;
+ Loc : constant Source_Ptr := Sloc (N);
+ User_Type : constant Node_Id := Defining_Identifier (N);
+ Scop : constant Entity_Id := Scope (User_Type);
+ Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop);
+ Is_RT : constant Boolean := Is_Remote_Types (Scop);
+ Type_Def : constant Node_Id := Type_Definition (N);
+ Parameter : Node_Id;
+
+ Is_Degenerate : Boolean;
+ -- True iff this RAS has an access formal parameter (see
+ -- Exp_Dist.Add_RAS_Dereference_TSS for details).
+
+ Subpkg : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S'));
+ Subpkg_Decl : Node_Id;
+ Subpkg_Body : Node_Id;
+ Vis_Decls : constant List_Id := New_List;
+ Priv_Decls : constant List_Id := New_List;
+
+ Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (User_Type), 'R'));
+
+ Full_Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars (Obj_Type));
+
+ RACW_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (User_Type), 'P'));
+
+ Fat_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars (User_Type));
+
+ Fat_Type_Decl : Node_Id;
begin
- -- We add a record type declaration for the equivalent fat pointer type
+ Is_Degenerate := False;
+ Parameter := First (Parameter_Specifications (Type_Def));
+ while Present (Parameter) loop
+ if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
+ Error_Msg_N ("formal parameter& has anonymous access type?",
+ Defining_Identifier (Parameter));
+ Is_Degenerate := True;
+ exit;
+ end if;
+
+ Next (Parameter);
+ end loop;
+
+ if Is_Degenerate then
+ Error_Msg_NE
+ ("remote access-to-subprogram type& can only be null?",
+ Defining_Identifier (Parameter), User_Type);
+
+ -- The only legal value for a RAS with a formal parameter of an
+ -- anonymous access type is null, because it cannot be subtype-
+ -- conformant with any legal remote subprogram declaration. In this
+ -- case, we cannot generate a corresponding primitive operation.
+
+ end if;
- New_Type_Decl :=
+ if Get_PCS_Name = Name_No_DSA then
+ return;
+ end if;
+
+ -- The tagged private type, primitive operation and RACW type associated
+ -- with a RAS need to all be declared in a subpackage of the one that
+ -- contains the RAS declaration, because the primitive of the object
+ -- type, and the associated primitive of the stub type, need to be
+ -- dispatching operations of these types, and the profile of the RAS
+ -- might contain tagged types declared in the same scope.
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Obj_Type,
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True));
+
+ Append_To (Priv_Decls,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Fat_Type,
- Type_Definition =>
+ Defining_Identifier => Full_Obj_Type,
+ Type_Definition =>
Make_Record_Definition (Loc,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Null_Present => True,
+ Component_List => Empty)));
+
+ -- Trick semantic analysis into swapping the public and full view when
+ -- freezing the public view.
+
+ Set_Comes_From_Source (Full_Obj_Type, True);
+
+ if not Is_Degenerate then
+ Append_To (Vis_Decls,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification => Build_RAS_Primitive_Specification (
+ Subp_Spec => Type_Def,
+ Remote_Object_Type => Obj_Type)));
+ end if;
+
+ Append_To (Vis_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => RACW_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Type, Loc),
+ Attribute_Name => Name_Class))));
+
+ Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
+ Set_Is_Remote_Types (RACW_Type, Is_RT);
+
+ Subpkg_Decl :=
+ Make_Package_Declaration (Loc,
+ Make_Package_Specification (Loc,
+ Defining_Unit_Name => Subpkg,
+ Visible_Declarations => Vis_Decls,
+ Private_Declarations => Priv_Decls,
+ End_Label => New_Occurrence_Of (Subpkg, Loc)));
+
+ Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
+ Set_Is_Remote_Types (Subpkg, Is_RT);
+ Insert_After_And_Analyze (N, Subpkg_Decl);
+
+ -- Generate package body to receive RACW calling stubs
+
+ -- Note: Analyze_Declarations has an absolute requirement that the
+ -- declaration list be non-empty, so provide dummy null statement here.
+
+ Subpkg_Body :=
+ Make_Package_Body (Loc,
+ Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
+ Declarations => New_List (Make_Null_Statement (Loc)));
+ Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
+
+ -- Many parts of the analyzer and expander expect
+ -- that the fat pointer type used to implement remote
+ -- access to subprogram types be a record.
+ -- Note: The structure of this type must be kept consistent
+ -- with the code generated by Remote_AST_Null_Value for the
+ -- corresponding 'null' expression.
+
+ Fat_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, Name_Ras),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RACW_Type, Loc)))))));
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Ras),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Integer, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Receiver),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Subp_Id),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Natural, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Async),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- 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);
+ Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
-- The reason we suppress the initialization procedure is that we know
-- that no initialization is required (even if Initialize_Scalars mode
end if;
elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
-
Params := Expressions (Deref_Subp_Call);
if Present (Params) then
end if;
else
- -- Context is not a call.
+ -- Context is not a call
return;
end if;
- if not Expander_Active then
+ if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return;
end if;
if Ekind (Deref_Proc) = E_Function then
Call_Node :=
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Deref_Proc, 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),
+ Name => New_Occurrence_Of (Deref_Proc, Loc),
Parameter_Associations => Params);
end if;
-- Remote_AST_E_Dereference --
------------------------------
- function Remote_AST_E_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
begin
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 Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
+ N_Indexed_Component)
and then Expander_Active
then
RAS_E_Dereference (P);
-- Remote_AST_I_Dereference --
------------------------------
- function Remote_AST_I_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
Deref : Node_Id;
- begin
+ begin
if Comes_From_Source (P)
and then (Is_Remote_Call_Interface (ET)
or else Is_Remote_Types (ET))
---------------------------
function Remote_AST_Null_Value
- (N : Node_Id;
- Typ : Entity_Id)
- return Boolean
+ (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
+ if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return False;
elsif Ekind (Typ) = E_Access_Subprogram_Type
-- 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
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Identifier (Loc, Name_Ras)),
+ Expression => Make_Null (Loc)))));
Analyze_And_Resolve (N, Target_Type);
return True;
end Remote_AST_Null_Value;
OSDN Git Service
