This patch adds some minor missing support for aspect Synchronization which is
later transformed into pragma Implemented by the expander.
------------
-- Source --
------------
-- checks.ads
package Checks is
type Synch_Iface is synchronized interface;
procedure With_Entry
(Obj : in out Synch_Iface;
Val : Integer) is abstract
with Synchronization => By_Entry;
procedure With_Procedure
(Obj : in out Synch_Iface;
Val : Integer) is abstract
with Synchronization => By_Protected_Procedure;
procedure With_Optional
(Obj : in out Synch_Iface;
Val : Integer) is abstract
with Synchronization => Optional;
protected type Prot_1 is new Synch_Iface with
entry With_Entry (Val : Integer);
entry With_Procedure (Val : Integer); -- Illegal
entry With_Optional (Val : Integer);
end Prot_1;
protected type Prot_2 is new Synch_Iface with
procedure With_Entry (Val : Integer); -- Illegal
procedure With_Procedure (Val : Integer);
procedure With_Optional (Val : Integer);
end Prot_2;
task type Task_1 is new Synch_Iface with
entry With_Entry (Val : Integer);
entry With_Procedure (Val : Integer); -- Illegal
entry With_Optional (Val : Integer);
end Task_1;
task type Task_2 is new Synch_Iface with
entry Dummy;
end Task_2;
procedure With_Entry (Obj : in out Task_2; Val : Integer); -- Illegal
procedure With_Procedure (Obj : in out Task_2; Val : Integer); -- Illegal
procedure With_Optional (Obj : in out Task_2; Val : Integer);
end Checks;
-- checks.adb
package body Checks is
protected body Prot_1 is
entry With_Entry (Val : Integer) when True is
begin
null;
end With_Entry;
entry With_Procedure (Val : Integer) when True is
begin
null;
end With_Procedure;
entry With_Optional (Val : Integer) when True is
begin
null;
end With_Optional;
end Prot_1;
protected body Prot_2 is
procedure With_Entry (Val : Integer) is
begin
null;
end With_Entry;
procedure With_Procedure (Val : Integer) is
begin
null;
end With_Procedure;
procedure With_Optional (Val : Integer) is
begin
null;
end With_Optional;
end Prot_2;
task body Task_1 is
begin
select
accept With_Entry (Val : Integer) do
null;
end With_Entry;
or
accept With_Procedure (Val : Integer) do
null;
end With_Procedure;
or
accept With_Optional (Val : Integer) do
null;
end With_Optional;
or
terminate;
end select;
end Task_1;
task body Task_2 is
begin
accept Dummy;
end Task_2;
procedure With_Entry (Obj : in out Task_2; Val : Integer) is
begin
null;
end With_Entry;
procedure With_Procedure (Obj : in out Task_2; Val : Integer) is
begin
null;
end With_Procedure;
procedure With_Optional (Obj : in out Task_2; Val : Integer) is
begin
null;
end With_Optional;
end Checks;
-------------------------------------
-- Compilation and expected output --
-------------------------------------
$ gnatmake -q -gnat12 checks.adb
$ checks.ads:19:13: type "Prot_1" must implement abstract subprogram
"With_Procedure" with a procedure
$ checks.ads:24:17: type "Prot_2" must implement abstract subprogram
"With_Entry" with an entry
$ checks.ads:31:13: interface subprogram "With_Procedure" cannot be implemented
by a primitive procedure of task type "Task_1"
$ checks.ads:38:14: type "Task_2" must implement abstract subprogram
"With_Entry" with an entry
$ checks.ads:39:14: interface subprogram "With_Procedure" cannot be implemented
by a primitive procedure of task type "Task_2"
$ gnatmake: "checks.adb" compilation error
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-01-23 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch9.adb: Update the comments involving pragma Implemented.
* sem_ch3.adb (Check_Pragma_Implemented (Entity_Id)): Add local
constant Subp_Alias and local variable Impl_Subp. Properly
handle aliases of synchronized wrappers. Code cleanup.
(Check_Pragma_Implemented (Entity_Id; Entity_Id)): Add
Name_Optional as part of the condition.
* sem_prag.adb (Analyze_Pragma): Add "Optional" as one of the
valid choices of implementation kind.
(Check_Arg_Is_One_Of): New routine.
* snames.ads-tmlp: Add Name_Optional.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 183412)
+++ exp_ch9.adb (working copy)
@@ -8878,7 +8878,8 @@
-- Target.Primitive (Param1, ..., ParamN);
-- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
- -- marked by pragma Implemented (XXX, By_Any) or not marked at all.
+ -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
+ -- at all.
-- declare
-- S : constant Offset_Index :=
@@ -8923,9 +8924,9 @@
function Build_Dispatching_Requeue_To_Any return Node_Id;
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
-- the form Concval.Ename. Ename is either marked by pragma Implemented
- -- (XXX, By_Any) or not marked at all. Create a block which determines
- -- at runtime whether Ename denotes an entry or a procedure and perform
- -- the appropriate kind of dispatching select.
+ -- (XXX, By_Any | Optional) or not marked at all. Create a block which
+ -- determines at runtime whether Ename denotes an entry or a procedure
+ -- and perform the appropriate kind of dispatching select.
function Build_Normal_Requeue return Node_Id;
-- N denotes a non-dispatching requeue statement to either a task or a
@@ -9445,9 +9446,10 @@
Analyze (N);
-- The procedure_or_entry_NAME's implementation kind is either
- -- By_Any or pragma Implemented was not applied at all. In this
- -- case a runtime test determines whether Ename denotes an entry
- -- or a protected procedure and performs the appropriate call.
+ -- By_Any, Optional, or pragma Implemented was not applied at all.
+ -- In this case a runtime test determines whether Ename denotes an
+ -- entry or a protected procedure and performs the appropriate
+ -- call.
else
Rewrite (N, Build_Dispatching_Requeue_To_Any);
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 183406)
+++ sem_ch3.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -8897,17 +8897,27 @@
procedure Check_Pragma_Implemented (Subp : Entity_Id) is
Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
+ Subp_Alias : constant Entity_Id := Alias (Subp);
Contr_Typ : Entity_Id;
+ Impl_Subp : Entity_Id;
begin
-- Subp must have an alias since it is a hidden entity used to link
-- an interface subprogram to its overriding counterpart.
- pragma Assert (Present (Alias (Subp)));
+ pragma Assert (Present (Subp_Alias));
+ -- Handle aliases to synchronized wrappers
+
+ Impl_Subp := Subp_Alias;
+
+ if Is_Primitive_Wrapper (Impl_Subp) then
+ Impl_Subp := Wrapped_Entity (Impl_Subp);
+ end if;
+
-- Extract the type of the controlling formal
- Contr_Typ := Etype (First_Formal (Alias (Subp)));
+ Contr_Typ := Etype (First_Formal (Subp_Alias));
if Is_Concurrent_Record_Type (Contr_Typ) then
Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
@@ -8917,12 +8927,12 @@
-- be implemented by an entry.
if Impl_Kind = Name_By_Entry
- and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
+ and then Ekind (Impl_Subp) /= E_Entry
then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with an entry",
- Alias (Subp), Contr_Typ);
+ Subp_Alias, Contr_Typ);
elsif Impl_Kind = Name_By_Protected_Procedure then
@@ -8934,19 +8944,17 @@
Error_Msg_Node_2 := Contr_Typ;
Error_Msg_NE
("interface subprogram & cannot be implemented by a " &
- "primitive procedure of task type &", Alias (Subp),
+ "primitive procedure of task type &", Subp_Alias,
Iface_Alias);
-- An interface subprogram whose implementation kind is By_
-- Protected_Procedure must be implemented by a procedure.
- elsif Is_Primitive_Wrapper (Alias (Subp))
- and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
- then
+ elsif Ekind (Impl_Subp) /= E_Procedure then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with a " &
- "procedure", Alias (Subp), Contr_Typ);
+ "procedure", Subp_Alias, Contr_Typ);
end if;
end if;
end Check_Pragma_Implemented;
@@ -8966,10 +8974,11 @@
-- Ada 2012 (AI05-0030): The implementation kinds of an overridden
-- and overriding subprogram are different. In general this is an
-- error except when the implementation kind of the overridden
- -- subprograms is By_Any.
+ -- subprograms is By_Any or Optional.
if Iface_Kind /= Subp_Kind
and then Iface_Kind /= Name_By_Any
+ and then Iface_Kind /= Name_Optional
then
if Iface_Kind = Name_By_Entry then
Error_Msg_N
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 183407)
+++ sem_prag.adb (working copy)
@@ -473,6 +473,9 @@
N1, N2, N3 : Name_Id);
procedure Check_Arg_Is_One_Of
(Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
N1, N2, N3, N4, N5 : Name_Id);
-- Check the specified argument Arg to make sure that it is an
-- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
@@ -1178,6 +1181,24 @@
procedure Check_Arg_Is_One_Of
(Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if Chars (Argx) /= N1
+ and then Chars (Argx) /= N2
+ and then Chars (Argx) /= N3
+ and then Chars (Argx) /= N4
+ then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
N1, N2, N3, N4, N5 : Name_Id)
is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
@@ -9325,8 +9346,12 @@
-----------------
-- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
- -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
+ -- implementation_kind ::=
+ -- By_Entry | By_Protected_Procedure | By_Any | Optional
+ -- "By_Any" and "Optional" are treated as synonyms in order to
+ -- support Ada 2012 aspect Synchronization.
+
when Pragma_Implemented => Implemented : declare
Proc_Id : Entity_Id;
Typ : Entity_Id;
@@ -9337,8 +9362,11 @@
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Check_Arg_Is_One_Of
- (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+ Check_Arg_Is_One_Of (Arg2,
+ Name_By_Any,
+ Name_By_Entry,
+ Name_By_Protected_Procedure,
+ Name_Optional);
-- Extract the name of the local procedure
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 183411)
+++ snames.ads-tmpl (working copy)
@@ -678,6 +678,7 @@
Name_No_Task_Attributes_Package : constant Name_Id := N + $;
Name_Nominal : constant Name_Id := N + $;
Name_On : constant Name_Id := N + $;
+ Name_Optional : constant Name_Id := N + $;
Name_Policy : constant Name_Id := N + $;
Name_Parameter_Types : constant Name_Id := N + $;
Name_Reference : constant Name_Id := N + $;
