Patchwork [Ada] Missing accessibility check

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 6, 2013, 11:20 a.m.
Message ID <20130206112047.GA14181@adacore.com>
Download mbox | patch
Permalink /patch/218553/
State New
Headers show

Comments

Arnaud Charlet - Feb. 6, 2013, 11:20 a.m.
This patch adds a missing case to the accessibility mechanism. The machinery
can now recognize a rewritten interface conversion and properly extract the
level of the operand.

------------
-- Source --
------------

--  types.ads

package Types is
   type Iface is limited interface;
   type Any_Iface_Ptr is access all Iface'Class;

   type Port_Type is tagged record
      Data : Any_Iface_Ptr;
   end record;

   procedure Connect (Port : in out Port_Type; Data : Any_Iface_Ptr);

   type Computer_Type is limited new Iface with record
      Port : Port_Type;
   end record;

   procedure Init_Ports (Comp : in out Computer_Type);
end Types;

--  types.adb

package body Types is
   procedure Connect (Port : in out Port_Type; Data : Any_Iface_Ptr) is
   begin
      Port.Data := Data;
   end Connect;

   procedure Init_Ports (Comp : in out Computer_Type) is
   begin
      Comp.Port.Connect (Iface (Comp)'Access);
   end Init_Ports;
end Types;

----------------------------
-- Compilation and output --
----------------------------

$ gcc -c -gnat05 types.adb
types.adb:9:26: non-local pointer cannot point to local object

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-02-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_util.adb (Is_Interface_Conversion): New routine.
	(Object_Access_Level): Detect an interface conversion
	that has been rewritten into a different construct. Use the
	original form of the conversion to find the access level of
	the operand.

Patch

Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 195798)
+++ sem_util.adb	(working copy)
@@ -11997,9 +11997,6 @@ 
    -- Object_Access_Level --
    -------------------------
 
-   function Object_Access_Level (Obj : Node_Id) return Uint is
-      E : Entity_Id;
-
    --  Returns the static accessibility level of the view denoted by Obj. Note
    --  that the value returned is the result of a call to Scope_Depth. Only
    --  scope depths associated with dynamic scopes can actually be returned.
@@ -12008,6 +12005,12 @@ 
    --  always one is immaterial (invariant: if level(E2) is deeper than
    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
 
+   function Object_Access_Level (Obj : Node_Id) return Uint is
+      function Is_Interface_Conversion (N : Node_Id) return Boolean;
+      --  Determine whether N is a construct of the form
+      --    Some_Type (Operand._tag'Address)
+      --  This construct appears in the context of dispatching calls
+
       function Reference_To (Obj : Node_Id) return Node_Id;
       --  An explicit dereference is created when removing side-effects from
       --  expressions for constraint checking purposes. In this case a local
@@ -12016,6 +12019,18 @@ 
       --  prefix of the dereference is created by an object declaration whose
       --  initial expression is a reference.
 
+      -----------------------------
+      -- Is_Interface_Conversion --
+      -----------------------------
+
+      function Is_Interface_Conversion (N : Node_Id) return Boolean is
+      begin
+         return
+           Nkind (N) = N_Unchecked_Type_Conversion
+             and then Nkind (Expression (N)) = N_Attribute_Reference
+             and then Attribute_Name (Expression (N)) = Name_Address;
+      end Is_Interface_Conversion;
+
       ------------------
       -- Reference_To --
       ------------------
@@ -12034,6 +12049,10 @@ 
          end if;
       end Reference_To;
 
+      --  Local variables
+
+      E : Entity_Id;
+
    --  Start of processing for Object_Access_Level
 
    begin
@@ -12104,7 +12123,17 @@ 
          then
             return Object_Access_Level (Prefix (Obj));
 
-         elsif not (Comes_From_Source (Obj)) then
+         --  Detect an interface conversion in the context of a dispatching
+         --  call. Use the original form of the conversion to find the access
+         --  level of the operand.
+
+         elsif Is_Interface (Etype (Obj))
+           and then Is_Interface_Conversion (Prefix (Obj))
+           and then Nkind (Original_Node (Obj)) = N_Type_Conversion
+         then
+            return Object_Access_Level (Original_Node (Obj));
+
+         elsif not Comes_From_Source (Obj) then
             declare
                Ref : constant Node_Id := Reference_To (Obj);
             begin
@@ -12119,9 +12148,7 @@ 
             return Type_Access_Level (Etype (Prefix (Obj)));
          end if;
 
-      elsif Nkind (Obj) = N_Type_Conversion
-        or else Nkind (Obj) = N_Unchecked_Type_Conversion
-      then
+      elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
          return Object_Access_Level (Expression (Obj));
 
       elsif Nkind (Obj) = N_Function_Call then