Patchwork [Ada] Ada 2012 aspect Synchronization

login
register
mail settings
Submitter Arnaud Charlet
Date Jan. 23, 2012, 8:55 a.m.
Message ID <20120123085526.GA31513@adacore.com>
Download mbox | patch
Permalink /patch/137304/
State New
Headers show

Comments

Arnaud Charlet - Jan. 23, 2012, 8:55 a.m.
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  <kirtchev@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.

Patch

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 + $;