Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
+ Stub_Type : Entity_Id := Empty;
Nod : Node_Id);
-- Build calling stubs for general purpose. The parameters are:
-- Decls : a place to put declarations
-- Is_Known_Non_A... : True if we know that this is not asynchronous
-- Spec : a node with a Parameter_Specifications and
-- a Subtype_Mark if applicable
- -- Object_Type : in case of a RACW, parameters of type access to
- -- Object_Type will be marshalled using the
- -- address of this object (the addr field) rather
- -- than using the 'Write on the object itself
+ -- Stub_Type : in case of RACW stubs, parameters of type access
+ -- to Stub_Type will be marshalled using the
+ -- address of the object (the addr field) rather
+ -- than using the 'Write on the stub itself
-- Nod : used to provide sloc for generated code
function Build_Subprogram_Calling_Stubs
package Asynchronous_Flags_Table is
new Simple_HTable (Header_Num => Hash_Index,
- Element => Node_Id,
+ Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => Hash,
Equal => "=");
- -- Mapping between a RACW type and the node holding the value True if
- -- the RACW is asynchronous and False otherwise.
+ -- Mapping between a RACW type and a constant having the value True
+ -- if the RACW is asynchronous and False otherwise.
package RCI_Locator_Table is
new Simple_HTable (Header_Num => Hash_Index,
-- then nothing is added in the tree but the right values are returned
-- anyhow and Existing is set to True.
+ procedure Add_RACW_Asynchronous_Flag
+ (Declarations : List_Id;
+ RACW_Type : Entity_Id);
+ -- Declare a boolean constant associated with RACW_Type whose value
+ -- indicates at run time whether a pragma Asynchronous applies to it.
+
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
end loop;
end Add_Calling_Stubs_To_Declarations;
+ --------------------------------
+ -- Add_RACW_Asynchronous_Flag --
+ --------------------------------
+
+ procedure Add_RACW_Asynchronous_Flag
+ (Declarations : List_Id;
+ RACW_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
+
+ Asynchronous_Flag : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (RACW_Type), 'A'));
+
+ begin
+ -- Declare the asynchronous flag. This flag will be changed to True
+ -- whenever it is known that the RACW type is asynchronous.
+
+ Append_To (Declarations,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Asynchronous_Flag,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)));
+
+ Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
+ end Add_RACW_Asynchronous_Flag;
+
-----------------------
-- Add_RACW_Features --
-----------------------
Object_RPC_Receiver => Object_RPC_Receiver,
Existing => Existing);
+ Add_RACW_Asynchronous_Flag
+ (Declarations => Decls,
+ RACW_Type => RACW_Type);
+
Add_RACW_Read_Write_Attributes
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
if not Same_Scope and then not Existing then
-- The RACW has been declared in another scope than the designated
- -- 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.
+ -- 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.
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node : Node_Id;
Decls : List_Id)
is
- -- Set sloc of generated declaration to be that of the
- -- insertion node, so the declarations are recognized as
- -- belonging to the current package.
+ -- Set sloc of generated declaration copy of insertion node sloc, so
+ -- the declarations are recognized as belonging to the current package.
Loc : constant Source_Ptr := Sloc (Insertion_Node);
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
- Local_Stub : constant Entity_Id :=
+ Local_Stub : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
- Stubbed_Result : constant Entity_Id :=
+ Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Asynchronous_Flag : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('S'));
- Asynchronous_Node : constant Node_Id :=
- New_Occurrence_Of (Standard_False, Loc);
-
- -- Functions to create occurrences of the formal
- -- parameter names.
+ Asynchronous_Flags_Table.Get (RACW_Type);
+ pragma Assert (Present (Asynchronous_Flag));
function Stream_Parameter return Node_Id;
function Result return Node_Id;
+ -- Functions to create occurrences of the formal parameter names
- function Stream_Parameter return Node_Id is
- begin
- return Make_Identifier (Loc, Name_S);
- end Stream_Parameter;
+ ------------
+ -- Result --
+ ------------
function Result return Node_Id is
begin
return Make_Identifier (Loc, Name_V);
end Result;
- begin
- -- Declare the asynchronous flag. This flag will be changed to True
- -- whenever it is known that the RACW type is asynchronous. Also, the
- -- node gets stored since it may be rewritten when we process the
- -- asynchronous pragma.
+ ----------------------
+ -- Stream_Parameter --
+ ----------------------
- Append_To (Declarations,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Asynchronous_Flag,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => Asynchronous_Node));
+ function Stream_Parameter return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_S);
+ end Stream_Parameter;
- Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
+ -- Start of processing for Add_RACW_Read_Attribute
- -- Object declarations
+ begin
+ -- Generate object declarations
Decls := New_List (
Make_Object_Declaration (Loc,
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
- -- Build_Get_Unique_RP_Call needs this information.
+ -- Build_Get_Unique_RP_Call needs this information
-- Note: Here we assume that the Fat_Type is a record
-- containing just a pointer to a proxy or stub object.
Proc_Statements := New_List (
- -- Get_RAS_Info (Pkg, Subp, PA);
- -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
- -- return Fat_Type!(PA);
- -- end if;
+ -- Generate:
+
+ -- Get_RAS_Info (Pkg, Subp, PA);
+ -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
+ -- return Fat_Type!(PA);
+ -- end if;
Make_Procedure_Call_Statement (Loc,
Name =>
Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
+ -- E.4.1(9) A remote call is asynchronous if it is a call to
+ -- a procedure, or a call through a value of an access-to-procedure
+ -- type, to which a pragma Asynchronous applies.
+
+ -- Parameter Asynch_P is true when the procedure is asynchronous;
+ -- Expression Asynch_T is true when the type is asynchronous.
+
Set_Field (Name_Asynchronous,
Make_Or_Else (Loc,
New_Occurrence_Of (Asynch_P, Loc),
New_Occurrence_Of (Boolean_Literals (
Is_Asynchronous (Ras_Type)), Loc))));
- -- E.4.1(9) A remote call is asynchronous if it is a call to
- -- a procedure, or a call through a value of an access-to-procedure
- -- type, to which a pragma Asynchronous applies.
- -- Parameter Asynch_P is true when the procedure is asynchronous;
- -- Expression Asynch_T is true when the type is asynchronous.
Append_List_To (Proc_Statements,
Build_Get_Unique_RP_Call
-- Add_RAS_Dereference_TSS --
-----------------------------
+ -- This subprogram could use more comments ???
+
procedure Add_RAS_Dereference_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Parameter_Associations => Param_Assoc));
end if;
- -- Build the complete subprogram.
+ -- Build the complete subprogram
if Is_Function then
Proc_Spec :=
Set_Comes_From_Source (Proxy_Type_Full_View, True);
-
-- procedure Call
-- (Self : access O;
-- ...other-formals...) is
-- associating Subprogram_Number with the subprogram declared
-- by Declaration, for which we have receiving stubs in Stubs.
+ ---------------------
+ -- Append_Stubs_To --
+ ---------------------
+
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Declaration : Node_Id;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
+ Stub_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Asynchronous_Statements : List_Id := No_List;
Non_Asynchronous_Statements : List_Id := No_List;
- -- Statements specifics to the Asynchronous/Non-Asynchronous cases.
+ -- Statements specifics to the Asynchronous/Non-Asynchronous cases
Extra_Formal_Statements : constant List_Id := New_List;
-- List of statements for extra formal parameters. It will appear after
Extra_Parameter : Entity_Id;
begin
- if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
+ if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
-- In the case of a controlling formal argument, we marshall
-- its addr field rather than the local stub.
if (Out_Present (Current_Parameter)
or else Nkind (Typ) = N_Access_Definition)
- and then Etyp /= Object_Type
+ and then Etyp /= Stub_Type
then
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Is_Function => Nkind (Spec_To_Use) =
N_Function_Specification,
Spec => Spec_To_Use,
- Object_Type => Stub_Type,
+ Stub_Type => Stub_Type,
Nod => Vis_Decl);
RCI_Calling_Stubs_Table.Set
-------------------------------
procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
- N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
- pragma Assert (N /= Empty);
+ Asynchronous_Flag : constant Entity_Id :=
+ Asynchronous_Flags_Table.Get (RACW_Type);
begin
- Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
+ Replace (Expression (Parent (Asynchronous_Flag)),
+ New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
end RACW_Type_Is_Asynchronous;
-------------------------
projects / gcc.git / commitdiff