diff options
Diffstat (limited to 'gcc/ada/exp_disp.adb')
| -rw-r--r-- | gcc/ada/exp_disp.adb | 483 |
1 files changed, 259 insertions, 224 deletions
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index f24828263..9b5cb5716 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1068,6 +1068,32 @@ package body Exp_Disp is -- to avoid the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); + + -- For functions returning interface types add implicit conversion to + -- force the displacement of the pointer to the object to reference + -- the corresponding secondary dispatch table. This is needed to + -- handle well nested calls through secondary dispatch tables + -- (for example Obj.Prim1.Prim2). + + if Is_Interface (Res_Typ) then + Rewrite (Call_Node, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Res_Typ, Loc), + Expression => Relocate_Node (Call_Node))); + Set_Etype (Call_Node, Res_Typ); + Expand_Interface_Conversion (Call_Node, Is_Static => False); + Force_Evaluation (Call_Node); + + pragma Assert (Nkind (Call_Node) = N_Explicit_Dereference + and then Nkind (Prefix (Call_Node)) = N_Identifier + and then Nkind (Parent (Entity (Prefix (Call_Node)))) + = N_Object_Declaration); + Set_Assignment_OK (Parent (Entity (Prefix (Call_Node)))); + + if Nkind (Parent (Call_Node)) = N_Object_Declaration then + Set_Assignment_OK (Parent (Call_Node)); + end if; + end if; end Expand_Dispatching_Call; --------------------------------- @@ -8421,115 +8447,57 @@ package body Exp_Disp is procedure Set_CPP_Constructors (Typ : Entity_Id) is - procedure Set_CPP_Constructors_Old (Typ : Entity_Id); - -- For backward compatibility this routine handles CPP constructors - -- of non-tagged types. + function Gen_Parameters_Profile (E : Entity_Id) return List_Id; + -- Duplicate the parameters profile of the imported C++ constructor + -- adding an access to the object as an additional parameter. - procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is - Loc : Source_Ptr; - Init : Entity_Id; - E : Entity_Id; - Found : Boolean := False; - P : Node_Id; + function Gen_Parameters_Profile (E : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (E); Parms : List_Id; + P : Node_Id; begin - -- Look for the constructor entities - - E := Next_Entity (Typ); - while Present (E) loop - if Ekind (E) = E_Function - and then Is_Constructor (E) - then - -- Create the init procedure - - Found := True; - Loc := Sloc (E); - Init := Make_Defining_Identifier (Loc, - Make_Init_Proc_Name (Typ)); - Parms := - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => - New_Reference_To (Typ, Loc))); - - if Present (Parameter_Specifications (Parent (E))) then - P := First (Parameter_Specifications (Parent (E))); - while Present (P) loop - Append_To (Parms, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Defining_Identifier (P))), - Parameter_Type => - New_Copy_Tree (Parameter_Type (P)))); - Next (P); - end loop; - end if; - - Discard_Node ( - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Init, - Parameter_Specifications => Parms))); - - Set_Init_Proc (Typ, Init); - Set_Is_Imported (Init); - Set_Is_Constructor (Init); - Set_Interface_Name (Init, Interface_Name (E)); - Set_Convention (Init, Convention_CPP); - Set_Is_Public (Init); - Set_Has_Completion (Init); - end if; - - Next_Entity (E); - end loop; - - -- If there are no constructors, mark the type as abstract since we - -- won't be able to declare objects of that type. - - if not Found then - Set_Is_Abstract_Type (Typ); + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + Parameter_Type => New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (P))), + Parameter_Type => New_Copy_Tree (Parameter_Type (P)), + Expression => New_Copy_Tree (Expression (P)))); + Next (P); + end loop; end if; - end Set_CPP_Constructors_Old; + + return Parms; + end Gen_Parameters_Profile; -- Local variables - Loc : Source_Ptr; - E : Entity_Id; - Found : Boolean := False; - P : Node_Id; - Parms : List_Id; + Loc : Source_Ptr; + E : Entity_Id; + Found : Boolean := False; + IP : Entity_Id; + IP_Body : Node_Id; + P : Node_Id; + Parms : List_Id; + + Covers_Default_Constructor : Entity_Id := Empty; - Constructor_Decl_Node : Node_Id; - Constructor_Id : Entity_Id; - Wrapper_Id : Entity_Id; - Wrapper_Body_Node : Node_Id; - Actuals : List_Id; - Body_Stmts : List_Id; - Init_Tags_List : List_Id; + -- Start of processing for Set_CPP_Constructor begin pragma Assert (Is_CPP_Class (Typ)); - -- For backward compatibility the compiler accepts C++ classes - -- imported through non-tagged record types. In such case the - -- wrapper of the C++ constructor is useless because the _tag - -- component is not available. - - -- Example: - -- type Root is limited record ... - -- pragma Import (CPP, Root); - -- function New_Root return Root; - -- pragma CPP_Constructor (New_Root, ... ); - - if not Is_Tagged_Type (Typ) then - Set_CPP_Constructors_Old (Typ); - return; - end if; - -- Look for the constructor entities E := Next_Entity (Typ); @@ -8539,154 +8507,178 @@ package body Exp_Disp is then Found := True; Loc := Sloc (E); + Parms := Gen_Parameters_Profile (E); + IP := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Typ)); + + -- Case 1: Constructor of non-tagged type + + -- If the C++ class has no virtual methods then the matching Ada + -- type is a non-tagged record type. In such case there is no need + -- to generate a wrapper of the C++ constructor because the _tag + -- component is not available. + + if not Is_Tagged_Type (Typ) then + Discard_Node + (Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => IP, + Parameter_Specifications => Parms))); + + Set_Init_Proc (Typ, IP); + Set_Is_Imported (IP); + Set_Is_Constructor (IP); + Set_Interface_Name (IP, Interface_Name (E)); + Set_Convention (IP, Convention_CPP); + Set_Is_Public (IP); + Set_Has_Completion (IP); + + -- Case 2: Constructor of a tagged type + + -- In this case we generate the IP as a wrapper of the the + -- C++ constructor because IP must also save copy of the _tag + -- generated in the C++ side. The copy of the _tag is used by + -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. - -- Generate the declaration of the imported C++ constructor - - Parms := - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uInit), - Parameter_Type => - New_Reference_To (Typ, Loc))); - - if Present (Parameter_Specifications (Parent (E))) then - P := First (Parameter_Specifications (Parent (E))); - while Present (P) loop - Append_To (Parms, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Defining_Identifier (P))), - Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); - Next (P); - end loop; - end if; - - Constructor_Id := Make_Temporary (Loc, 'P'); - - Constructor_Decl_Node := - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Constructor_Id, - Parameter_Specifications => Parms)); - - Set_Is_Imported (Constructor_Id); - Set_Is_Constructor (Constructor_Id); - Set_Interface_Name (Constructor_Id, Interface_Name (E)); - Set_Convention (Constructor_Id, Convention_CPP); - Set_Is_Public (Constructor_Id); - Set_Has_Completion (Constructor_Id); + -- Generate: + -- procedure IP (_init : Typ; ...) is + -- procedure ConstructorP (_init : Typ; ...); + -- pragma Import (ConstructorP); + -- begin + -- ConstructorP (_init, ...); + -- if Typ._tag = null then + -- Typ._tag := _init._tag; + -- end if; + -- end IP; - -- Build the wrapper of this constructor + else + declare + Body_Stmts : constant List_Id := New_List; + Constructor_Id : Entity_Id; + Constructor_Decl_Node : Node_Id; + Init_Tags_List : List_Id; - Parms := - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uInit), - Parameter_Type => - New_Reference_To (Typ, Loc))); - - if Present (Parameter_Specifications (Parent (E))) then - P := First (Parameter_Specifications (Parent (E))); - while Present (P) loop - Append_To (Parms, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Defining_Identifier (P))), - Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); - Next (P); - end loop; - end if; + begin + Constructor_Id := Make_Temporary (Loc, 'P'); - Body_Stmts := New_List; + Constructor_Decl_Node := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Constructor_Id, + Parameter_Specifications => Parms)); - -- Invoke the C++ constructor + Set_Is_Imported (Constructor_Id); + Set_Is_Constructor (Constructor_Id); + Set_Interface_Name (Constructor_Id, Interface_Name (E)); + Set_Convention (Constructor_Id, Convention_CPP); + Set_Is_Public (Constructor_Id); + Set_Has_Completion (Constructor_Id); - Actuals := New_List; + -- Build the init procedure as a wrapper of this constructor - P := First (Parms); - while Present (P) loop - Append_To (Actuals, - New_Reference_To (Defining_Identifier (P), Loc)); - Next (P); - end loop; + Parms := Gen_Parameters_Profile (E); - Append_To (Body_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Constructor_Id, Loc), - Parameter_Associations => Actuals)); + -- Invoke the C++ constructor - -- Initialize copies of C++ primary and secondary tags + declare + Actuals : constant List_Id := New_List; - Init_Tags_List := New_List; + begin + P := First (Parms); + while Present (P) loop + Append_To (Actuals, + New_Reference_To (Defining_Identifier (P), Loc)); + Next (P); + end loop; - declare - Tag_Elmt : Elmt_Id; - Tag_Comp : Node_Id; + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Constructor_Id, Loc), + Parameter_Associations => Actuals)); + end; - begin - Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); - Tag_Comp := First_Tag_Component (Typ); + -- Initialize copies of C++ primary and secondary tags - while Present (Tag_Elmt) - and then Is_Tag (Node (Tag_Elmt)) - loop - -- Skip the following assertion with primary tags because - -- Related_Type is not set on primary tag components + Init_Tags_List := New_List; - pragma Assert (Tag_Comp = First_Tag_Component (Typ) - or else Related_Type (Node (Tag_Elmt)) - = Related_Type (Tag_Comp)); + declare + Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; - Append_To (Init_Tags_List, - Make_Assignment_Statement (Loc, - Name => - New_Reference_To (Node (Tag_Elmt), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uInit), - Selector_Name => - New_Reference_To (Tag_Comp, Loc)))); + begin + Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); + Tag_Comp := First_Tag_Component (Typ); - Tag_Comp := Next_Tag_Component (Tag_Comp); - Next_Elmt (Tag_Elmt); - end loop; - end; + while Present (Tag_Elmt) + and then Is_Tag (Node (Tag_Elmt)) + loop + -- Skip the following assertion with primary tags + -- because Related_Type is not set on primary tag + -- components + + pragma Assert + (Tag_Comp = First_Tag_Component (Typ) + or else Related_Type (Node (Tag_Elmt)) + = Related_Type (Tag_Comp)); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Node (Tag_Elmt), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)))); - Append_To (Body_Stmts, - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Typ))), - Loc), - Right_Opnd => - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (RTE (RE_Null_Address), Loc))), - Then_Statements => Init_Tags_List)); + Tag_Comp := Next_Tag_Component (Tag_Comp); + Next_Elmt (Tag_Elmt); + end loop; + end; - Wrapper_Id := Make_Defining_Identifier (Loc, - Make_Init_Proc_Name (Typ)); + Append_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), + Loc), + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))), + Then_Statements => Init_Tags_List)); + + IP_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => IP, + Parameter_Specifications => Parms), + Declarations => New_List (Constructor_Decl_Node), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts, + Exception_Handlers => No_List)); + + Discard_Node (IP_Body); + Set_Init_Proc (Typ, IP); + end; + end if; - Wrapper_Body_Node := - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Wrapper_Id, - Parameter_Specifications => Parms), - Declarations => New_List (Constructor_Decl_Node), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Body_Stmts, - Exception_Handlers => No_List)); + -- If this constructor has parameters and all its parameters + -- have defaults then it covers the default constructor. The + -- semantic analyzer ensures that only one constructor with + -- defaults covers the default constructor. - Discard_Node (Wrapper_Body_Node); - Set_Init_Proc (Typ, Wrapper_Id); + if Present (Parameter_Specifications (Parent (E))) + and then Needs_No_Actuals (E) + then + Covers_Default_Constructor := IP; + end if; end if; Next_Entity (E); @@ -8699,6 +8691,49 @@ package body Exp_Disp is Set_Is_Abstract_Type (Typ); end if; + -- Handle constructor that has all its parameters with defaults and + -- hence it covers the default constructor. We generate a wrapper IP + -- which calls the covering constructor. + + if Present (Covers_Default_Constructor) then + declare + Body_Stmts : List_Id; + + begin + Loc := Sloc (Covers_Default_Constructor); + + Body_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Covers_Default_Constructor, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit)))); + + IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); + + IP_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => IP, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + Parameter_Type => New_Reference_To (Typ, Loc)))), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts, + Exception_Handlers => No_List)); + + Discard_Node (IP_Body); + Set_Init_Proc (Typ, IP); + end; + end if; + -- If the CPP type has constructors then it must import also the default -- C++ constructor. It is required for default initialization of objects -- of the type. It is also required to elaborate objects of Ada types |