Ada: adaptations for polyorb
Arnaud Charlet
charlet@ACT-Europe.FR
Wed Oct 27 09:56:00 GMT 2004
Tested on x86-linux
Part of adaptation of GNAT for PolyORB:
2004-10-26 Thomas Quinot <quinot@act-europe.fr>
* exp_dist.adb (Build_General_Calling_Stubs): New formal parameter
RACW_Type, used in the PolyORB version.
Rename RCI_Info to RCI_Locator, for consistency between the PolyORB
version and the GARLIC version.
* snames.ads, snames.adb, s-parint.ads, s-parint.adb:
Rename RCI_Info to RCI_Locator for better consistency between the
GARLIC and PolyORB versions of the distributed systems annex.
(DSA_Implementation_Name): This enumeration lists the possible
implementations of the Partition Communication Subsystem for the
Distributed Systems Annex (DSA). The three available implementations
are the dummy stub implementation (No_DSA), and two versions based on
two different distribution runtime libraries: GARLIC and PolyORB. Both
the GARLIC PCS and the PolyORB PCS are part of the GLADE distribution
technology.
Change the literal GLADE_DSA to GARLIC_DSA to accurately describe
that organization.
* rtsfind.ads: Rename RCI_Info to RCI_Locator for better consistency
between the GARLIC and PolyORB versions of the distributed systems
annex.
Remove RE_Unbounded_Reclaim_Pool since it is unused.
-------------- next part --------------
Index: exp_dist.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_dist.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_dist.adb
--- exp_dist.adb 4 Oct 2004 14:50:08 -0000 1.15
+++ exp_dist.adb 27 Oct 2004 09:32:59 -0000
@@ -132,6 +132,7 @@ package body Exp_Dist is
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
-- Build calling stubs for general purpose. The parameters are:
-- Decls : a place to put declarations
@@ -159,6 +160,7 @@ package body Exp_Dist is
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
New_Name : Name_Id := No_Name) return Node_Id;
-- Build the calling stub for a given subprogram with the subprogram ID
@@ -220,10 +222,9 @@ package body Exp_Dist is
-- Return True if nothing prevents the program whose specification is
-- given to be asynchronous (i.e. no out parameter).
- function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id;
- function Get_String_Id (Val : String) return String_Id;
- -- Ugly functions used to retrieve a package name. Inherited from the
- -- old exp_dist.adb and not rewritten yet ???
+ procedure Get_Pkg_Name_String (Decl_Node : Node_Id);
+ -- Retrieve the fully expanded name of the library unit declared by decl
+ -- into the name buffer.
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
@@ -308,7 +309,7 @@ package body Exp_Dist is
Hash => Hash,
Equal => "=");
-- Mapping between a RCI package on which All_Calls_Remote applies and
- -- the generic instantiation of RCI_Info for this package.
+ -- the generic instantiation of RCI_Locator for this package.
package RCI_Calling_Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
@@ -369,7 +370,7 @@ package body Exp_Dist is
function RCI_Package_Locator
(Loc : Source_Ptr;
Package_Spec : Node_Id) return Node_Id;
- -- Instantiate the generic package RCI_Info in order to locate the
+ -- Instantiate the generic package RCI_Locator in order to locate the
-- RCI package whose spec is given as argument.
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
@@ -429,7 +430,7 @@ package body Exp_Dist is
begin
-- The first thing added is an instantiation of the generic package
- -- System.Partition_interface.RCI_Info with the name of the (current)
+ -- System.Partition_interface.RCI_Locator with the name of this
-- remote package. This will act as an interface with the name server
-- to determine the Partition_ID and the RPC_Receiver for the
-- receiver of this package.
@@ -1935,6 +1936,8 @@ package body Exp_Dist is
Subp_Info_List : constant List_Id := New_List;
+ Register_Pkg_Actuals : constant List_Id := New_List;
+
Dummy_Register_Name : Name_Id;
Dummy_Register_Spec : Node_Id;
Dummy_Register_Decl : Node_Id;
@@ -2277,10 +2280,47 @@ package body Exp_Dist is
Make_Package_Declaration (Loc,
Specification => Dummy_Register_Spec);
- Append_To (Decls,
- Dummy_Register_Decl);
+ Append_To (Decls, Dummy_Register_Decl);
Analyze (Dummy_Register_Decl);
+ Get_Pkg_Name_String (Pkg_Spec);
+ Append_To (Register_Pkg_Actuals,
+ -- Name
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Receiver
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
+ Attribute_Name =>
+ Name_Unrestricted_Access));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Version
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
+ Attribute_Name =>
+ Name_Version));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info_Len
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Length));
+
Dummy_Register_Body :=
Make_Package_Body (Loc,
Defining_Unit_Name =>
@@ -2294,29 +2334,7 @@ package body Exp_Dist is
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc,
- Strval => Get_Pkg_Name_String_Id (Pkg_Spec)),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
- Attribute_Name =>
- Name_Unrestricted_Access),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Address),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Length))))));
+ Parameter_Associations => Register_Pkg_Actuals))));
Append_To (Decls, Dummy_Register_Body);
Analyze (Dummy_Register_Body);
@@ -2473,6 +2491,7 @@ package body Exp_Dist is
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
@@ -2502,6 +2521,9 @@ package body Exp_Dist is
-- List of statements for extra formal parameters. It will appear after
-- the regular statements for writing out parameters.
+ pragma Warnings (Off, RACW_Type);
+ -- Unreferenced formal parameter.
+
begin
-- The general form of a calling stub for a given subprogram is:
@@ -3038,6 +3060,7 @@ package body Exp_Dist is
procedure Build_Passive_Partition_Stub (U : Node_Id) is
Pkg_Spec : Node_Id;
+ Pkg_Name : String_Id;
L : List_Id;
Reg : Node_Id;
Loc : constant Source_Ptr := Sloc (U);
@@ -3063,12 +3086,14 @@ package body Exp_Dist is
L := Declarations (U);
end if;
+ Get_Pkg_Name_String (Pkg_Spec);
+ Pkg_Name := String_From_Name_Buffer;
Reg :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
Parameter_Associations => New_List (
- Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)),
+ Make_String_Literal (Loc, Pkg_Name),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
@@ -3120,6 +3145,7 @@ package body Exp_Dist is
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
New_Name : Name_Id := No_Name) return Node_Id
is
@@ -3325,6 +3351,7 @@ package body Exp_Dist is
N_Function_Specification,
Spec => Spec_To_Use,
Stub_Type => Stub_Type,
+ RACW_Type => RACW_Type,
Nod => Vis_Decl);
RCI_Calling_Stubs_Table.Set
@@ -4049,11 +4076,11 @@ package body Exp_Dist is
Pop_Scope;
end Expand_Receiving_Stubs_Bodies;
- ----------------------------
- -- Get_Pkg_Name_string_Id --
- ----------------------------
+ -------------------------
+ -- Get_Pkg_Name_string --
+ -------------------------
- function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is
+ procedure Get_Pkg_Name_String (Decl_Node : Node_Id) is
Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
begin
@@ -4063,20 +4090,7 @@ package body Exp_Dist is
Name_Len := Name_Len - 7;
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
-
- return Get_String_Id (Name_Buffer (1 .. Name_Len));
- end Get_Pkg_Name_String_Id;
-
- -------------------
- -- Get_String_Id --
- -------------------
-
- function Get_String_Id (Val : String) return String_Id is
- begin
- Start_String;
- Store_String_Chars (Val);
- return End_String;
- end Get_String_Id;
+ end Get_Pkg_Name_String;
-----------------------
-- Get_Subprogram_Id --
@@ -4331,21 +4345,26 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Package_Spec : Node_Id) return Node_Id
is
- Inst : constant Node_Id :=
- Make_Package_Instantiation (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
- Name =>
- New_Occurrence_Of (RTE (RE_RCI_Info), Loc),
- Generic_Associations => New_List (
- Make_Generic_Association (Loc,
- Selector_Name =>
- Make_Identifier (Loc, Name_RCI_Name),
- Explicit_Generic_Actual_Parameter =>
- Make_String_Literal (Loc,
- Strval => Get_Pkg_Name_String_Id (Package_Spec)))));
+ Inst : Node_Id;
+ Pkg_Name : String_Id;
begin
+ Get_Pkg_Name_String (Package_Spec);
+ Pkg_Name := String_From_Name_Buffer;
+ Inst :=
+ Make_Package_Instantiation (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
+ Name =>
+ New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
+ Generic_Associations => New_List (
+ Make_Generic_Association (Loc,
+ Selector_Name =>
+ Make_Identifier (Loc, Name_RCI_Name),
+ Explicit_Generic_Actual_Parameter =>
+ Make_String_Literal (Loc,
+ Strval => Pkg_Name))));
+
RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
Defining_Unit_Name (Inst));
return Inst;
Index: snames.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.ads,v
retrieving revision 1.31
diff -u -p -r1.31 snames.ads
--- snames.ads 4 Oct 2004 14:51:16 -0000 1.31
+++ snames.ads 27 Oct 2004 09:33:00 -0000
@@ -238,7 +238,7 @@ package Snames is
-- Names of implementations of the distributed systems annex
Name_No_DSA : constant Name_Id := N + 064;
- Name_GLADE_DSA : constant Name_Id := N + 065;
+ Name_GARLIC_DSA : constant Name_Id := N + 065;
Name_PolyORB_DSA : constant Name_Id := N + 066;
-- Names of identifiers used in expanding distribution stubs
Index: snames.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/snames.adb,v
retrieving revision 1.30
diff -u -p -r1.30 snames.adb
--- snames.adb 4 Oct 2004 14:51:16 -0000 1.30
+++ snames.adb 27 Oct 2004 09:33:00 -0000
@@ -122,7 +122,7 @@ package body Snames is
"text_io#" &
"wide_text_io#" &
"no_dsa#" &
- "glade_dsa#" &
+ "garlic_dsa#" &
"polyorb_dsa#" &
"addr#" &
"async#" &
Index: s-parint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-parint.ads,v
retrieving revision 1.8
diff -u -p -r1.8 s-parint.ads
--- s-parint.ads 13 Sep 2004 10:18:41 -0000 1.8
+++ s-parint.ads 27 Oct 2004 09:33:00 -0000
@@ -42,7 +42,7 @@ package System.Partition_Interface is
pragma Elaborate_Body;
- type DSA_Implementation_Name is (No_DSA, GLADE_DSA, PolyORB_DSA);
+ type DSA_Implementation_Name is (No_DSA, GARLIC_DSA, PolyORB_DSA);
DSA_Implementation : constant DSA_Implementation_Name := No_DSA;
-- RCI receiving stubs contain a table of descriptors for
@@ -97,7 +97,7 @@ package System.Partition_Interface is
-- unit has has the same version than the caller's one.
function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID;
- -- Similar in some respects to RCI_Info.Get_Active_Partition_ID
+ -- Similar in some respects to RCI_Locator.Get_Active_Partition_ID
function Get_Active_Version (Name : Unit_Name) return String;
-- Similar in some respects to Get_Active_Partition_ID
@@ -114,7 +114,7 @@ package System.Partition_Interface is
function Get_RCI_Package_Receiver
(Name : Unit_Name) return Interfaces.Unsigned_64;
- -- Similar in some respects to RCI_Info.Get_RCI_Package_Receiver
+ -- Similar in some respects to RCI_Locator.Get_RCI_Package_Receiver
procedure Get_Unique_Remote_Pointer
(Handler : in out RACW_Stub_Type_Access);
@@ -149,10 +149,10 @@ package System.Partition_Interface is
generic
RCI_Name : String;
- package RCI_Info is
+ package RCI_Locator is
function Get_RCI_Package_Receiver return Interfaces.Unsigned_64;
function Get_Active_Partition_ID return RPC.Partition_ID;
- end RCI_Info;
+ end RCI_Locator;
-- RCI package information caching
procedure Run (Main : Main_Subprogram_Type := null);
Index: s-parint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-parint.adb,v
retrieving revision 1.7
diff -u -p -r1.7 s-parint.adb
--- s-parint.adb 13 Sep 2004 10:18:41 -0000 1.7
+++ s-parint.adb 27 Oct 2004 09:33:00 -0000
@@ -219,11 +219,11 @@ package body System.Partition_Interface
(Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
end Raise_Program_Error_Unknown_Tag;
- --------------
- -- RCI_Info --
- --------------
+ -----------------
+ -- RCI_Locator --
+ -----------------
- package body RCI_Info is
+ package body RCI_Locator is
-----------------------------
-- Get_Active_Partition_ID --
@@ -254,7 +254,7 @@ package body System.Partition_Interface
return 0;
end Get_RCI_Package_Receiver;
- end RCI_Info;
+ end RCI_Locator;
------------------------------
-- Register_Passive_Package --
Index: rtsfind.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/rtsfind.ads,v
retrieving revision 1.19
diff -u -p -r1.19 rtsfind.ads
--- rtsfind.ads 1 Sep 2004 11:51:53 -0000 1.19
+++ rtsfind.ads 27 Oct 2004 09:33:00 -0000
@@ -1017,7 +1017,7 @@ package Rtsfind is
RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
RE_Register_Passive_Package, -- System.Partition_Interface
RE_Register_Receiving_Stub, -- System.Partition_Interface
- RE_RCI_Info, -- System.Partition_Interface
+ RE_RCI_Locator, -- System.Partition_Interface
RE_RCI_Subp_Info, -- System.Partition_Interface
RE_RCI_Subp_Info_Array, -- System.Partition_Interface
RE_Subprogram_Id, -- System.Partition_Interface
@@ -1025,8 +1025,6 @@ package Rtsfind is
RE_Global_Pool_Object, -- System.Pool_Global
- RE_Unbounded_Reclaim_Pool, -- System.Pool_Local
-
RE_Stack_Bounded_Pool, -- System.Pool_Size
RE_Do_Apc, -- System.RPC
@@ -1077,7 +1075,6 @@ package Rtsfind is
RE_Get_Local_Address, -- System.PolyORB_Interface
RE_Get_Reference, -- System.PolyORB_Interface
RE_Local_Oid_To_Address, -- System.PolyORB_Interface
- RE_RCI_Locator, -- System.PolyORB_Interface
RE_Asynchronous_P_To_Sync_Scope, -- System.PolyORB_Interface
RE_Buffer_Stream_Type, -- System.PolyORB_Interface
RE_Allocate_Buffer, -- System.PolyORB_Interface
@@ -2099,7 +2096,7 @@ package Rtsfind is
RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface,
RE_Register_Passive_Package => System_Partition_Interface,
RE_Register_Receiving_Stub => System_Partition_Interface,
- RE_RCI_Info => System_Partition_Interface,
+ RE_RCI_Locator => System_Partition_Interface,
RE_RCI_Subp_Info => System_Partition_Interface,
RE_RCI_Subp_Info_Array => System_Partition_Interface,
RE_Subprogram_Id => System_Partition_Interface,
@@ -2147,7 +2144,6 @@ package Rtsfind is
RE_Get_Local_Address => System_PolyORB_Interface,
RE_Get_Reference => System_PolyORB_Interface,
RE_Local_Oid_To_Address => System_PolyORB_Interface,
- RE_RCI_Locator => System_PolyORB_Interface,
RE_Asynchronous_P_To_Sync_Scope => System_PolyORB_Interface,
RE_Buffer_Stream_Type => System_PolyORB_Interface,
RE_Allocate_Buffer => System_PolyORB_Interface,
@@ -2234,8 +2230,6 @@ package Rtsfind is
RE_Global_Pool_Object => System_Pool_Global,
- RE_Unbounded_Reclaim_Pool => System_Pool_Local,
-
RE_Stack_Bounded_Pool => System_Pool_Size,
RE_Do_Apc => System_RPC,
More information about the Gcc-patches
mailing list