diff options
Diffstat (limited to 'gcc/ada/exp_dist.adb')
| -rw-r--r-- | gcc/ada/exp_dist.adb | 580 |
1 files changed, 326 insertions, 254 deletions
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index fb91ce7a47a..3ad20602b38 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -41,6 +41,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; @@ -225,9 +226,7 @@ package body Exp_Dist is -- In either case, this means stubs cannot contain a default-initialized -- object declaration of such type. - procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id); + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); -- Add calling stubs to the declarative part function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; @@ -915,27 +914,145 @@ package body Exp_Dist is -- since this require separate mechanisms ('Input is a function while -- 'Read is a procedure). + generic + with procedure Process_Subprogram_Declaration (Decl : Node_Id); + -- Generate calling or receiving stub for this subprogram declaration + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id); + -- Recursively visit the given RCI Package_Specification, calling + -- Process_Subprogram_Declaration for each remote subprogram. + + ------------------------- + -- Build_Package_Stubs -- + ------------------------- + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is + Decls : constant List_Id := Visible_Declarations (Pkg_Spec); + Decl : Node_Id; + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); + -- Recurse for the given nested package declaration + + ----------------------- + -- Visit_Nested_Spec -- + ----------------------- + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is + Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); + begin + Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); + Build_Package_Stubs (Nested_Pkg_Spec); + Pop_Scope; + end Visit_Nested_Pkg; + + -- Start of processing for Build_Package_Stubs + + begin + Decl := First (Decls); + while Present (Decl) loop + case Nkind (Decl) is + when N_Subprogram_Declaration => + + -- Note: we test Comes_From_Source on Spec, not Decl, because + -- in the case of a subprogram instance, only the specification + -- (not the declaration) is marked as coming from source. + + if Comes_From_Source (Specification (Decl)) then + Process_Subprogram_Declaration (Decl); + end if; + + when N_Package_Declaration => + + -- Case of a nested package or package instantiation coming + -- from source. Note that the anonymous wrapper package for + -- subprogram instances is not flagged Is_Generic_Instance at + -- this point, so there is a distinct circuit to handle them + -- (see case N_Subprogram_Instantiation below). + + declare + Pkg_Ent : constant Entity_Id := + Defining_Unit_Name (Specification (Decl)); + begin + if Comes_From_Source (Decl) + or else + (Is_Generic_Instance (Pkg_Ent) + and then Comes_From_Source + (Get_Package_Instantiation_Node (Pkg_Ent))) + then + Visit_Nested_Pkg (Decl); + end if; + end; + + when N_Subprogram_Instantiation => + + -- The subprogram declaration for an instance of a generic + -- subprogram is wrapped in a package that does not come from + -- source, so we need to explicitly traverse it here. + + if Comes_From_Source (Decl) then + Visit_Nested_Pkg (Instance_Spec (Decl)); + end if; + + when others => + null; + end case; + Next (Decl); + end loop; + end Build_Package_Stubs; + --------------------------------------- -- Add_Calling_Stubs_To_Declarations -- --------------------------------------- - procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id) - is + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; -- Subprogram id 0 is reserved for calls received from -- remote access-to-subprogram dereferences. - Current_Declaration : Node_Id; - Loc : constant Source_Ptr := Sloc (Pkg_Spec); RCI_Instantiation : Node_Id; - Subp_Stubs : Node_Id; - Subp_Str : String_Id; - pragma Warnings (Off, Subp_Str); + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate calling stub for one remote subprogram + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Stubs : Node_Id; + Subp_Str : String_Id; + pragma Warnings (Off, Subp_Str); + + begin + Assign_Subprogram_Identifier + (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs ( + Vis_Decl => Decl, + Subp_Id => + Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Defining_Unit_Name (Spec))); + + Append_To (List_Containing (Decl), Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Calling_Stubs_To_Declarations begin + Push_Scope (Scope_Of_Spec (Pkg_Spec)); + -- The first thing added is an instantiation of the generic package -- System.Partition_Interface.RCI_Locator with the name of this remote -- package. This will act as an interface with the name server to @@ -945,51 +1062,21 @@ package body Exp_Dist is RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); RCI_Cache := Defining_Unit_Name (RCI_Instantiation); - Append_To (Decls, RCI_Instantiation); + Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); Analyze (RCI_Instantiation); -- For each subprogram declaration visible in the spec, we do build a -- body. We also increment a counter to assign a different Subprogram_Id - -- to each subprograms. The receiving stubs processing do use the same + -- to each subprograms. The receiving stubs processing uses the same -- mechanism and will thus assign the same Id and do the correct -- dispatching. Overload_Counter_Table.Reset; PolyORB_Support.Reserve_NamingContext_Methods; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - Assign_Subprogram_Identifier - (Defining_Unit_Name (Specification (Current_Declaration)), - Current_Subprogram_Number, - Subp_Str); - - Subp_Stubs := - Build_Subprogram_Calling_Stubs ( - Vis_Decl => Current_Declaration, - Subp_Id => - Build_Subprogram_Id (Loc, - Defining_Unit_Name (Specification (Current_Declaration))), - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then - Is_Asynchronous (Defining_Unit_Name (Specification - (Current_Declaration)))); - - Append_To (Decls, Subp_Stubs); - Analyze (Subp_Stubs); - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; + Visit_Spec (Pkg_Spec); - -- Need to handle the case of nested packages??? - - Next (Current_Declaration); - end loop; + Pop_Scope; end Add_Calling_Stubs_To_Declarations; ----------------------------- @@ -2819,12 +2906,8 @@ package body Exp_Dist is procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is Spec : constant Node_Id := Specification (Unit_Node); - Decls : constant List_Id := Visible_Declarations (Spec); begin - Push_Scope (Scope_Of_Spec (Spec)); - Add_Calling_Stubs_To_Declarations - (Specification (Unit_Node), Decls); - Pop_Scope; + Add_Calling_Stubs_To_Declarations (Spec); end Expand_Calling_Stubs_Bodies; ----------------------------------- @@ -3685,6 +3768,7 @@ package body Exp_Dist is Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request + Lookup_RAS : Node_Id; Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); -- A remote subprogram is created to allow peers to look up RAS -- information using subprogram ids. @@ -3693,9 +3777,8 @@ package body Exp_Dist is Subp_Index : Entity_Id; -- Subprogram_Id as read from the incoming stream - Current_Declaration : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Current_Stubs : Node_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); Subp_Info_List : constant List_Id := New_List; @@ -3713,6 +3796,9 @@ package body Exp_Dist is -- associating Subprogram_Number with the subprogram declared -- by Declaration, for which we have receiving stubs in Stubs. + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + --------------------- -- Append_Stubs_To -- --------------------- @@ -3736,6 +3822,76 @@ package body Exp_Dist is New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + pragma Warnings (Off, Subp_Val); + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. This aggregate must be kept consistent + -- with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + + -- Addr => + + Make_Component_Association (Loc, + Choices => + New_List (Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => Current_Subp_Number); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + -- Start of processing for Add_Receiving_Stubs_To_Declarations begin @@ -3800,7 +3956,7 @@ package body Exp_Dist is -- Build a subprogram for RAS information lookups - Current_Declaration := + Lookup_RAS := Make_Subprogram_Declaration (Loc, Specification => Make_Function_Specification (Loc, @@ -3816,19 +3972,17 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); - - Append_To (Decls, Current_Declaration); - Analyze (Current_Declaration); + Append_To (Decls, Lookup_RAS); + Analyze (Lookup_RAS); Current_Stubs := Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, + (Vis_Decl => Lookup_RAS, Asynchronous => False); Append_To (Decls, Current_Stubs); Analyze (Current_Stubs); Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => - Current_Stubs, + Stubs => Current_Stubs, Subprogram_Number => 1); -- For each subprogram, the receiving stub will be built and a @@ -3841,87 +3995,7 @@ package body Exp_Dist is Overload_Counter_Table.Reset; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - pragma Warnings (Off, Subp_Val); - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous (Subp_Def)); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Addr)), - Expression => - New_Occurrence_Of ( - Proxy_Object_Addr, Loc)))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => Current_Stubs, - Subprogram_Number => Current_Subprogram_Number); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - -- Need to handle case of a nested package??? - - Next (Current_Declaration); - end loop; + Visit_Spec (Pkg_Spec); -- If we receive an invalid Subprogram_Id, it is best to do nothing -- rather than raising an exception since we do not want someone @@ -6654,13 +6728,10 @@ package body Exp_Dist is Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; - Current_Declaration : Node_Id; - Current_Stubs : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); - - Subp_Info_List : constant List_Id := New_List; + Subp_Info_List : constant List_Id := New_List; Register_Pkg_Actuals : constant List_Id := New_List; @@ -6681,6 +6752,9 @@ package body Exp_Dist is -- object, used in the context of calls through remote -- access-to-subprogram types. + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + --------------------- -- Append_Stubs_To -- --------------------- @@ -6744,6 +6818,110 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Subp_Number))))); end Append_Stubs_To; + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + + Subp_Dist_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); + + Current_Stubs : Node_Id; + Proxy_Obj_Addr : Entity_Id; + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Obj_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert + (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Dist_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Subp_Val))); + Analyze (Last (Decls)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. The aggregate below must be kept + -- consistent with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => + New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Name => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Address), + + -- Name_Length => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Length), + + -- Addr => + + New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => Decl, + Stubs => Current_Stubs, + Subp_Number => Current_Subp_Number, + Subp_Dist_Name => Subp_Dist_Name, + Subp_Proxy_Addr => Proxy_Obj_Addr); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + -- Start of processing for Add_Receiving_Stubs_To_Declarations begin @@ -6804,113 +6982,7 @@ package body Exp_Dist is Overload_Counter_Table.Reset; Reserve_NamingContext_Methods; - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - - Subp_Dist_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name - (Related_Id => Chars (Subp_Def), - Suffix => 'D', - Suffix_Index => -1)); - - Proxy_Object_Addr : Entity_Id; - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous (Subp_Def)); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Dist_Name, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, Subp_Val))); - Analyze (Last (Decls)); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Address), - - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Length), - - New_Occurrence_Of (Proxy_Object_Addr, Loc))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => Current_Declaration, - Stubs => Current_Stubs, - Subp_Number => Current_Subprogram_Number, - Subp_Dist_Name => Subp_Dist_Name, - Subp_Proxy_Addr => Proxy_Object_Addr); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - -- Need to handle case of a nested package??? - - Next (Current_Declaration); - end loop; + Visit_Spec (Pkg_Spec); Append_To (Decls, Make_Object_Declaration (Loc, |