diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 396c8914f9a..9b5d0fba73a 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -1169,7 +1169,8 @@ package body Accessibility is Insert_Action (N, Make_Implicit_If_Statement (N, Condition => Cond, - Then_Statements => Stmts)); + Then_Statements => Stmts), + Suppress => All_Checks); end if; end Apply_Accessibility_Check_For_Allocator; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9c293f47814..b156de6ee05 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3688,7 +3688,7 @@ package Einfo is -- having Has_Machine_Radix_Clause True. This happens when a type is -- derived from a type with a clause present. --- Master_Id +-- Master_Id [root type only] -- Defined in access types and subtypes. Empty unless Has_Task is set for -- the designated type, in which case it points to the entity for the -- Master_Id for the access type master. Also set for access-to-limited- @@ -5252,7 +5252,7 @@ package Einfo is -- E_Access_Type -- E_Access_Subtype -- Direct_Primitive_Operations $$$ type - -- Master_Id + -- Master_Id (root type only) -- Directly_Designated_Type -- Associated_Storage_Pool (root type only) -- Finalization_Collection (root type only) @@ -5704,7 +5704,7 @@ package Einfo is -- E_General_Access_Type -- First_Entity $$$ -- Renamed_Entity $$$ - -- Master_Id + -- Master_Id (root type only) -- Directly_Designated_Type -- Associated_Storage_Pool (root type only) -- Finalization_Collection (root type only) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 843dc173c25..12cbd58a42b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2564,8 +2564,7 @@ package body Exp_Ch3 is Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level)); elsif Present (Target_Ref) then Append_To (Args, - New_Occurrence_Of - (Master_Id (Base_Type (Root_Type (Etype (Target_Ref)))), Loc)); + New_Occurrence_Of (Master_Id (Etype (Target_Ref)), Loc)); else Append_To (Args, Make_Identifier (Loc, Name_uMaster)); end if; @@ -6882,8 +6881,8 @@ package body Exp_Ch3 is -- but testing Comes_From_Source may be too general in this case -- (affects some test output)??? - elsif not Is_Param_Block_Component_Type (Ptr_Typ) - and then Is_Limited_Class_Wide_Type (Desig_Typ) + elsif Is_Limited_Class_Wide_Type (Desig_Typ) + and then not Is_Param_Block_Component_Type (Ptr_Typ) then Build_Master_Entity (N); Build_Master_Renaming (Ptr_Typ); @@ -6901,7 +6900,9 @@ package body Exp_Ch3 is begin if Is_Access_Type (Def_Id) then - Build_Master (Def_Id); + if Nkind (Type_Definition (N)) /= N_Derived_Type_Definition then + Build_Master (Def_Id); + end if; if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then Expand_Access_Protected_Subprogram_Type (N); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2763aed4f9a..1bad0f9a3c8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4976,7 +4976,7 @@ package body Exp_Ch4 is -- created when expanding the function declaration. if Has_Task (Etyp) then - if No (Master_Id (Base_Type (PtrT))) then + if No (Master_Id (PtrT)) then -- The designated type was an incomplete type, and the -- access type did not get expanded. Salvage it now. diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 716c1d33f7a..60de3aa27d8 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -652,7 +652,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Local_Anonymous_Access, Flag), Sm (Is_Param_Block_Component_Type, Flag, Base_Type_Only), Sm (Is_Pure_Unit_Access_Type, Flag), - Sm (Master_Id, Node_Id), + Sm (Master_Id, Node_Id, Root_Type_Only), Sm (No_Pool_Assigned, Flag, Root_Type_Only), Sm (No_Strict_Aliasing, Flag, Base_Type_Only), Sm (Storage_Size_Variable, Node_Id, Impl_Base_Type_Only))); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 08d45ebca33..028e170021e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4513,51 +4513,47 @@ package body Sem_Res is end if; end if; - -- (Ada 2005: AI-251): If the actual is an allocator whose - -- directly designated type is a class-wide interface, we build - -- an anonymous access type to use it as the type of the - -- allocator. Later, when the subprogram call is expanded, if - -- the interface has a secondary dispatch table the expander - -- will add a type conversion to force the correct displacement - -- of the pointer. - if Nkind (A) = N_Allocator then declare DDT : constant Entity_Id := Directly_Designated_Type (Base_Type (Etype (F))); begin - -- Displace the pointer to the object to reference its - -- secondary dispatch table. + -- Ada 2005, AI-251: If the actual is an allocator whose + -- directly designated type is a class-wide interface, we + -- build a type conversion to force the displacement of + -- the pointer to reference the secondary dispatch table. + -- Note that we need to resolve the allocator explicitly, + -- otherwise its E_Allocator_Type will never be replaced, + -- since it's now the operand of a type conversion. if Is_Class_Wide_Type (DDT) and then Is_Interface (DDT) then - Rewrite (A, Convert_To (Etype (F), Relocate_Node (A))); + Convert_To_And_Rewrite (Etype (F), A); Flag_Interface_Pointer_Displacement (A); - - Analyze_And_Resolve (A, Etype (F), - Suppress => Access_Check); + Resolve (Expression (A), Etype (F)); + Analyze_And_Resolve + (A, Etype (F), Suppress => Access_Check); end if; - -- Ada 2005, AI-162:If the actual is an allocator, the - -- innermost enclosing statement is the master of the - -- created object. This needs to be done with expansion - -- enabled only, otherwise the transient scope will not - -- be removed in the expansion of the wrapped construct. + -- Ada 2005, AI-162: If the actual of an access parameter + -- is an allocator, the innermost enclosing statement is + -- the master of the created object. When the expander is + -- active, establish a transient scope to embody it. - if Expander_Active - and then (Needs_Finalization (DDT) - or else Has_Task (DDT)) - then - Establish_Transient_Scope - (A, Manage_Sec_Stack => False); + if Ekind (Etype (F)) = E_Anonymous_Access_Type then + Check_Restriction (No_Access_Parameter_Allocators, A); + + if Expander_Active + and then (Needs_Finalization (DDT) + or else Might_Have_Tasks (DDT)) + then + Establish_Transient_Scope + (A, Manage_Sec_Stack => False); + end if; end if; end; - - if Ekind (Etype (F)) = E_Anonymous_Access_Type then - Check_Restriction (No_Access_Parameter_Allocators, A); - end if; end if; -- (Ada 2005): The call may be to a primitive operation of a