From: Samuel Tardieu Date: Wed, 13 Aug 2008 10:57:43 +0000 (+0000) Subject: re PR ada/36777 (Protected type cannot have access taken from its body.) X-Git-Tag: releases/gcc-4.4.0~3158 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=2d14501c4714ef2b4ab848d52d22a1c700804197;p=thirdparty%2Fgcc.git 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 5e5478fe77d3..bf3c7dd903d5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2008-08-13 Samuel Tardieu + + 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 * 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 890f09b1d822..80cd34d5593e 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 b3077df0df12..6a77fd1160c8 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 96e24a4c994a..e1d042c92c23 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 00c1e380d881..a8f7fc8dc333 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/ChangeLog b/gcc/testsuite/ChangeLog index 7fb2c7d4ed25..d036b781439e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-08-13 Samuel Tardieu + + PR ada/36777 + * gnat.dg/protected_self_ref1.adb, gnat.dg/protected_self_ref2.adb: + New. + 2008-08-13 Manuel Lopez-Ibanez 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 index 000000000000..b6c2aef6809b --- /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 000000000000..825c0cc40e79 --- /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;