Fix a bug in which a call of the form X.Y (the prefix notation of Y(X)) where X is of a reference type (i.e. a type with the Implicit_Dereference aspect specified), and the access discriminant of X has a designated type that is also an access type, incorrectly gets compilation errors.
Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ 2017-09-18 Bob Duff <d...@adacore.com> * sem_ch4.adb (Complete_Object_Operation): Do not insert 'Access for reference types in the access-to-access case. gcc/testsuite/ 2017-09-18 Bob Duff <d...@adacore.com> * gnat.dg/tagged_prefix_call.adb: New testcase.
Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 252913) +++ sem_ch4.adb (working copy) @@ -8554,14 +8554,21 @@ ("expect variable in call to&", Prefix (N), Entity (Subprog)); end if; - -- Conversely, if the formal is an access parameter and the object - -- is not, replace the actual with a 'Access reference. Its analysis - -- will check that the object is aliased. + -- Conversely, if the formal is an access parameter and the object is + -- not an access type or a reference type (i.e. a type with the + -- Implicit_Dereference aspect specified), replace the actual with a + -- 'Access reference. Its analysis will check that the object is + -- aliased. elsif Is_Access_Type (Formal_Type) and then not Is_Access_Type (Etype (Obj)) + and then (not Has_Implicit_Dereference (Etype (Obj)) + or else + not Is_Access_Type + (Designated_Type + (Etype (Get_Reference_Discriminant (Etype (Obj)))))) then - -- A special case: A.all'access is illegal if A is an access to a + -- A special case: A.all'Access is illegal if A is an access to a -- constant and the context requires an access to a variable. if not Is_Access_Constant (Formal_Type) then Index: ../testsuite/gnat.dg/tagged_prefix_call.adb =================================================================== --- ../testsuite/gnat.dg/tagged_prefix_call.adb (revision 0) +++ ../testsuite/gnat.dg/tagged_prefix_call.adb (revision 0) @@ -0,0 +1,24 @@ +-- { dg-do compile } + +procedure Tagged_Prefix_Call is + + package Defs is + type Database_Connection_Record is abstract tagged null record; + type Database_Connection is access all Database_Connection_Record'Class; + + procedure Start_Transaction + (Self : not null access Database_Connection_Record'Class) + is null; + + type DB_Connection (Elem : access Database_Connection) + is null record + with Implicit_Dereference => Elem; + end Defs; + + use Defs; + + DB : DB_Connection(null); + +begin + DB.Start_Transaction; +end Tagged_Prefix_Call;