OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_dist.adb (Get_Subprogram_Ids): This function will no more assign subprogram Ids, even if they are not yet assigned.

Browse Source 
2006-10-31  Thomas Quinot  <quinot@adacore.com>
	    Pablo Oliveira  <oliveira@adacore.com>
        
        * exp_dist.adb (Get_Subprogram_Ids): This function will no more assign
	subprogram Ids, even if they are not yet assigned.
	(Build_Subprogram_Id): It is now this function that will take care of
	calling Assign_Subprogram_Ids if necessary.
	(Add_Receiving_Stubs_To_Declarations): Checking the subprograms ids
	should be done only once they are assigned.
	(Build_From_Any_Function, case of tagged types): Add missing call to
	Allocate_Buffer.
	(Corresponding_Stub_Type): New subprogram. Returns the associated stub
	type for an RACW type.
	(Add_RACW_Features): When processing an RACW declaration for which the
	designated type is already frozen, enforce E.2.2(14) rules immediately.
	(GARLIC_Support.Build_Subprogram_Receiving_Stubs): Do not perform any
	special reordering of controlling formals.

	* exp_dist.ads (Corresponding_Stub_Type): New subprogram. Returns the
	associated stub type for an RACW type.

From-SVN: r118264
This commit is contained in:
Thomas Quinot 2006-10-31 18:55:55 +01:00 committed by Arnaud Charlet
parent 108e13eb74
commit 92869a7b6b
2 changed files with 197 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

355
gcc/ada/exp_dist.adb
View File

@ -24,32 +24,34 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Atree; use Atree; with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Exp_Strm; use Exp_Strm; with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
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 Ttypes; use Ttypes;
with Uintp; use Uintp;
with GNAT.HTable; use GNAT.HTable; with GNAT.HTable; use GNAT.HTable;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
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 Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Dist is package body Exp_Dist is
@ -1012,45 +1014,53 @@ package body Exp_Dist is
-- Add_RACW_Features -- -- Add_RACW_Features --
----------------------- -----------------------
procedure Add_RACW_Features (RACW_Type : Entity_Id) procedure Add_RACW_Features (RACW_Type : Entity_Id) is
is Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
Desig : constant Entity_Id := Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
Etype (Designated_Type (RACW_Type)); Decls : List_Id;
Decls : List_Id :=
List_Containing (Declaration_Node (RACW_Type));
Same_Scope : constant Boolean :=
Scope (Desig) = Scope (RACW_Type);
Stub_Type : Entity_Id; Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id; Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id; RPC_Receiver_Decl : Node_Id;
Existing : Boolean;
Existing : Boolean;
-- True when appropriate stubs have already been generated (this is the
-- case when another RACW with the same designated type has already been
-- encountered, in which case we reuse the previous stubs rather than
-- generating new ones).
begin begin
if not Expander_Active then if not Expander_Active then
return; return;
end if; end if;
if Same_Scope then -- Look for declarations
-- We are declaring a RACW in the same package than its designated -- Case of declaring a RACW in the same package than its designated
-- type, so the list to use for late declarations must be the -- type, so the list to use for late declarations must be the private
-- private part of the package. We do know that this private part -- part of the package. We do know that this private part exists since
-- exists since the designated type has to be a private one. -- the designated type has to be a private one.
if Same_Scope then
Decls := Private_Declarations Decls := Private_Declarations
(Package_Specification_Of_Scope (Current_Scope)); (Package_Specification_Of_Scope (Current_Scope));
elsif Nkind (Parent (Decls)) = N_Package_Specification -- Comment here???
and then Present (Private_Declarations (Parent (Decls)))
then else
Decls := Private_Declarations (Parent (Decls)); Decls := List_Containing (Declaration_Node (RACW_Type));
if Nkind (Parent (Decls)) = N_Package_Specification
and then Present (Private_Declarations (Parent (Decls)))
then
Decls := Private_Declarations (Parent (Decls));
end if;
end if; end if;
-- If we were unable to find the declarations, that means that the -- If we were unable to find the declarations, that means that the
-- completion of the type was missing. We can safely return and let -- completion of the type was missing. We can safely return and let the
-- the error be caught by the semantic analysis. -- error be caught by the semantic analysis.
if No (Decls) then if No (Decls) then
return; return;
@ -1083,12 +1093,17 @@ package body Exp_Dist is
-- type and has not been handled by another RACW in the same package -- type and has not been handled by another RACW in the same package
-- as the first one, so add primitive for the stub type here. -- as the first one, so add primitive for the stub type here.
Validate_RACW_Primitives (RACW_Type);
Add_RACW_Primitive_Declarations_And_Bodies Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig, (Designated_Type => Desig,
Insertion_Node => RPC_Receiver_Decl, Insertion_Node => RPC_Receiver_Decl,
Decls => Decls); Decls => Decls);
else else
-- Validate_RACW_Primitives will be called when the designated type
-- is frozen, see Exp_Ch3.Freeze_Type.
-- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
Add_Access_Type_To_Process (E => Desig, A => RACW_Type); Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
end if; end if;
end Add_RACW_Features; end Add_RACW_Features;
@ -1102,17 +1117,17 @@ package body Exp_Dist is
Insertion_Node : Node_Id; Insertion_Node : Node_Id;
Decls : List_Id) Decls : List_Id)
is is
Loc : constant Source_Ptr := Sloc (Insertion_Node);
-- Set Sloc of generated declaration copy of insertion node Sloc, so -- Set Sloc of generated declaration copy of insertion node Sloc, so
-- the declarations are recognized as belonging to the current package. -- the declarations are recognized as belonging to the current package.
Loc : constant Source_Ptr := Sloc (Insertion_Node);
Stub_Elements : constant Stub_Structure := Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type); Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure); pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Is_RAS : constant Boolean := Is_RAS : constant Boolean :=
not Comes_From_Source (Stub_Elements.RACW_Type); not Comes_From_Source (Stub_Elements.RACW_Type);
Current_Insertion_Node : Node_Id := Insertion_Node; Current_Insertion_Node : Node_Id := Insertion_Node;
@ -1161,8 +1176,8 @@ package body Exp_Dist is
if Get_PCS_Name = Name_PolyORB_DSA then if Get_PCS_Name = Name_PolyORB_DSA then
-- For the case of PolyORB, we need to map a textual operation -- For the case of PolyORB, we need to map a textual operation
-- name into a primitive index. Currently we do so using a -- name into a primitive index. Currently we do so using a simple
-- simple sequence of string comparisons. -- sequence of string comparisons.
RPC_Receiver_Elsif_Parts := New_List; RPC_Receiver_Elsif_Parts := New_List;
end if; end if;
@ -1179,15 +1194,15 @@ package body Exp_Dist is
while Current_Primitive_Elmt /= No_Elmt loop while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt); Current_Primitive := Node (Current_Primitive_Elmt);
-- Copy the primitive of all the parents, except predefined -- Copy the primitive of all the parents, except predefined ones
-- ones that are not remotely dispatching. -- that are not remotely dispatching.
if Chars (Current_Primitive) /= Name_uSize if Chars (Current_Primitive) /= Name_uSize
and then Chars (Current_Primitive) /= Name_uAlignment and then Chars (Current_Primitive) /= Name_uAlignment
and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize) and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
then then
-- The first thing to do is build an up-to-date copy of -- The first thing to do is build an up-to-date copy of the
-- the spec with all the formals referencing Designated_Type -- spec with all the formals referencing Designated_Type
-- transformed into formals referencing Stub_Type. Since this -- transformed into formals referencing Stub_Type. Since this
-- primitive may have been inherited, go back the alias chain -- primitive may have been inherited, go back the alias chain
-- until the real primitive has been found. -- until the real primitive has been found.
@ -1237,8 +1252,8 @@ package body Exp_Dist is
-- Analyzing the body here would cause the Stub type to be -- Analyzing the body here would cause the Stub type to be
-- frozen, thus preventing subsequent primitive declarations. -- frozen, thus preventing subsequent primitive declarations.
-- For this reason, it will be analyzed later in the -- For this reason, it will be analyzed later in the regular
-- regular flow. -- flow.
-- Build the receiver stubs -- Build the receiver stubs
@ -1331,8 +1346,8 @@ package body Exp_Dist is
end if; end if;
-- Do not analyze RPC receiver at this stage since it will otherwise -- Do not analyze RPC receiver at this stage since it will otherwise
-- reference subprograms that have not been analyzed yet. It will -- reference subprograms that have not been analyzed yet. It will be
-- be analyzed in the regular flow. -- analyzed in the regular flow.
end Add_RACW_Primitive_Declarations_And_Bodies; end Add_RACW_Primitive_Declarations_And_Bodies;
@ -1372,8 +1387,8 @@ package body Exp_Dist is
Nkind (Type_Def) = N_Access_Function_Definition; Nkind (Type_Def) = N_Access_Function_Definition;
Is_Degenerate : Boolean; Is_Degenerate : Boolean;
-- Set to True if the subprogram_specification for this RAS has -- Set to True if the subprogram_specification for this RAS has an
-- an anonymous access parameter (see Process_Remote_AST_Declaration). -- anonymous access parameter (see Process_Remote_AST_Declaration).
Spec : constant Node_Id := Type_Def; Spec : constant Node_Id := Type_Def;
@ -1382,8 +1397,8 @@ package body Exp_Dist is
-- Start of processing for Add_RAS_Dereference_TSS -- Start of processing for Add_RAS_Dereference_TSS
begin begin
-- The Dereference TSS for a remote access-to-subprogram type -- The Dereference TSS for a remote access-to-subprogram type has the
-- has the form: -- form:
-- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>) -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
-- [return <>] -- [return <>]
@ -1406,11 +1421,12 @@ package body Exp_Dist is
Is_Degenerate := False; Is_Degenerate := False;
Current_Parameter := First (Parameter_Specifications (Type_Def)); Current_Parameter := First (Parameter_Specifications (Type_Def));
Parameters : while Present (Current_Parameter) loop Parameters : while Present (Current_Parameter) loop
if Nkind (Parameter_Type (Current_Parameter)) if Nkind (Parameter_Type (Current_Parameter)) =
= N_Access_Definition N_Access_Definition
then then
Is_Degenerate := True; Is_Degenerate := True;
end if; end if;
Append_To (Param_Specs, Append_To (Param_Specs,
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier =>
@ -1445,8 +1461,8 @@ package body Exp_Dist is
else else
-- For a normal RAS type, we cast the RAS formal to the corresponding -- For a normal RAS type, we cast the RAS formal to the corresponding
-- tagged type, and perform a dispatching call to its Call -- tagged type, and perform a dispatching call to its Call primitive
-- primitive operation. -- operation.
Prepend_To (Param_Assoc, Prepend_To (Param_Assoc,
Unchecked_Convert_To (RACW_Type, Unchecked_Convert_To (RACW_Type,
@ -2198,9 +2214,50 @@ package body Exp_Dist is
E : Entity_Id) return Node_Id E : Entity_Id) return Node_Id
is is
begin begin
if Get_Subprogram_Ids (E).Str_Identifier = No_String then
declare
Current_Declaration : Node_Id;
Current_Subp : Entity_Id;
Current_Subp_Str : String_Id;
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
begin
-- Build_Subprogram_Id is called outside of the context of
-- generating calling or receiving stubs. Hence we are processing
-- an 'Access attribute_reference for an RCI subprogram, for the
-- purpose of obtaining a RAS value.
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 Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Current_Subp := Defining_Unit_Name (Specification (
Current_Declaration));
Assign_Subprogram_Identifier
(Current_Subp, Current_Subp_Number, Current_Subp_Str);
Current_Subp_Number := Current_Subp_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end;
end if;
case Get_PCS_Name is case Get_PCS_Name is
when Name_PolyORB_DSA => when Name_PolyORB_DSA =>
return Make_String_Literal (Loc, Get_Subprogram_Id (E)); return Make_String_Literal (Loc, Get_Subprogram_Id (E));
when others => when others =>
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end case; end case;
@ -2335,6 +2392,18 @@ package body Exp_Dist is
end case; end case;
end Copy_Specification; end Copy_Specification;
-----------------------------
-- Corresponding_Stub_Type --
-----------------------------
function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
begin
return Stub_Elements.Stub_Type;
end Corresponding_Stub_Type;
--------------------------- ---------------------------
-- Could_Be_Asynchronous -- -- Could_Be_Asynchronous --
--------------------------- ---------------------------
@ -3466,9 +3535,6 @@ package body Exp_Dist is
Subp_Val : String_Id; Subp_Val : String_Id;
begin begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
-- Build receiving stub -- Build receiving stub
Current_Stubs := Current_Stubs :=
@ -3499,6 +3565,9 @@ package body Exp_Dist is
Current_Subprogram_Number, Current_Subprogram_Number,
Subp_Val); Subp_Val);
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
-- Add subprogram descriptor (RCI_Subp_Info) to the -- Add subprogram descriptor (RCI_Subp_Info) to the
-- subprograms table for this receiver. The aggregate -- subprograms table for this receiver. The aggregate
-- below must be kept consistent with the declaration -- below must be kept consistent with the declaration
@ -4440,13 +4509,16 @@ package body Exp_Dist is
or else not Constrained or else not Constrained
or else Is_Controlling_Formal or else Is_Controlling_Formal
then then
-- If an input parameter is contrained, then its reading is -- If an input parameter is constrained, then the read of
-- deferred until the beginning of the subprogram body. If -- the parameter is deferred until the beginning of the
-- it is unconstrained, then an expression is built for -- subprogram body. If it is unconstrained, then an
-- the object declaration and the variable is set using -- expression is built for the object declaration and the
-- 'Input instead of 'Read. -- variable is set using 'Input instead of 'Read. Note that
-- this deferral does not change the order in which the
-- actuals are read because Build_Ordered_Parameter_List
-- puts them unconstrained first.
if Constrained and then not Is_Controlling_Formal then if Constrained then
Append_To (Statements, Append_To (Statements,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc), Prefix => New_Occurrence_Of (Etyp, Loc),
@ -4780,8 +4852,10 @@ package body Exp_Dist is
----------------------- -----------------------
function Get_Subprogram_Id (Def : Entity_Id) return String_Id is function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
begin begin
return Get_Subprogram_Ids (Def).Str_Identifier; pragma Assert (Result /= No_String);
return Result;
end Get_Subprogram_Id; end Get_Subprogram_Id;
----------------------- -----------------------
@ -4800,54 +4874,8 @@ package body Exp_Dist is
function Get_Subprogram_Ids function Get_Subprogram_Ids
(Def : Entity_Id) return Subprogram_Identifiers (Def : Entity_Id) return Subprogram_Identifiers
is is
Result : Subprogram_Identifiers :=
Subprogram_Identifier_Table.Get (Def);
Current_Declaration : Node_Id;
Current_Subp : Entity_Id;
Current_Subp_Str : String_Id;
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
begin begin
if Result.Str_Identifier = No_String then return Subprogram_Identifier_Table.Get (Def);
-- We are looking up this subprogram's identifier outside of the
-- context of generating calling or receiving stubs. Hence we are
-- processing an 'Access attribute_reference for an RCI subprogram,
-- for the purpose of obtaining a RAS value.
pragma Assert
(Is_Remote_Call_Interface (Scope (Def))
and then
(Nkind (Parent (Def)) = N_Procedure_Specification
or else
Nkind (Parent (Def)) = N_Function_Specification));
Current_Declaration :=
First (Visible_Declarations
(Package_Specification_Of_Scope (Scope (Def))));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Current_Subp := Defining_Unit_Name (Specification (
Current_Declaration));
Assign_Subprogram_Identifier
(Current_Subp, Current_Subp_Number, Current_Subp_Str);
if Current_Subp = Def then
Result := (Current_Subp_Str, Current_Subp_Number);
end if;
Current_Subp_Number := Current_Subp_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end if;
pragma Assert (Result.Str_Identifier /= No_String);
return Result;
end Get_Subprogram_Ids; end Get_Subprogram_Ids;
---------- ----------
@ -6712,9 +6740,6 @@ package body Exp_Dist is
Proxy_Object_Addr : Entity_Id; Proxy_Object_Addr : Entity_Id;
begin begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
-- Build receiving stub -- Build receiving stub
Current_Stubs := Current_Stubs :=
@ -6745,6 +6770,9 @@ package body Exp_Dist is
Current_Subprogram_Number, Current_Subprogram_Number,
Subp_Val); Subp_Val);
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Dist_Name, Defining_Identifier => Subp_Dist_Name,
@ -6979,9 +7007,9 @@ package body Exp_Dist is
Is_Controlling_Formal : Boolean; Is_Controlling_Formal : Boolean;
Is_First_Controlling_Formal : Boolean; Is_First_Controlling_Formal : Boolean;
First_Controlling_Formal_Seen : Boolean := False; First_Controlling_Formal_Seen : Boolean := False;
-- Controlling formal parameters of distributed object -- Controlling formal parameters of distributed object primitives
-- primitives require special handling, and the first -- require special handling, and the first such parameter needs even
-- such parameter needs even more. -- more special handling.
begin begin
-- ??? document general form of stub subprograms for the PolyORB case -- ??? document general form of stub subprograms for the PolyORB case
@ -7069,8 +7097,8 @@ package body Exp_Dist is
if Is_Controlling_Formal then if Is_Controlling_Formal then
-- In the case of a controlling formal argument, we send -- In the case of a controlling formal argument, we send its
-- its reference. -- reference.
Etyp := RACW_Type; Etyp := RACW_Type;
@ -7078,9 +7106,8 @@ package body Exp_Dist is
Etyp := Etype (Parameter_Type (Current_Parameter)); Etyp := Etype (Parameter_Type (Current_Parameter));
end if; end if;
-- The first controlling formal parameter is treated -- The first controlling formal parameter is treated specially: it
-- specially: it is used to set the target object of -- is used to set the target object of the call.
-- the call.
if not Is_First_Controlling_Formal then if not Is_First_Controlling_Formal then
@ -7103,11 +7130,10 @@ package body Exp_Dist is
begin begin
if Is_Controlling_Formal then if Is_Controlling_Formal then
-- For a controlling formal parameter (other -- For a controlling formal parameter (other than the
-- than the first one), use the corresponding -- first one), use the corresponding RACW. If the
-- RACW. If the parameter is not an anonymous -- parameter is not an anonymous access parameter, that
-- access parameter, that involves taking -- involves taking its 'Unrestricted_Access.
-- its 'Unrestricted_Access.
if Nkind (Parameter_Type (Current_Parameter)) if Nkind (Parameter_Type (Current_Parameter))
= N_Access_Definition = N_Access_Definition
@ -7130,10 +7156,10 @@ package body Exp_Dist is
or else not Constrained or else not Constrained
or else Is_Controlling_Formal or else Is_Controlling_Formal
then then
-- The parameter has an input value, is constrained -- The parameter has an input value, is constrained at
-- at runtime by an input value, or is a controlling -- runtime by an input value, or is a controlling formal
-- formal parameter (always passed as a reference) -- parameter (always passed as a reference) other than
-- other than the first one. -- the first one.
Expr := PolyORB_Support.Helpers.Build_To_Any_Call ( Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
Actual_Parameter, Decls); Actual_Parameter, Decls);
@ -7181,8 +7207,8 @@ package body Exp_Dist is
end; end;
end if; end if;
-- If the current parameter has a dynamic constrained status, -- If the current parameter has a dynamic constrained status, then
-- then this status is transmitted as well. -- this status is transmitted as well.
-- This should be done for accessibility as well ??? -- This should be done for accessibility as well ???
if Nkind (Parameter_Type (Current_Parameter)) if Nkind (Parameter_Type (Current_Parameter))
@ -7254,9 +7280,9 @@ package body Exp_Dist is
else else
pragma Assert (Present (Asynchronous)); pragma Assert (Present (Asynchronous));
Asynchronous_P := New_Copy_Tree (Asynchronous); Asynchronous_P := New_Copy_Tree (Asynchronous);
-- The expression node Asynchronous will be used to build -- The expression node Asynchronous will be used to build an 'if'
-- an 'if' statement at the end of Build_General_Calling_Stubs: -- statement at the end of Build_General_Calling_Stubs: we need to
-- we need to make a copy here. -- make a copy here.
end if; end if;
Append_To (Parameter_Associations (Last (Statements)), Append_To (Parameter_Associations (Last (Statements)),
@ -7290,8 +7316,7 @@ package body Exp_Dist is
if Is_Function then if Is_Function then
-- If this is a function call, then read the value and -- If this is a function call, read the value and return it
-- return it.
Append_To (Non_Asynchronous_Statements, Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc, Make_Tag_Check (Loc,
@ -7353,8 +7378,8 @@ package body Exp_Dist is
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Controlling_Parameter, Prefix => Controlling_Parameter,
Selector_Name => Name_Target))))); Selector_Name => Name_Target)))));
-- Controlling_Parameter has the same components -- Controlling_Parameter has the same components as
-- as System.Partition_Interface.RACW_Stub_Type. -- System.Partition_Interface.RACW_Stub_Type.
Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
@ -7503,10 +7528,9 @@ package body Exp_Dist is
-- ??? -- ???
Outer_Decls : constant List_Id := New_List; Outer_Decls : constant List_Id := New_List;
-- At the outermost level, an NVList and Any's are -- At the outermost level, an NVList and Any's are declared for all
-- declared for all parameters. The Dynamic_Async -- parameters. The Dynamic_Async flag also needs to be declared there
-- flag also needs to be declared there to be visible -- to be visible from the exception handling code.
-- from the exception handling code.
Outer_Statements : constant List_Id := New_List; Outer_Statements : constant List_Id := New_List;
-- Statements that occur prior to the declaration of the actual -- Statements that occur prior to the declaration of the actual
@ -7685,7 +7709,7 @@ package body Exp_Dist is
or else not Out_Present (Current_Parameter) or else not Out_Present (Current_Parameter)
or else not Constrained or else not Constrained
then then
-- If an input parameter is contrained, then its reading is -- If an input parameter is constrained, then its reading is
-- deferred until the beginning of the subprogram body. If -- deferred until the beginning of the subprogram body. If
-- it is unconstrained, then an expression is built for -- it is unconstrained, then an expression is built for
-- the object declaration and the variable is set using -- the object declaration and the variable is set using
@ -7705,8 +7729,8 @@ package body Exp_Dist is
Expr := Empty; Expr := Empty;
else else
null; null;
-- Expr will be used to initialize (and constrain) -- Expr will be used to initialize (and constrain) the
-- the parameter when it is declared. -- parameter when it is declared.
end if; end if;
end if; end if;
@ -8764,6 +8788,15 @@ package body Exp_Dist is
Object_Definition => Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
-- Allocate_Buffer (Strm);
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc))));
-- Any_To_BS (Strm, A); -- Any_To_BS (Strm, A);
Append_To (Stms, Append_To (Stms,

3
gcc/ada/exp_dist.ads
View File

@ -95,6 +95,9 @@ package Exp_Dist is
-- access to Stub_Type. If New_Name is given, then it will be used as -- access to Stub_Type. If New_Name is given, then it will be used as
-- the name for the newly created spec. -- the name for the newly created spec.
function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id;
-- Return the stub type associated with the given RACW type
function Underlying_RACW_Type function Underlying_RACW_Type
(RAS_Typ : Entity_Id) return Entity_Id; (RAS_Typ : Entity_Id) return Entity_Id;
-- Given a remote access-to-subprogram type or its equivalent -- Given a remote access-to-subprogram type or its equivalent