[PATCH] ada/36777: A protected type may denote the current protected object
Samuel Tardieu
sam@rfc1149.net
Sun Aug 3 15:01:00 GMT 2008
According to RM 9.4(21/2), within the declaration or body of a
protected object other than in an access_definition, the name of
the protected type denotes the current instance.
This patch allows attributes to be applied properly in this case.
The prefix is rewritten to the current instance when appropriate,
and an error message is issued when an instance is used instead
of a type.
The "protected_self_ref1.adb" should compile and run without error,
while "protected_self_ref2.adb" will issue the following error:
12. D := P'Digits;
|
>>> prefix of "Digits" attribute denotes current instance (RM 9.4(21/2))
Tested on i686-pc-linux-gnu. Ok for trunk?
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.
---
gcc/ada/exp_attr.adb | 8 +++++
gcc/ada/sem_attr.adb | 19 ++++++++++++-
gcc/ada/sem_util.adb | 36 +++++++++++++++++++++++++
gcc/ada/sem_util.ads | 4 +++
gcc/testsuite/gnat.dg/protected_self_ref1.adb | 25 +++++++++++++++++
gcc/testsuite/gnat.dg/protected_self_ref2.adb | 18 ++++++++++++
6 files changed, 109 insertions(+), 1 deletions(-)
create mode 100644 gcc/testsuite/gnat.dg/protected_self_ref1.adb
create mode 100644 gcc/testsuite/gnat.dg/protected_self_ref2.adb
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 8e0a83b..2814f85 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -635,6 +635,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 4b59915..89a1474 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -710,6 +710,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
@@ -1623,6 +1629,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
@@ -1989,7 +2000,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 e8823b6..3ad181b 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.
diff --git a/gcc/testsuite/gnat.dg/protected_self_ref1.adb b/gcc/testsuite/gnat.dg/protected_self_ref1.adb
new file mode 100644
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
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;
--
1.6.0.rc0.182.gb96c7
More information about the Gcc-patches
mailing list