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;
