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

5 files changed, 77 insertions, 1 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5e5478f..bf3c7dd 100644
--- 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 890f09b..80cd34d 100644
--- 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 b3077df..6a77fd1 100644
--- 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 96e24a4..e1d042c 100644
--- 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 00c1e38..a8f7fc8 100644
--- 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.