This patch ensures that Ada RM 6.3.1 13.1/3 which states
The calling convention for an anonymous access-to-subprogram parameter or
anonymous access-to-subprogram result is protected if the reserved word
protected appears in its definition; otherwise, it is the convention of
the subprogram that contains the parameter.
properly sets the convention of an anonymous access-to-subprogram type to that
of the related subprogram.
------------
-- Source --
------------
-- conventions.ads
package Conventions is
-----------------
-- Inherit Ada --
-----------------
procedure Ada_1 (Ptr : access procedure);
function Ada_2 return access procedure;
function Ada_3 return access procedure;
function Ada_4 return access procedure;
---------------
-- Inherit C --
---------------
procedure C_1 (Ptr : access procedure) with Convention => C;
function C_2 return access procedure with Convention => C;
function C_3 return access procedure with Convention => C;
function C_4 return access procedure with Convention => C;
-----------------------
-- Inherit Protected --
-----------------------
protected IP is
procedure Prot_1 (Ptr : access procedure);
function Prot_2 return access procedure;
function Prot_3 return access procedure;
function Prot_4 return access procedure;
end IP;
------------------------
-- Protected with Ada --
------------------------
procedure Prot_Ada_1 (Ptr : access protected procedure); -- OK
function Prot_Ada_2 return access protected procedure; -- OK
----------------------
-- Protected with C --
----------------------
procedure Prot_C_1 (Ptr : access protected procedure) -- OK
with Convention => C;
function Prot_C_2 return access protected procedure -- OK
with Convention => C;
------------------------------
-- Protected with Protected --
------------------------------
protected PP is
procedure Prot_1 (Ptr : access protected procedure); -- OK
function Prot_2 return access protected procedure; -- OK
function Prot_3 return access protected procedure; -- OK
function Prot_4 return access protected procedure; -- OK
end PP;
---------------
-- Renamings --
---------------
procedure Ren_Ada_1 (Ptr : access procedure) renames Ada_1;
function Ren_Ada_2 return access procedure renames Ada_2;
procedure Ren_C_1 (Ptr : access procedure) renames C_1;
function Ren_C_2 return access procedure renames C_2;
procedure Ren_Prot_1 (Ptr : access procedure) renames IP.Prot_1;
function Ren_Prot_2 return access procedure renames IP.Prot_2;
--------------
-- Nestings --
--------------
procedure Nest_Ada_1
(Ptr_1 : access procedure (Ptr_2 : access procedure));
function Nest_Ada_2
return access procedure (Ptr : access procedure);
function Nest_Ada_3
return access procedure (Ptr : access procedure);
function Nest_Ada_4
return access procedure (Ptr : access procedure);
procedure Nest_C_1
(Ptr_1 : access procedure (Ptr_2 : access procedure))
with Convention => C;
function Nest_C_2
return access procedure (Ptr : access procedure)
with Convention => C;
function Nest_C_3
return access procedure (Ptr : access procedure)
with Convention => C;
function Nest_C_4
return access procedure (Ptr : access procedure)
with Convention => C;
protected NP is
procedure Prot_1 (Ptr_1 : access procedure (Ptr_2 : access procedure));
function Prot_2 return access procedure (Ptr : access procedure);
function Prot_3 return access procedure (Ptr : access procedure);
function Prot_4 return access procedure (Ptr : access procedure);
end NP;
procedure Calls;
end Conventions;
-- conventions.adb
package body Conventions is
-- Specs
procedure Ada_Proc;
procedure Ada_Proc_Access (Ptr : access procedure);
procedure C_Proc with Convention => C;
procedure C_Proc_Access (Ptr : access procedure) with Convention => C;
protected P is
procedure Proc;
end P;
protected P_Access is
procedure Proc (Ptr : access procedure);
end P_Access;
-- Bodies
procedure Ada_Proc is
begin null; end Ada_Proc;
procedure Ada_Proc_Access (Ptr : access procedure) is
begin null; end Ada_Proc_Access;
procedure C_Proc is
begin null; end C_Proc;
procedure C_Proc_Access (Ptr : access procedure) is
begin null; end C_Proc_Access;
protected body P is
procedure Proc is begin null; end Proc;
end P;
protected body P_Access is
procedure Proc (Ptr : access procedure) is
begin null; end Proc;
end P_Access;
-----------------
-- Inherit Ada --
-----------------
procedure Ada_1 (Ptr : access procedure) is
begin null; end Ada_1;
function Ada_2 return access procedure is
begin
return Ada_Proc'Access; -- OK
end Ada_2;
function Ada_3 return access procedure is
begin
return C_Proc'Access; -- Error
end Ada_3;
function Ada_4 return access procedure is
begin
return P.Proc'Access; -- Error
end Ada_4;
---------------
-- Inherit C --
---------------
procedure C_1 (Ptr : access procedure) is
begin null; end C_1;
function C_2 return access procedure is
begin
return Ada_Proc'Access; -- Error
end C_2;
function C_3 return access procedure is
begin
return C_Proc'Access; -- OK
end C_3;
function C_4 return access procedure is
begin
return P.Proc'Access; -- Error
end C_4;
----------------------
-- Iherit Protected --
----------------------
protected body IP is
procedure Prot_1 (Ptr : access procedure) is
begin null; end Prot_1;
function Prot_2 return access procedure is
begin
return Ada_Proc'Access; -- OK
end Prot_2;
function Prot_3 return access procedure is
begin
return C_Proc'Access; -- Error
end Prot_3;
function Prot_4 return access procedure is
begin
return P.Proc'Access; -- Error
end Prot_4;
end IP;
------------------------
-- Protected with Ada --
------------------------
procedure Prot_Ada_1 (Ptr : access protected procedure) is
begin null; end Prot_Ada_1;
function Prot_Ada_2 return access protected procedure is
begin return null; end Prot_Ada_2;
----------------------
-- Protected with C --
----------------------
procedure Prot_C_1 (Ptr : access protected procedure) is
begin null; end Prot_C_1;
function Prot_C_2 return access protected procedure is
begin return null; end Prot_C_2;
------------------------------
-- Protected with Protected --
------------------------------
protected body PP is
procedure Prot_1 (Ptr : access protected procedure) is
begin null; end Prot_1;
function Prot_2 return access protected procedure is
begin return null; end Prot_2;
function Prot_3 return access protected procedure is
begin return null; end Prot_3;
function Prot_4 return access protected procedure is
begin return null; end Prot_4;
end PP;
--------------
-- Nestings --
--------------
procedure Nest_Ada_1
(Ptr_1 : access procedure (Ptr_2 : access procedure)) is
begin null; end Nest_Ada_1;
function Nest_Ada_2
return access procedure (Ptr : access procedure) is
begin
return Ada_Proc_Access'Access; -- OK
end Nest_Ada_2;
function Nest_Ada_3
return access procedure (Ptr : access procedure) is
begin
return C_Proc_Access'Access; -- Error
end Nest_Ada_3;
function Nest_Ada_4
return access procedure (Ptr : access procedure) is
begin
return P_Access.Proc'Access; -- Error
end Nest_Ada_4;
procedure Nest_C_1
(Ptr_1 : access procedure (Ptr_2 : access procedure)) is
begin null; end Nest_C_1;
function Nest_C_2
return access procedure (Ptr : access procedure) is
begin
return Ada_Proc_Access'Access; -- Error
end Nest_C_2;
function Nest_C_3
return access procedure (Ptr : access procedure) is
begin
return C_Proc_Access'Access; -- OK
end Nest_C_3;
function Nest_C_4
return access procedure (Ptr : access procedure) is
begin
return P_Access.Proc'Access; -- Error
end Nest_C_4;
protected body NP is
procedure Prot_1 (Ptr_1 : access procedure (Ptr_2 : access procedure)) is
begin null; end Prot_1;
function Prot_2 return access procedure (Ptr : access procedure) is
begin
return Ada_Proc_Access'Access; -- OK
end Prot_2;
function Prot_3 return access procedure (Ptr : access procedure) is
begin
return C_Proc_Access'Access; -- Error
end Prot_3;
function Prot_4 return access procedure (Ptr : access procedure) is
begin
return P_Access.Proc'Access; -- Error
end Prot_4;
end NP;
-----------
-- Calls --
-----------
procedure Calls is
begin
Ada_1 (Ada_Proc'Access); -- OK
Ada_1 (C_Proc'Access); -- Error
Ada_1 (P.Proc'Access); -- Error
C_1 (Ada_Proc'Access); -- Error
C_1 (C_Proc'Access); -- OK
C_1 (P.Proc'Access); -- Error
IP.Prot_1 (Ada_Proc'Access); -- OK
IP.Prot_1 (C_Proc'Access); -- Error
IP.Prot_1 (P.Proc'Access); -- Error
Ren_Ada_1 (Ada_Proc'Access); -- OK
Ren_Ada_1 (C_Proc'Access); -- Error
Ren_Ada_1 (P.Proc'Access); -- Error
Ren_C_1 (Ada_Proc'Access); -- Error
Ren_C_1 (C_Proc'Access); -- OK
Ren_C_1 (P.Proc'Access); -- Error
Ren_Prot_1 (Ada_Proc'Access); -- OK
Ren_Prot_1 (C_Proc'Access); -- Error
Ren_Prot_1 (P.Proc'Access); -- Error
Nest_Ada_1 (Ada_Proc_Access'Access); -- OK
Nest_Ada_1 (C_Proc_Access'Access); -- Error
Nest_Ada_1 (P_Access.Proc'Access); -- Error
Nest_C_1 (Ada_Proc_Access'Access); -- Error
Nest_C_1 (C_Proc_Access'Access); -- OK
Nest_C_1 (P_Access.Proc'Access); -- Error
NP.Prot_1 (Ada_Proc_Access'Access); -- OK
NP.Prot_1 (C_Proc_Access'Access); -- Error
NP.Prot_1 (P_Access.Proc'Access); -- Error
end Calls;
end Conventions;
----------------------------
-- Compilation and output --
----------------------------
$ gcc -c conventions.adb
conventions.adb:56:14: subprogram "C_Proc" has wrong convention
conventions.adb:56:14: does not match access to subprogram declared at
conventions.ads:9
conventions.adb:61:14: context requires a non-protected subprogram
conventions.adb:73:14: subprogram "Ada_Proc" has wrong convention
conventions.adb:73:14: does not match access to subprogram declared at
conventions.ads:17
conventions.adb:83:14: context requires a non-protected subprogram
conventions.adb:101:17: subprogram "C_Proc" has wrong convention
conventions.adb:101:17: does not match access to subprogram declared at
conventions.ads:28
conventions.adb:106:17: context requires a non-protected subprogram
conventions.adb:165:14: subprogram "C_Proc_Access" has wrong convention
conventions.adb:165:14: does not match access to subprogram declared at
conventions.ads:80
conventions.adb:171:14: context requires a non-protected subprogram
conventions.adb:181:14: subprogram "Ada_Proc_Access" has wrong convention
conventions.adb:181:14: does not match access to subprogram declared at
conventions.ads:88
conventions.adb:193:14: context requires a non-protected subprogram
conventions.adb:207:17: subprogram "C_Proc_Access" has wrong convention
conventions.adb:207:17: does not match access to subprogram declared at
conventions.ads:101
conventions.adb:212:17: context requires a non-protected subprogram
conventions.adb:223:14: subprogram "C_Proc" has wrong convention
conventions.adb:223:14: does not match access to subprogram declared at
conventions.ads:7
conventions.adb:224:14: context requires a non-protected subprogram
conventions.adb:226:12: subprogram "Ada_Proc" has wrong convention
conventions.adb:226:12: does not match access to subprogram declared at
conventions.ads:16
conventions.adb:228:12: context requires a non-protected subprogram
conventions.adb:231:18: subprogram "C_Proc" has wrong convention
conventions.adb:231:18: does not match access to subprogram declared at
conventions.ads:26
conventions.adb:232:18: context requires a non-protected subprogram
conventions.adb:235:18: subprogram "C_Proc" has wrong convention
conventions.adb:235:18: does not match access to subprogram declared at
conventions.ads:7
conventions.adb:236:18: context requires a non-protected subprogram
conventions.adb:238:16: subprogram "Ada_Proc" has wrong convention
conventions.adb:238:16: does not match access to subprogram declared at
conventions.ads:16
conventions.adb:240:16: context requires a non-protected subprogram
conventions.adb:243:19: subprogram "C_Proc" has wrong convention
conventions.adb:243:19: does not match access to subprogram declared at
conventions.ads:26
conventions.adb:244:19: context requires a non-protected subprogram
conventions.adb:247:19: subprogram "C_Proc_Access" has wrong convention
conventions.adb:247:19: does not match access to subprogram declared at
conventions.ads:76
conventions.adb:248:19: context requires a non-protected subprogram
conventions.adb:250:17: subprogram "Ada_Proc_Access" has wrong convention
conventions.adb:250:17: does not match access to subprogram declared at
conventions.ads:85
conventions.adb:252:17: context requires a non-protected subprogram
conventions.adb:255:18: subprogram "C_Proc_Access" has wrong convention
conventions.adb:255:18: does not match access to subprogram declared at
conventions.ads:99
conventions.adb:256:18: context requires a non-protected subprogram
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-23 Hristian Kirtchev <kirtc...@adacore.com>
* freeze.adb (Freeze_Subprogram): Ensure that all anonymous
access-to-subprogram types inherit the convention of the
associated subprogram. (Set_Profile_Convention): New routine.
* sem_ch6.adb (Check_Conformance): Do not compare the conventions
of the two entities directly, use Conventions_Match to account
for anonymous access-to-subprogram and subprogram types.
(Conventions_Match): New routine.
Index: freeze.adb
===================================================================
--- freeze.adb (revision 244773)
+++ freeze.adb (working copy)
@@ -7945,17 +7945,69 @@
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id);
+ -- Set the conventions of all anonymous access-to-subprogram formals and
+ -- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+
+ ----------------------------
+ -- Set_Profile_Convention --
+ ----------------------------
+
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id) is
+ Conv : constant Convention_Id := Convention (Subp_Id);
+
+ procedure Set_Type_Convention (Typ : Entity_Id);
+ -- Set the convention of anonymous access-to-subprogram type Typ and
+ -- its designated type to Conv.
+
+ -------------------------
+ -- Set_Type_Convention --
+ -------------------------
+
+ procedure Set_Type_Convention (Typ : Entity_Id) is
+ begin
+ -- Set the convention on both the anonymous access-to-subprogram
+ -- type and the subprogram type it points to because both types
+ -- participate in conformance-related checks.
+
+ if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+ Set_Convention (Typ, Conv);
+ Set_Convention (Designated_Type (Typ), Conv);
+ end if;
+ end Set_Type_Convention;
+
+ -- Local variables
+
+ Formal : Entity_Id;
+
+ -- Start of processing for Set_Profile_Convention
+
+ begin
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Set_Type_Convention (Etype (Formal));
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (Subp_Id) = E_Function then
+ Set_Type_Convention (Etype (Subp_Id));
+ end if;
+ end Set_Profile_Convention;
+
+ -- Local variables
+
+ F : Entity_Id;
Retype : Entity_Id;
- F : Entity_Id;
+ -- Start of processing for Freeze_Subprogram
+
begin
-- Subprogram may not have an address clause unless it is imported
if Present (Address_Clause (E)) then
if not Is_Imported (E) then
Error_Msg_N
- ("address clause can only be given " &
- "for imported subprogram",
+ ("address clause can only be given for imported subprogram",
Name (Address_Clause (E)));
end if;
end if;
@@ -7986,8 +8038,8 @@
-- referenced data may change even if the address value does not.
-- Note that if the programmer gave an explicit Pure_Function pragma,
- -- then we believe the programmer, and leave the subprogram Pure.
- -- We also suppress this check on run-time files.
+ -- then we believe the programmer, and leave the subprogram Pure. We
+ -- also suppress this check on run-time files.
if Is_Pure (E)
and then Is_Subprogram (E)
@@ -7997,6 +8049,20 @@
Check_Function_With_Address_Parameter (E);
end if;
+ -- Ensure that all anonymous access-to-subprogram types inherit the
+ -- covention of their related subprogram (RM 6.3.1 13.1/3). This is
+ -- not done for a defaulted convention Ada because those types also
+ -- default to Ada. Convention Protected must not be propagated when
+ -- the subprogram is an entry because this would be illegal. The only
+ -- way to force convention Protected on these kinds of types is to
+ -- include keyword "protected" in the access definition.
+
+ if Convention (E) /= Convention_Ada
+ and then Convention (E) /= Convention_Protected
+ then
+ Set_Profile_Convention (E);
+ end if;
+
-- For non-foreign convention subprograms, this is where we create
-- the extra formals (for accessibility level and constrained bit
-- information). We delay this till the freeze point precisely so
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 244773)
+++ sem_ch6.adb (working copy)
@@ -4870,6 +4870,12 @@
-- in the message, and also provides the location for posting the
-- message in the absence of a specified Err_Loc location.
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean;
+ -- Determine whether the conventions of arbitrary entities Id1 and Id2
+ -- match.
+
-----------------------
-- Conformance_Error --
-----------------------
@@ -4929,6 +4935,35 @@
end if;
end Conformance_Error;
+ -----------------------
+ -- Conventions_Match --
+ -----------------------
+
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean
+ is
+ begin
+ -- Ignore the conventions of anonymous access-to-subprogram types
+ -- and subprogram types because these are internally generated and
+ -- the only way these may receive a convention is if they inherit
+ -- the convention of a related subprogram.
+
+ if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ or else
+ Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ then
+ return True;
+
+ -- Otherwise compare the conventions directly
+
+ else
+ return Convention (Id1) = Convention (Id2);
+ end if;
+ end Conventions_Match;
+
-- Local Variables
Old_Type : constant Entity_Id := Etype (Old_Id);
@@ -5015,7 +5050,7 @@
-- entity is inherited.
if Ctype >= Subtype_Conformant then
- if Convention (Old_Id) /= Convention (New_Id) then
+ if not Conventions_Match (Old_Id, New_Id) then
if not Is_Frozen (New_Id) then
null;
