re PR ada/36777 (Protected type cannot have access taken from its body.)

    gcc/ada/
	PR ada/36777
	* sem_util.ads, sem_util.adb (Is_Protected_Self_Reference): New.
	* sem_attr.adb (Check_Type): The current instance of a protected
	object is not a type name.
	(Analyze_Access_Attribute): Accept instances of protected objects.
	(Analyze_Attribute, Attribute_Address clause): Ditto.
	* exp_attr.adb (Expand_N_Attribute_Reference): Rewrite
	the prefix as being the current instance if needed.

    gcc/testsuite/
	PR ada/36777
	* gnat.dg/protected_self_ref1.adb, gnat.dg/protected_self_ref2.adb:
	New.

From-SVN: r139051

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5e5478fe77d3be397adf00e09f5effc3b6d7a7f3..bf3c7dd903d504e94c3442c1e4c34940c54e68d5 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2008-08-13  Samuel Tardieu  <sam@rfc1149.net>
+
+       PR ada/36777
+       * sem_util.ads, sem_util.adb (Is_Protected_Self_Reference): New.
+       * sem_attr.adb (Check_Type): The current instance of a protected
+       object is not a type name.
+       (Analyze_Access_Attribute): Accept instances of protected objects.
+       (Analyze_Attribute, Attribute_Address clause): Ditto.
+       * exp_attr.adb (Expand_N_Attribute_Reference): Rewrite
+       the prefix as being the current instance if needed.
+
 2008-08-12  Danny Smith  <danyssmith@users.sourceforge.net>
 
        * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) [WINDOWS]: Remove

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 890f09b1d8223d4012e3daae2d4663cce494a896..80cd34d5593e35ff0a0526d2aebc6222574c071d 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -636,6 +636,14 @@ package body Exp_Attr is
          Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
       end if;
 
+      --  If prefix is a protected type name, this is a reference to
+      --  the current instance of the type.
+
+      if Is_Protected_Self_Reference (Pref) then
+         Rewrite (Pref, Concurrent_Ref (Pref));
+         Analyze (Pref);
+      end if;
+
       --  Remaining processing depends on specific attribute
 
       case Id is

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index b3077df0df12b2b319d33067eef24164de6af519..6a77fd1160c87245d8a6306c5b04e9735ba29474 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -713,6 +713,12 @@ package body Sem_Attr is
                then
                   null;
 
+               --  OK if reference to the current instance of a protected
+               --  object.
+
+               elsif Is_Protected_Self_Reference (P) then
+                  null;
+
                --  Otherwise we have an error case
 
                else
@@ -1643,6 +1649,11 @@ package body Sem_Attr is
          then
             Error_Attr_P ("prefix of % attribute must be a type");
 
+         elsif Is_Protected_Self_Reference (P) then
+            Error_Attr_P
+              ("prefix of % attribute denotes current instance " &
+                 "(RM 9.4(21/2))");
+
          elsif Ekind (Entity (P)) = E_Incomplete_Type
             and then Present (Full_View (Entity (P)))
          then
@@ -2009,7 +2020,13 @@ package body Sem_Attr is
          --  An Address attribute created by expansion is legal even when it
          --  applies to other entity-denoting expressions.
 
-         if Is_Entity_Name (P) then
+         if Is_Protected_Self_Reference (P) then
+            --  An Address attribute on a protected object self reference
+            --  is legal.
+
+            null;
+
+         elsif Is_Entity_Name (P) then
             declare
                Ent : constant Entity_Id := Entity (P);
 

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 96e24a4c994aa27cc04f514c5ef5ac28c123eca3..e1d042c92c235fa53ec703005da0193f05e257fa 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6372,6 +6372,42 @@ package body Sem_Util is
       end if;
    end Is_Potentially_Persistent_Type;
 
+   ---------------------------------
+   -- Is_Protected_Self_Reference --
+   ---------------------------------
+
+   function Is_Protected_Self_Reference (N : Node_Id) return Boolean
+   is
+      function In_Access_Definition (N : Node_Id) return Boolean;
+      --  Returns true if N belongs to an access definition
+
+      --------------------------
+      -- In_Access_Definition --
+      --------------------------
+
+      function In_Access_Definition (N : Node_Id) return Boolean
+      is
+         P : Node_Id := Parent (N);
+      begin
+         while Present (P) loop
+            if Nkind (P) = N_Access_Definition then
+               return True;
+            end if;
+            P := Parent (P);
+         end loop;
+         return False;
+      end In_Access_Definition;
+
+   --  Start of processing for Is_Protected_Self_Reference
+
+   begin
+      return Ada_Version >= Ada_05
+        and then Is_Entity_Name (N)
+        and then Is_Protected_Type (Entity (N))
+        and then In_Open_Scopes (Entity (N))
+        and then not In_Access_Definition (N);
+   end Is_Protected_Self_Reference;
+
    -----------------------------
    -- Is_RCI_Pkg_Spec_Or_Body --
    -----------------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 00c1e380d8813bbc5fdf20a47220298311acfefb..a8f7fc8dc333bf98b378d4951fa5575cb9f76c3c 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -726,6 +726,10 @@ package Sem_Util is
    --  persistent. A private type is potentially persistent if the full type
    --  is potentially persistent.
 
+   function Is_Protected_Self_Reference (N : Node_Id) return Boolean;
+   --  Return True if node N denotes a protected type name which represents
+   --  the current instance of a protected object according to RM 9.4(21/2).
+
    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean;
    --  Return True if a compilation unit is the specification or the
    --  body of a remote call interface package.

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7fb2c7d4ed256c279ce5afc4c4eb80ae994025d2..d036b781439eafa35e8e68fb47302e04535bd089 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-08-13  Samuel Tardieu  <sam@rfc1149.net>
+
+       PR ada/36777
+       * gnat.dg/protected_self_ref1.adb, gnat.dg/protected_self_ref2.adb:
+       New.
+
 2008-08-13  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
        PR c/15236

diff --git a/gcc/testsuite/gnat.dg/protected_self_ref1.adb b/gcc/testsuite/gnat.dg/protected_self_ref1.adb
new file mode 100644 (file)
index 0000000..b6c2aef
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/protected_self_ref1.adb
@@ -0,0 +1,25 @@
+--  { dg-do run }
+with System;
+
+procedure Protected_Self_Ref1 is
+
+   protected type P is
+      procedure Foo;
+   end P;
+
+   protected body P is
+      procedure Foo is
+         Ptr : access P;  -- here P denotes the type P
+        T   : Integer;
+        A   : System.Address;
+      begin
+         Ptr := P'Access; -- here P denotes the "this" instance of P
+        T := P'Size;
+        A := P'Address;
+      end;
+   end P;
+
+   O : P;
+begin
+   O.Foo;
+end Protected_Self_Ref1;

diff --git a/gcc/testsuite/gnat.dg/protected_self_ref2.adb b/gcc/testsuite/gnat.dg/protected_self_ref2.adb
new file mode 100644 (file)
index 0000000..825c0cc
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/protected_self_ref2.adb
@@ -0,0 +1,18 @@
+--  { dg-do compile }
+procedure Protected_Self_Ref2 is
+
+   protected type P is
+      procedure Foo;
+   end P;
+
+   protected body P is
+      procedure Foo is
+        D : Integer;
+      begin
+         D := P'Digits;  -- { dg-error "denotes current instance" }
+      end;
+   end P;
+
+begin
+   null;
+end Protected_Self_Ref2;