===================================================================
@@ -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
===================================================================
@@ -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;
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 <kirtchev@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.