This change causes the compiler to copy components from runtime record type
System.Partition_Interface.RACW_Stub_Type instead of hard-coding the
component list in Build_Stub_Type. This allows the structure of that type
to be changed in the PCS without having to change the compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-09-19 Thomas Quinot <qui...@adacore.com>
* exp_dist.adb, rtsfind.ads, sem_util.adb, sem_util.ads
(Build_Stub_Type): Remove, instead copy components from
System.Partition_Interface.RACW_Stub_Type.
(RPC_Receiver_Decl): Remainder of code from old Build_Stub_Type routine.
(Copy_Component_List): New subprogram.
Index: exp_dist.adb
===================================================================
--- exp_dist.adb (revision 178955)
+++ exp_dist.adb (working copy)
@@ -328,8 +328,8 @@
RPC_Receiver_Decl : Node_Id;
-- Declaration for the RPC receiver entity associated with the
- -- designated type. As an exception, for the case of an RACW that
- -- implements a RAS, no object RPC receiver is generated. Instead,
+ -- designated type. As an exception, in the case of GARLIC, for an RACW
+ -- that implements a RAS, no object RPC receiver is generated. Instead,
-- RPC_Receiver_Decl is the declaration after which the RPC receiver
-- would have been inserted.
@@ -559,14 +559,9 @@
-- call. Decls provides a location where variable declarations can be
-- appended to construct the necessary values.
- procedure Specific_Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id);
- -- Build a components list for the stub type associated with an RACW type,
- -- and build the necessary RPC receiver, if applicable. PCS-specific
- -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
- -- is generated, then RPC_Receiver_Decl is set to Empty.
+ function Specific_RPC_Receiver_Decl
+ (RACW_Type : Entity_Id) return Node_Id;
+ -- Build the RPC receiver, for RACW, if applicable, else return Empty
procedure Specific_Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
@@ -656,10 +651,7 @@
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
- procedure Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id);
+ function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
@@ -733,10 +725,7 @@
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
- procedure Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id);
+ function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
@@ -1976,7 +1965,6 @@
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
- Stub_Type_Comps : List_Id;
Stub_Type_Decl : Node_Id;
Stub_Type_Access_Decl : Node_Id;
@@ -1999,8 +1987,10 @@
Chars => New_External_Name
(Related_Id => Chars (Stub_Type), Suffix => 'A'));
- Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+ RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
+ -- Create new stub type, copying components from generic RACW_Stub_Type
+
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
@@ -2010,7 +2000,8 @@
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
- Component_Items => Stub_Type_Comps)));
+ Component_Items =>
+ Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
-- Does the stub type need to explicitly implement interfaces from the
-- designated type???
@@ -2041,7 +2032,10 @@
if Present (RPC_Receiver_Decl) then
Append_To (Decls, RPC_Receiver_Decl);
+
else
+ -- Kludge, requires comment???
+
RPC_Receiver_Decl := Last (Decls);
end if;
@@ -2399,7 +2393,6 @@
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
-
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -3874,7 +3867,7 @@
-- Compute distribution identifier
Assign_Subprogram_Identifier
- (Subp_Def, Current_Subp_Number, Subp_Val);
+ (Subp_Def, Current_Subp_Number, Subp_Val);
pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
@@ -4711,72 +4704,6 @@
return Target_Info;
end Build_Stub_Target;
- ---------------------
- -- Build_Stub_Type --
- ---------------------
-
- procedure Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
- Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
-
- begin
- Stub_Type_Comps := New_List (
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Receiver),
- 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, Name_Addr),
- 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, Name_Asynchronous),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (Standard_Boolean, Loc))));
-
- if Is_RAS then
- RPC_Receiver_Decl := Empty;
- else
- declare
- RPC_Receiver_Request : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_R);
- begin
- RPC_Receiver_Decl :=
- Make_Subprogram_Declaration (Loc,
- Build_RPC_Receiver_Specification
- (RPC_Receiver => Make_Temporary (Loc, 'R'),
- Request_Parameter => RPC_Receiver_Request));
- end;
- end if;
- end Build_Stub_Type;
-
--------------------------------------
-- Build_Subprogram_Receiving_Stubs --
--------------------------------------
@@ -5253,6 +5180,28 @@
return Make_Identifier (Loc, Name_V);
end Result;
+ -----------------------
+ -- RPC_Receiver_Decl --
+ -----------------------
+
+ function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
+
+ begin
+ -- No RPC receiver for remote access-to-subprogram
+
+ if Is_RAS then
+ return Empty;
+ end if;
+
+ return
+ Make_Subprogram_Declaration (Loc,
+ Build_RPC_Receiver_Specification
+ (RPC_Receiver => Make_Temporary (Loc, 'R'),
+ Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
+ end RPC_Receiver_Decl;
+
----------------------
-- Stream_Parameter --
----------------------
@@ -7659,46 +7608,6 @@
return Target_Info;
end Build_Stub_Target;
- ---------------------
- -- Build_Stub_Type --
- ---------------------
-
- procedure Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
-
- begin
- Stub_Type_Comps := New_List (
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Target),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Asynchronous),
-
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (Standard_Boolean, Loc))));
-
- RPC_Receiver_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'R'),
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Servant), Loc));
- end Build_Stub_Type;
-
-----------------------------
-- Build_RPC_Receiver_Body --
-----------------------------
@@ -11160,6 +11069,21 @@
Overload_Counter_Table.Set (Name_Find, 1);
end Reserve_NamingContext_Methods;
+ -----------------------
+ -- RPC_Receiver_Decl --
+ -----------------------
+
+ function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
+
+ begin
+ return
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'R'),
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
+ end RPC_Receiver_Decl;
+
end PolyORB_Support;
-------------------------------
@@ -11514,26 +11438,22 @@
end case;
end Specific_Build_Stub_Target;
- ------------------------------
- -- Specific_Build_Stub_Type --
- ------------------------------
+ --------------------------------
+ -- Specific_RPC_Receiver_Decl --
+ --------------------------------
- procedure Specific_Build_Stub_Type
- (RACW_Type : Entity_Id;
- Stub_Type_Comps : out List_Id;
- RPC_Receiver_Decl : out Node_Id)
+ function Specific_RPC_Receiver_Decl
+ (RACW_Type : Entity_Id) return Node_Id
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- PolyORB_Support.Build_Stub_Type
- (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+ return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
when others =>
- GARLIC_Support.Build_Stub_Type
- (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+ return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
end case;
- end Specific_Build_Stub_Type;
+ end Specific_RPC_Receiver_Decl;
-----------------------------------------------
-- Specific_Build_Subprogram_Receiving_Stubs --
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 178955)
+++ rtsfind.ads (working copy)
@@ -1163,6 +1163,7 @@
RE_Get_RACW, -- System.Partition_Interface
RE_Get_RCI_Package_Receiver, -- System.Partition_Interface
RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface
+ RE_RACW_Stub_Type, -- System.Partition_Interface
RE_RACW_Stub_Type_Access, -- System.Partition_Interface
RE_RAS_Proxy_Type_Access, -- System.Partition_Interface
RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
@@ -2357,6 +2358,7 @@
RE_Get_RACW => System_Partition_Interface,
RE_Get_RCI_Package_Receiver => System_Partition_Interface,
RE_Get_Unique_Remote_Pointer => System_Partition_Interface,
+ RE_RACW_Stub_Type => System_Partition_Interface,
RE_RACW_Stub_Type_Access => System_Partition_Interface,
RE_RAS_Proxy_Type_Access => System_Partition_Interface,
RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface,
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 178955)
+++ sem_util.adb (working copy)
@@ -2265,6 +2265,39 @@
end Conditional_Delay;
-------------------------
+ -- Copy_Component_List --
+ -------------------------
+
+ function Copy_Component_List
+ (R_Typ : Entity_Id;
+ Loc : Source_Ptr) return List_Id
+ is
+ Comp : Node_Id;
+ Comps : constant List_Id := New_List;
+ begin
+ Comp := First_Component (Underlying_Type (R_Typ));
+
+ while Present (Comp) loop
+ if Comes_From_Source (Comp) then
+ declare
+ Comp_Decl : constant Node_Id := Declaration_Node (Comp);
+ begin
+ Append_To (Comps,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Comp)),
+ Component_Definition =>
+ New_Copy_Tree
+ (Component_Definition (Comp_Decl), New_Sloc => Loc)));
+ end;
+ end if;
+ Next_Component (Comp);
+ end loop;
+
+ return Comps;
+ end Copy_Component_List;
+
+ -------------------------
-- Copy_Parameter_List --
-------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 178955)
+++ sem_util.ads (working copy)
@@ -272,6 +272,13 @@
-- of inlining, and for private protected ops. Also used to create bodies
-- for stubbed subprograms.
+ function Copy_Component_List
+ (R_Typ : Entity_Id;
+ Loc : Source_Ptr) return List_Id;
+ -- Copy components from record type R_Typ that come from source. Used to
+ -- create a new compatible record type. Loc is the source location assigned
+ -- to the created nodes.
+
function Current_Entity (N : Node_Id) return Entity_Id;
pragma Inline (Current_Entity);
-- Find the currently visible definition for a given identifier, that is to
