checks.ads (Apply_Accessibility_Check): Add parameter Insert_Node.

2008-07-31  Gary Dismukes  <dismukes@adacore.com>

	* checks.ads (Apply_Accessibility_Check): Add parameter Insert_Node.

	* checks.adb (Apply_Accessibility_Check): Insert the check on
	Insert_Node.

	* exp_attr.adb:
	(Expand_N_Attribute_Refernce, Attribute_Access): Pass attribute node
	to new parameter Insert_Node on call to Apply_Accessibility_Check.
	Necessary to distinguish the insertion node because the dereferenced
	formal may come from a rename, but the check must be inserted in
	front of the attribute.

	* exp_ch4.adb:
	(Expand_N_Allocator): Pass actual for new Insert_Node parameter on
	call to Apply_Accessibility_Check.
	(Expand_N_Type_Conversion): Pass actual for new Insert_Node parameter
	on call to Apply_Accessibility_Check.
	Minor reformatting

From-SVN: r138399

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index aea61397dc98e24eefeec04537011859672a6fc0..6eb7ebbbbc3f27e185c6a6203bec90a0a5c7b125 100644 (file)
--- 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 0c9049471b40ac14303ab62f646c3c5ce8c02918..7b231473c8144fff5dfafb2d4bd60907f2540c66 100644 (file)
--- 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 6ad556852808f9af15ac931ea726df50a04510e1..84bc808b86f8a6063ce6d75708684be742295ff7 100644 (file)
--- 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 798da67036ee1f53bcf6f3fb6e65b1dd61148ec0..ba09aa69807a4a65bd84d3985d7b66e91719b0a2 100644 (file)
--- 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