This patch reorganizes the Lock_Free restrictions. The compiler issues a
warning whenever a Priority aspect/pragma is given while the lock-free
implementation has been forced by an aspect/pragma.

------------
-- Source --
------------

package T is
   protected type P1
     with Lock_Free
   is
      pragma Priority (1);
   end P1;
end T;

-----------------
-- Compilation --
-----------------

gnatmake -q -gnat12 t.ads

------------
-- Output --
------------

t.ads:5:07: warning: pragma "Priority" for "P1" has no effect when Lock_Free 
given
gnatmake: "t.ads" compilation error

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-07-09  Vincent Pucci  <pu...@adacore.com>

        * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support
        atomic operation moved to the protected body case. No non-elementary
        out parameter moved to the protected declaration case. Functions have
        only one lock-free restriction.
        (Analyze_Protected_Type_Declaration): Issue a warning when
        Priority given with Lock_Free.

Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 189367)
+++ sem_ch9.adb (working copy)
@@ -139,87 +139,69 @@
             Priv_Decls : constant List_Id := Private_Declarations (Pdef);
             Vis_Decls  : constant List_Id := Visible_Declarations (Pdef);
 
-            Comp_Id    : Entity_Id;
-            Comp_Size  : Int;
-            Comp_Type  : Entity_Id;
-            Decl       : Node_Id;
+            Decl : Node_Id;
 
          begin
-            --  Examine the visible declarations. Entries and entry families
-            --  are not allowed by the lock-free restrictions.
+            --  Examine the visible and the private declarations
 
             Decl := First (Vis_Decls);
             while Present (Decl) loop
+
+               --  Entries and entry families are not allowed by the lock-free
+               --  restrictions.
+
                if Nkind (Decl) = N_Entry_Declaration then
                   if Complain then
-                     Error_Msg_N ("entry not allowed for lock-free " &
-                                  "implementation",
+                     Error_Msg_N ("entry not allowed when Lock_Free given",
                                   Decl);
                   end if;
 
                   return False;
-               end if;
 
-               Next (Decl);
-            end loop;
+               --  Non-elementary out parameters in protected procedure are not
+               --  allowed by the lock-free restrictions.
 
-            --  Examine the private declarations
+               elsif Nkind (Decl) = N_Subprogram_Declaration
+                 and then Nkind (Specification (Decl)) =
+                            N_Procedure_Specification
+                 and then Present
+                            (Parameter_Specifications (Specification (Decl)))
+               then
+                  declare
+                     Par_Specs : constant List_Id   :=
+                                   Parameter_Specifications
+                                     (Specification (Decl));
+                     Par       : constant Node_Id   := First (Par_Specs);
+                     Par_Typ   : constant Entity_Id :=
+                                   Etype (Parameter_Type (Par));
 
-            Decl := First (Priv_Decls);
-            while Present (Decl) loop
-
-               --  The protected type must define at least one scalar component
-
-               if Nkind (Decl) = N_Component_Declaration then
-                  Comp_Id       := Defining_Identifier (Decl);
-                  Comp_Type     := Etype (Comp_Id);
-
-                  --  Make sure the protected component type has size and
-                  --  alignment fields set at this point whenever this is
-                  --  possible.
-
-                  Layout_Type (Comp_Type);
-
-                  if Known_Esize (Comp_Type) then
-                     Comp_Size := UI_To_Int (Esize (Comp_Type));
-
-                  --  If the Esize (Object_Size) is unknown at compile-time,
-                  --  look at the RM_Size (Value_Size) since it may have been
-                  --  set by an explicit representation clause.
-
-                  else
-                     Comp_Size := UI_To_Int (RM_Size (Comp_Type));
-                  end if;
-
-                  --  Check that the size of the component is 8, 16, 32 or 64
-                  --  bits.
-
-                  case Comp_Size is
-                     when 8 | 16 | 32 | 64 =>
-                        null;
-                     when others           =>
+                  begin
+                     if Out_Present (Par)
+                       and then not Is_Elementary_Type (Par_Typ)
+                     then
                         if Complain then
-                           Error_Msg_N ("must support atomic operations for " &
-                                        "lock-free implementation",
-                                         Decl);
+                           Error_Msg_NE
+                             ("non-elementary out parameter& not allowed " &
+                              "when Lock_Free given",
+                              Par,
+                              Defining_Identifier (Par));
                         end if;
 
                         return False;
-                  end case;
+                     end if;
+                  end;
+               end if;
 
-               --  Entries and entry families are not allowed
+               --  Examine the private declarations after the visible
+               --  declarations.
 
-               elsif Nkind (Decl) = N_Entry_Declaration then
-                  if Complain then
-                     Error_Msg_N ("entry not allowed for lock-free " &
-                                  "implementation",
-                                  Decl);
-                  end if;
-
-                  return False;
+               if No (Next (Decl))
+                 and then List_Containing (Decl) = Vis_Decls
+               then
+                  Decl := First (Priv_Decls);
+               else
+                  Next (Decl);
                end if;
-
-               Next (Decl);
             end loop;
          end;
 
@@ -248,6 +230,11 @@
             function Satisfies_Lock_Free_Requirements
               (Sub_Body : Node_Id) return Boolean
             is
+               Is_Procedure : constant Boolean    :=
+                                Ekind (Corresponding_Spec (Sub_Body)) =
+                                  E_Procedure;
+               --  Indicates if Sub_Body is a procedure body
+
                Comp : Entity_Id := Empty;
                --  Track the current component which the body references
 
@@ -260,152 +247,160 @@
 
                function Check_Node (N : Node_Id) return Traverse_Result is
                begin
-                  --  Function calls and attribute references must be static
+                  if Is_Procedure then
+                     --  Function calls and attribute references must be static
 
-                  if Nkind (N) = N_Attribute_Reference
-                    and then not Is_Static_Expression (N)
-                  then
-                     if Complain then
-                        Error_Msg_N
-                          ("non-static attribute reference not allowed",
-                           N);
-                     end if;
+                     if Nkind (N) = N_Attribute_Reference
+                       and then not Is_Static_Expression (N)
+                     then
+                        if Complain then
+                           Error_Msg_N
+                             ("non-static attribute reference not allowed", N);
+                        end if;
 
-                     return Abandon;
+                        return Abandon;
 
-                  elsif Nkind (N) = N_Function_Call
-                    and then not Is_Static_Expression (N)
-                  then
-                     if Complain then
-                        Error_Msg_N ("non-static function call not allowed",
-                                     N);
-                     end if;
+                     elsif Nkind (N) = N_Function_Call
+                       and then not Is_Static_Expression (N)
+                     then
+                        if Complain then
+                           Error_Msg_N ("non-static function call not allowed",
+                                        N);
+                        end if;
 
-                     return Abandon;
+                        return Abandon;
 
-                  --  Loop statements and procedure calls are prohibited
+                     --  Loop statements and procedure calls are prohibited
 
-                  elsif Nkind (N) = N_Loop_Statement then
-                     if Complain then
-                        Error_Msg_N ("loop not allowed", N);
-                     end if;
+                     elsif Nkind (N) = N_Loop_Statement then
+                        if Complain then
+                           Error_Msg_N ("loop not allowed", N);
+                        end if;
 
-                     return Abandon;
+                        return Abandon;
 
-                  elsif Nkind (N) = N_Procedure_Call_Statement then
-                     if Complain then
-                        Error_Msg_N ("procedure call not allowed", N);
+                     elsif Nkind (N) = N_Procedure_Call_Statement then
+                        if Complain then
+                           Error_Msg_N ("procedure call not allowed", N);
+                        end if;
+
+                        return Abandon;
+
+                     --  References
+
+                     elsif Nkind (N) = N_Identifier
+                       and then Present (Entity (N))
+                     then
+                        declare
+                           Id     : constant Entity_Id := Entity (N);
+                           Sub_Id : constant Entity_Id :=
+                                      Corresponding_Spec (Sub_Body);
+
+                        begin
+                           --  Prohibit references to non-constant entities
+                           --  outside the protected subprogram scope.
+
+                           if Ekind (Id) in Assignable_Kind
+                             and then not Scope_Within_Or_Same (Scope (Id),
+                                            Sub_Id)
+                             and then not Scope_Within_Or_Same (Scope (Id),
+                                            Protected_Body_Subprogram (Sub_Id))
+                           then
+                              if Complain then
+                                 Error_Msg_NE
+                                   ("reference to global variable& not " &
+                                    "allowed", N, Id);
+                              end if;
+
+                              return Abandon;
+                           end if;
+                        end;
                      end if;
+                  end if;
 
-                     return Abandon;
+                  --  A protected subprogram (function or procedure) may
+                  --  reference only one component of the protected type, plus
+                  --  the type of the component must support atomic operation.
 
-                  --  References
-
-                  elsif Nkind (N) = N_Identifier
+                  if Nkind (N) = N_Identifier
                     and then Present (Entity (N))
                   then
                      declare
-                        Id     : constant Entity_Id := Entity (N);
-                        Sub_Id : constant Entity_Id :=
-                                   Corresponding_Spec (Sub_Body);
+                        Id        : constant Entity_Id := Entity (N);
+                        Comp_Decl : Node_Id;
+                        Comp_Id   : Entity_Id := Empty;
+                        Comp_Size : Int;
+                        Comp_Type : Entity_Id;
 
                      begin
-                        --  Prohibit references to non-constant entities
-                        --  outside the protected subprogram scope.
+                        if Ekind (Id) = E_Component then
+                           Comp_Id := Id;
 
-                        if Ekind (Id) in Assignable_Kind
-                          and then not Scope_Within_Or_Same (Scope (Id),
-                                         Sub_Id)
-                          and then not Scope_Within_Or_Same (Scope (Id),
-                                         Protected_Body_Subprogram (Sub_Id))
+                        elsif Ekind_In (Id, E_Constant, E_Variable)
+                          and then Present (Prival_Link (Id))
                         then
-                           if Complain then
-                              Error_Msg_NE
-                                ("reference to global variable& not allowed",
-                                 N, Id);
-                           end if;
+                           Comp_Id := Prival_Link (Id);
+                        end if;
 
-                           return Abandon;
+                        if Present (Comp_Id) then
+                           Comp_Decl := Parent (Comp_Id);
+                           Comp_Type := Etype (Comp_Id);
 
-                        --  Prohibit non-scalar out parameters (scalar
-                        --  parameters are passed by copy).
+                           if Nkind (Comp_Decl) = N_Component_Declaration
+                             and then Is_List_Member (Comp_Decl)
+                             and then List_Containing (Comp_Decl) = Priv_Decls
+                           then
+                              --  Make sure the protected component type has
+                              --  size and alignment fields set at this point
+                              --  whenever this is possible.
 
-                        elsif Ekind_In (Id, E_Out_Parameter,
-                                            E_In_Out_Parameter)
-                          and then not Is_Elementary_Type (Etype (Id))
-                          and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
-                        then
-                           if Complain then
-                              Error_Msg_NE
-                                ("non-elementary out parameter& not allowed",
-                                 N, Id);
-                           end if;
+                              Layout_Type (Comp_Type);
 
-                           return Abandon;
+                              if Known_Esize (Comp_Type) then
+                                 Comp_Size := UI_To_Int (Esize (Comp_Type));
 
-                        --  A protected subprogram may reference only one
-                        --  component of the protected type.
+                              --  If the Esize (Object_Size) is unknown at
+                              --  compile-time, look at the RM_Size
+                              --  (Value_Size) since it may have been set by an
+                              --  explicit representation clause.
 
-                        elsif Ekind (Id) = E_Component then
-                           declare
-                              Comp_Decl : constant Node_Id := Parent (Id);
-                           begin
-                              if Nkind (Comp_Decl) = N_Component_Declaration
-                                and then Is_List_Member (Comp_Decl)
-                                and then List_Containing (Comp_Decl) =
-                                           Priv_Decls
-                              then
-                                 if No (Comp) then
-                                    Comp := Id;
+                              else
+                                 Comp_Size := UI_To_Int (RM_Size (Comp_Type));
+                              end if;
 
-                                 --  Check if another protected component has
-                                 --  already been accessed by the subprogram
-                                 --  body.
+                              --  Check that the size of the component is 8,
+                              --  16, 32 or 64 bits.
 
-                                 elsif Comp /= Id then
+                              case Comp_Size is
+                                 when 8 | 16 | 32 | 64 =>
+                                    null;
+                                 when others           =>
                                     if Complain then
-                                       Error_Msg_N
-                                         ("only one protected component " &
-                                          "allowed",
-                                          N);
+                                       Error_Msg_NE
+                                         ("type of& must support atomic " &
+                                          "operations",
+                                          N, Comp_Id);
                                     end if;
 
                                     return Abandon;
-                                 end if;
-                              end if;
-                           end;
+                              end case;
 
-                        elsif Ekind_In (Id, E_Constant, E_Variable)
-                          and then Present (Prival_Link (Id))
-                        then
-                           declare
-                              Comp_Decl : constant Node_Id :=
-                                            Parent (Prival_Link (Id));
-                           begin
-                              if Nkind (Comp_Decl) = N_Component_Declaration
-                                and then Is_List_Member (Comp_Decl)
-                                and then List_Containing (Comp_Decl) =
-                                           Priv_Decls
-                              then
-                                 if No (Comp) then
-                                    Comp := Prival_Link (Id);
+                              --  Check if another protected component has
+                              --  already been accessed by the subprogram body.
 
-                                 --  Check if another protected component has
-                                 --  already been accessed by the subprogram
-                                 --  body.
+                              if No (Comp) then
+                                 Comp := Id;
 
-                                 elsif Comp /= Prival_Link (Id) then
-                                    if Complain then
-                                       Error_Msg_N
-                                         ("only one protected component " &
-                                          "allowed",
-                                          N);
-                                    end if;
+                              elsif Comp /= Id then
+                                 if Complain then
+                                    Error_Msg_N
+                                      ("only one protected component allowed",
+                                       N);
+                                 end if;
 
-                                    return Abandon;
-                                 end if;
+                                 return Abandon;
                               end if;
-                           end;
+                           end if;
                         end if;
                      end;
                   end if;
@@ -444,7 +439,7 @@
                  and then not Satisfies_Lock_Free_Requirements (Decl)
                then
                   if Complain then
-                     Error_Msg_N ("body prevents lock-free implementation",
+                     Error_Msg_N ("body not allowed when Lock_Free given",
                                   Decl);
                   end if;
 
@@ -1787,6 +1782,43 @@
       --  issued by Allows_Lock_Free_Implementation.
 
       if Uses_Lock_Free (Defining_Identifier (N)) then
+         --  Complain when there is an explicit aspect/pragma Priority (or
+         --  Interrupt_Priority) while the lock-free implementation is forced
+         --  by an aspect/pragma.
+
+         declare
+            Id        : constant Entity_Id :=
+                          Defining_Identifier (Original_Node (N));
+            --  The warning must be issued on the original identifier in order
+            --  to deal properly with the case of a single protected object.
+
+            Prio_Item : constant Node_Id :=
+                          Get_Rep_Item
+                            (Defining_Identifier (N),
+                             Name_Priority,
+                             Check_Parents => False);
+
+         begin
+            if Present (Prio_Item) then
+               --  Aspect case
+
+               if Nkind (Prio_Item) = N_Aspect_Specification
+                 or else From_Aspect_Specification (Prio_Item)
+               then
+                  Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
+                  Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" &
+                                " given", Prio_Item, Id);
+
+               --  Pragma case
+
+               else
+                  Error_Msg_Name_1 := Pragma_Name (Prio_Item);
+                  Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" &
+                                " given", Prio_Item, Id);
+               end if;
+            end if;
+         end;
+
          if not Allows_Lock_Free_Implementation (N, Complain => True) then
             return;
          end if;

Reply via email to