diff options
Diffstat (limited to 'gcc/ada/sem_dist.adb')
| -rw-r--r-- | gcc/ada/sem_dist.adb | 294 |
1 files changed, 210 insertions, 84 deletions
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index aee306d..8314e6c 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -105,6 +105,55 @@ package body Sem_Dist is end if; end Add_Stub_Constructs; + --------------------------------------- + -- Build_RAS_Primitive_Specification -- + --------------------------------------- + + function Build_RAS_Primitive_Specification + (Subp_Spec : Node_Id; + Remote_Object_Type : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Subp_Spec); + + Primitive_Spec : constant Node_Id := + Copy_Specification (Loc, + Spec => Subp_Spec, + New_Name => Name_Call); + + Subtype_Mark_For_Self : Node_Id; + + begin + if No (Parameter_Specifications (Primitive_Spec)) then + Set_Parameter_Specifications (Primitive_Spec, New_List); + end if; + + if Nkind (Remote_Object_Type) in N_Entity then + Subtype_Mark_For_Self := + New_Occurrence_Of (Remote_Object_Type, Loc); + else + Subtype_Mark_For_Self := Remote_Object_Type; + end if; + + Prepend_To ( + Parameter_Specifications (Primitive_Spec), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Subtype_Mark_For_Self))); + + -- Trick later semantic analysis into considering this + -- operation as a primitive (dispatching) operation of + -- tagged type Obj_Type. + + Set_Comes_From_Source ( + Defining_Unit_Name (Primitive_Spec), True); + + return Primitive_Spec; + end Build_RAS_Primitive_Specification; + ------------------------- -- Full_Qualified_Name -- ------------------------- @@ -295,7 +344,6 @@ package body Sem_Dist is Async_E : Entity_Id; All_Calls_Remote_E : Entity_Id; Attribute_Subp : Entity_Id; - Local_Addr : Node_Id; begin -- Check if we have to expand the access attribute @@ -329,17 +377,11 @@ package body Sem_Dist is All_Calls_Remote_E := Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); - Local_Addr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Remote_Subp, Loc), - Attribute_Name => Name_Address); - Tick_Access_Conv_Call := Make_Function_Call (Loc, Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( - Local_Addr, Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), @@ -354,78 +396,165 @@ package body Sem_Dist is ------------------------------------ procedure Process_Remote_AST_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - User_Type : constant Node_Id := Defining_Identifier (N); - Fat_Type : constant Entity_Id := + Loc : constant Source_Ptr := Sloc (N); + User_Type : constant Node_Id := Defining_Identifier (N); + Scop : constant Entity_Id := Scope (User_Type); + Is_RCI : constant Boolean := + Is_Remote_Call_Interface (Scop); + Is_RT : constant Boolean := + Is_Remote_Types (Scop); + Type_Def : constant Node_Id := Type_Definition (N); + + Parameter : Node_Id; + Is_Degenerate : Boolean; + -- True iff this RAS has an access formal parameter (see + -- Exp_Dist.Add_RAS_Dereference_TSS for details). + + Subpkg : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Subpkg_Decl : Node_Id; + Vis_Decls : constant List_Id := New_List; + Priv_Decls : constant List_Id := New_List; + + Obj_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name ( + Chars (User_Type), 'R')); + + + Full_Obj_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Obj_Type)); + + RACW_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name ( + Chars (User_Type), 'P')); + + Fat_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars (User_Type)); - New_Type_Decl : Node_Id; + Fat_Type_Decl : Node_Id; begin - -- We add a record type declaration for the equivalent fat pointer type - New_Type_Decl := + -- The tagged private type, primitive operation and RACW + -- type associated with a RAS need to all be declared in + -- a subpackage of the one that contains the RAS declaration, + -- because the primitive of the object type, and the associated + -- primitive of the stub type, need to be dispatching operations + -- of these types, and the profile of the RAS might contain + -- tagged types declared in the same scope. + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Obj_Type, + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True)); + + Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => Fat_Type, - Type_Definition => + Defining_Identifier => + Full_Obj_Type, + Type_Definition => Make_Record_Definition (Loc, - Component_List => - Make_Component_List (Loc, - Component_Items => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Ras), - 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, - Chars => Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Integer, Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Subp_Id), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Natural, Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Async), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Boolean, Loc))))))); - - Insert_After (N, New_Type_Decl); + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True, + Null_Present => True, + Component_List => Empty))); + + Is_Degenerate := False; + Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Present (Parameter) loop + if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then + Error_Msg_N ("formal parameter& has anonymous access type?", + Defining_Identifier (Parameter)); + Is_Degenerate := True; + exit Parameters; + end if; + Next (Parameter); + end loop Parameters; + + if Is_Degenerate then + Error_Msg_NE ( + "remote access-to-subprogram type& can only be null?", + Defining_Identifier (Parameter), User_Type); + -- The only legal value for a RAS with a formal parameter of an + -- anonymous access type is null, because it cannot be + -- subtype-Conformant with any legal remote subprogram declaration. + -- In this case, we cannot generate a corresponding primitive + -- operation. + + else + Append_To (Vis_Decls, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => Build_RAS_Primitive_Specification ( + Subp_Spec => Type_Def, + Remote_Object_Type => Obj_Type))); + end if; + + Append_To (Vis_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => RACW_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Obj_Type, Loc), + Attribute_Name => + Name_Class)))); + Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); + Set_Is_Remote_Types (RACW_Type, Is_RT); + -- ??? Object RPC receiver generation should be bypassed for this + -- RACW type, since actually calls will be received by the package + -- RPC receiver for the designated RCI subprogram. + + Subpkg_Decl := + Make_Package_Declaration (Loc, + Make_Package_Specification (Loc, + Defining_Unit_Name => + Subpkg, + Visible_Declarations => + Vis_Decls, + Private_Declarations => + Priv_Decls, + End_Label => + New_Occurrence_Of (Subpkg, Loc))); + Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); + Set_Is_Remote_Types (Subpkg, Is_RT); + Insert_After_And_Analyze (N, Subpkg_Decl); + + -- Many parts of the analyzer and expander expect + -- that the fat pointer type used to implement remote + -- access to subprogram types be a record. + -- Note: The structure of this type must be kept consistent + -- with the code generated by Remote_AST_Null_Value for the + -- corresponding 'null' expression. + + Fat_Type_Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Fat_Type, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Ras), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Occurrence_Of (RACW_Type, Loc))))))); Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); + Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl); -- The reason we suppress the initialization procedure is that we know -- that no initialization is required (even if Initialize_Scalars mode @@ -506,8 +635,7 @@ package body Sem_Dist is -- Remote_AST_E_Dereference -- ------------------------------ - function Remote_AST_E_Dereference (P : Node_Id) return Boolean - is + function Remote_AST_E_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); begin @@ -534,12 +662,11 @@ package body Sem_Dist is -- Remote_AST_I_Dereference -- ------------------------------ - function Remote_AST_I_Dereference (P : Node_Id) return Boolean - is + function Remote_AST_I_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); Deref : Node_Id; - begin + begin if Comes_From_Source (P) and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) @@ -563,9 +690,8 @@ package body Sem_Dist is --------------------------- function Remote_AST_Null_Value - (N : Node_Id; - Typ : Entity_Id) - return Boolean + (N : Node_Id; + Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); Target_Type : Entity_Id; @@ -603,12 +729,12 @@ package body Sem_Dist is Rewrite (N, Make_Aggregate (Loc, - Expressions => New_List ( - Make_Integer_Literal (Loc, 0), -- Ras - Make_Integer_Literal (Loc, 0), -- Origin - Make_Integer_Literal (Loc, 0), -- Receiver - Make_Integer_Literal (Loc, 0), -- Subp_Id - New_Occurrence_Of (Standard_False, Loc)))); -- Asyn + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Ras)), + Expression => + Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; |