diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index aea61397dc98..6eb7ebbbbc3f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -470,7 +470,11 @@ package body Checks is -- Apply_Accessibility_Check -- ------------------------------- - procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is + procedure Apply_Accessibility_Check + (N : Node_Id; + Typ : Entity_Id; + Insert_Node : Node_Id) + is Loc : constant Source_Ptr := Sloc (N); Param_Ent : constant Entity_Id := Param_Entity (N); Param_Level : Node_Id; @@ -501,7 +505,7 @@ package body Checks is -- Raise Program_Error if the accessibility level of the the access -- parameter is deeper than the level of the target access type. - Insert_Action (N, + Insert_Action (Insert_Node, Make_Raise_Program_Error (Loc, Condition => Make_Op_Gt (Loc, diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 0c9049471b40..7b231473c814 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -102,11 +102,15 @@ package Checks is -- Determines whether an expression node requires a runtime access -- check and if so inserts the appropriate run-time check. - procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id); + procedure Apply_Accessibility_Check + (N : Node_Id; + Typ : Entity_Id; + Insert_Node : Node_Id); -- Given a name N denoting an access parameter, emits a run-time -- accessibility check (if necessary), checking that the level of -- the object denoted by the access parameter is not deeper than the -- level of the type Typ. Program_Error is raised if the check fails. + -- Insert_Node indicates the node where the check should be inserted. procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id); -- E is the entity for an object which has an address clause. If checks diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6ad556852808..84bc808b86f8 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -840,7 +840,10 @@ package body Exp_Attr is -- attribute was the dereference, and didn't handle cases where -- the attribute is applied to a subcomponent of the dereference, -- since there's generally no available, appropriate access type - -- to convert to in that case. + -- to convert to in that case. The attribute is passed as the + -- point to insert the check, because the access parameter may + -- come from a renaming, possibly in a different scope, and the + -- check must be associated with the attribute itself. elsif Id = Attribute_Access and then Nkind (Enc_Object) = N_Explicit_Dereference @@ -852,7 +855,7 @@ package body Exp_Attr is and then Present (Extra_Accessibility (Entity (Prefix (Enc_Object)))) then - Apply_Accessibility_Check (Prefix (Enc_Object), Typ); + Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); -- Ada 2005 (AI-251): If the designated type is an interface we -- add an implicit conversion to force the displacement of the diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 798da67036ee..ba09aa69807a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3440,7 +3440,8 @@ package body Exp_Ch4 is and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type then - Apply_Accessibility_Check (Nod, Typ); + Apply_Accessibility_Check + (Nod, Typ, Insert_Node => Nod); end if; Next_Elmt (Discr); @@ -7552,9 +7553,9 @@ package body Exp_Ch4 is -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was - -- expanded from an unchecked or unrestricted access attribute. Note - -- that other checks may still need to be applied below (such as - -- tagged type checks). + -- expanded from an Unchecked_ or Unrestricted_Access attribute. + -- Note that other checks may still need to be applied below (such + -- as tagged type checks). if Is_Entity_Name (Operand) and then @@ -7568,9 +7569,10 @@ package body Exp_Ch4 is and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) then - Apply_Accessibility_Check (Operand, Target_Type); + Apply_Accessibility_Check + (Operand, Target_Type, Insert_Node => Operand); - -- If the level of the operand type is statically deeper then the + -- If the level of the operand type is statically deeper than the -- level of the target type, then force Program_Error. Note that this -- can only occur for cases where the attribute is within the body of -- an instantiation (otherwise the conversion will already have been