2012-07-23 Ed Schonberg <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): When checking for
	potential ambiguities with class-wide operations on synchronized
	types, attach the copied node properly to the tree, to prevent
	errors during expansion.

2012-07-23  Yannick Moy  <moy@adacore.com>

	* sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body
	is analyzed in Alfa mode.

2012-07-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb: Adjust previous change.

2012-07-23  Vincent Pucci  <pucci@adacore.com>

	* sem_ch9.adb (Allows_Lock_Free_Implementation): Flag
	Lock_Free_Given renames previous flag Complain. Description
	updated. Henceforth, catch every error messages issued by this
	routine when Lock_Free_Given is True.  Declaration restriction
	updated: No non-elementary parameter instead (even in parameter)
	New subprogram body restrictions implemented: No allocator,
	no address, import or export rep items, no delay statement,
	no goto statement, no quantified expression and no dereference
	of access value.

2012-07-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Determine_Range): Add local variable Btyp. Handle
	the case where the base type of an enumeration subtype is
	private. Replace all occurrences of Base_Type with Btyp.
	* exp_attr.adb (Attribute_Valid): Handle the case where the
	base type of an enumeration subtype is private. Replace all
	occurrences of Base_Type with Btyp.
	* sem_util.adb (Get_Enum_Lit_From_Pos): Add local variable
	Btyp. Handle the case where the base type of an enumeration
	subtype is private. Replace all occurrences of Base_Type with
	Btyp.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@189775 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 224 insertions, 51 deletions

diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 49a163b0b52..1420ba87bc0 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
@@ -68,24 +69,30 @@ package body Sem_Ch9 is
 
    function Allows_Lock_Free_Implementation
      (N        : Node_Id;
-      Complain : Boolean := False) return Boolean;
+      Lock_Free_Given : Boolean := False) return Boolean;
    --  This routine returns True iff N satisfies the following list of lock-
    --  free restrictions for protected type declaration and protected body:
    --
    --    1) Protected type declaration
    --         May not contain entries
-   --         Component types must support atomic compare and exchange
+   --         Protected subprogram declarations may not have non-elementary
+   --           parameters.
    --
    --    2) Protected Body
    --         Each protected subprogram body within N must satisfy:
    --            May reference only one protected component
    --            May not reference non-constant entities outside the protected
    --              subprogram scope.
-   --            May not reference non-elementary out parameters
-   --            May not contain loop statements or procedure calls
+   --            May not contain address representation items, allocators and
+   --              quantified expressions.
+   --            May not contain delay, goto, loop and procedure call
+   --              statements.
+   --            May not contain exported and imported entities
+   --            May not dereference access values
    --            Function calls and attribute references must be static
    --
-   --  If Complain is True, an error message is issued when False is returned
+   --  If Lock_Free_Given is True, an error message is issued when False is
+   --  returned.
 
    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
    --  Given either a protected definition or a task definition in D, check
@@ -115,22 +122,32 @@ package body Sem_Ch9 is
    -------------------------------------
 
    function Allows_Lock_Free_Implementation
-     (N        : Node_Id;
-      Complain : Boolean := False) return Boolean
+     (N               : Node_Id;
+      Lock_Free_Given : Boolean := False) return Boolean
    is
+      Errors_Count : Nat;
+      --  Errors_Count is a count of errors detected by the compiler so far
+      --  when Lock_Free_Given is True.
+
    begin
       pragma Assert (Nkind_In (N,
                                N_Protected_Type_Declaration,
                                N_Protected_Body));
 
       --  The lock-free implementation is currently enabled through a debug
-      --  flag. When Complain is True, an aspect Lock_Free forces the lock-free
-      --  implementation. In that case, the debug flag is not needed.
+      --  flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
+      --  lock-free implementation. In that case, the debug flag is not needed.
 
-      if not Complain and then not Debug_Flag_9 then
+      if not Lock_Free_Given and then not Debug_Flag_9 then
          return False;
       end if;
 
+      --  Get the number of errors detected by the compiler so far
+
+      if Lock_Free_Given then
+         Errors_Count := Serious_Errors_Detected;
+      end if;
+
       --  Protected type declaration case
 
       if Nkind (N) = N_Protected_Type_Declaration then
@@ -150,14 +167,14 @@ package body Sem_Ch9 is
                --  restrictions.
 
                if Nkind (Decl) = N_Entry_Declaration then
-                  if Complain then
+                  if Lock_Free_Given then
                      Error_Msg_N
                        ("entry not allowed when Lock_Free given", Decl);
+                  else
+                     return False;
                   end if;
 
-                  return False;
-
-               --  Non-elementary out parameters in protected procedure are not
+               --  Non-elementary parameters in protected procedure are not
                --  allowed by the lock-free restrictions.
 
                elsif Nkind (Decl) = N_Subprogram_Declaration
@@ -176,18 +193,17 @@ package body Sem_Ch9 is
                   begin
                      Par := First (Par_Specs);
                      while Present (Par) loop
-                        if Out_Present (Par)
-                          and then not Is_Elementary_Type
-                                         (Etype (Parameter_Type (Par)))
+                        if not Is_Elementary_Type
+                                 (Etype (Defining_Identifier (Par)))
                         then
-                           if Complain then
+                           if Lock_Free_Given then
                               Error_Msg_NE
-                                ("non-elementary out parameter& not allowed "
+                                ("non-elementary parameter& not allowed "
                                  & "when Lock_Free given",
                                  Par, Defining_Identifier (Par));
+                           else
+                              return False;
                            end if;
-
-                           return False;
                         end if;
 
                         Next (Par);
@@ -240,6 +256,10 @@ package body Sem_Ch9 is
                Comp : Entity_Id := Empty;
                --  Track the current component which the body references
 
+               Errors_Count : Nat;
+               --  Errors_Count is a count of errors detected by the compiler
+               --  so far when Lock_Free_Given is True.
+
                function Check_Node (N : Node_Id) return Traverse_Result;
                --  Check that node N meets the lock free restrictions
 
@@ -248,6 +268,7 @@ package body Sem_Ch9 is
                ----------------
 
                function Check_Node (N : Node_Id) return Traverse_Result is
+                  Kind : constant Node_Kind := Nkind (N);
 
                   --  The following function belongs in sem_eval ???
 
@@ -310,51 +331,123 @@ package body Sem_Ch9 is
 
                begin
                   if Is_Procedure then
-                     --  Attribute references must be static or denote a static
-                     --  function.
+                     --  Allocators restricted
+
+                     if Kind = N_Allocator then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("allocator not allowed", N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
+
+                     --  Aspects Address, Export and Import restricted
+
+                     elsif Kind = N_Aspect_Specification then
+                        declare
+                           Asp_Name : constant Name_Id   :=
+                                        Chars (Identifier (N));
+                           Asp_Id   : constant Aspect_Id :=
+                                        Get_Aspect_Id (Asp_Name);
+
+                        begin
+                           if Asp_Id = Aspect_Address
+                             or else Asp_Id = Aspect_Export
+                             or else Asp_Id = Aspect_Import
+                           then
+                              Error_Msg_Name_1 := Asp_Name;
+
+                              if Lock_Free_Given then
+                                 Error_Msg_N ("aspect% not allowed", N);
+                                 return Skip;
+                              end if;
+
+                              return Abandon;
+                           end if;
+                        end;
+
+                     --  Address attribute definition clause restricted
+
+                     elsif Kind = N_Attribute_Definition_Clause
+                       and then Get_Attribute_Id (Chars (N)) =
+                                  Attribute_Address
+                     then
+                        Error_Msg_Name_1 := Chars (N);
+
+                        if Lock_Free_Given then
+                           if From_Aspect_Specification (N) then
+                              Error_Msg_N ("aspect% not allowed", N);
+                           else
+                              Error_Msg_N ("% clause not allowed", N);
+                           end if;
+
+                           return Skip;
+                        end if;
+
+                        return Abandon;
 
-                     if Nkind (N) = N_Attribute_Reference
+                     --  Non-static Attribute references that don't denote a
+                     --  static function restricted.
+
+                     elsif Kind = N_Attribute_Reference
                        and then not Is_Static_Expression (N)
                        and then not Is_Static_Function (N)
                      then
-                        if Complain then
+                        if Lock_Free_Given then
                            Error_Msg_N
                              ("non-static attribute reference not allowed", N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
-                     --  Function calls must be static
+                     --  Delay statements restricted
 
-                     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);
+                     elsif Kind in N_Delay_Statement then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("delay not allowed", N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
-                     --  Loop statements and procedure calls are prohibited
+                     --  Explicit dereferences restricted (i.e. dereferences of
+                     --  access values).
 
-                     elsif Nkind (N) = N_Loop_Statement then
-                        if Complain then
-                           Error_Msg_N ("loop not allowed", N);
+                     elsif Kind = N_Explicit_Dereference then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("explicit dereference not allowed", N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
-                     elsif Nkind (N) = N_Procedure_Call_Statement then
-                        if Complain then
-                           Error_Msg_N ("procedure call not allowed", N);
+                     --  Non-static function calls restricted
+
+                     elsif Kind = N_Function_Call
+                       and then not Is_Static_Expression (N)
+                     then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("non-static function call not allowed",
+                                        N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
+
+                     --  Goto statements restricted
+
+                     elsif Kind = N_Goto_Statement then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("goto statement not allowed", N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
                      --  References
 
-                     elsif Nkind (N) = N_Identifier
+                     elsif Kind = N_Identifier
                        and then Present (Entity (N))
                      then
                         declare
@@ -372,15 +465,75 @@ package body Sem_Ch9 is
                              and then not Scope_Within_Or_Same (Scope (Id),
                                             Protected_Body_Subprogram (Sub_Id))
                            then
-                              if Complain then
+                              if Lock_Free_Given then
                                  Error_Msg_NE
                                    ("reference to global variable& not " &
                                     "allowed", N, Id);
+                                 return Skip;
+                              end if;
+
+                              return Abandon;
+                           end if;
+                        end;
+
+                     --  Loop statements restricted
+
+                     elsif Kind = N_Loop_Statement then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("loop not allowed", N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
+
+                     --  Pragmas Export and Import restricted
+
+                     elsif Kind = N_Pragma then
+                        declare
+                           Prag_Name : constant Name_Id   := Pragma_Name (N);
+                           Prag_Id   : constant Pragma_Id :=
+                                         Get_Pragma_Id (Prag_Name);
+
+                        begin
+                           if Prag_Id = Pragma_Export
+                             or else Prag_Id = Pragma_Import
+                           then
+                              Error_Msg_Name_1 := Prag_Name;
+
+                              if Lock_Free_Given then
+                                 if From_Aspect_Specification (N) then
+                                    Error_Msg_N ("aspect% not allowed", N);
+                                 else
+                                    Error_Msg_N ("pragma% not allowed", N);
+                                 end if;
+
+                                 return Skip;
                               end if;
 
                               return Abandon;
                            end if;
                         end;
+
+                     --  Procedure call statements restricted
+
+                     elsif Kind = N_Procedure_Call_Statement then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("procedure call not allowed", N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
+
+                     --  Quantified expression restricted
+
+                     elsif Kind = N_Quantified_Expression then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("quantified expression not allowed",
+                                        N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
                      end if;
                   end if;
 
@@ -388,7 +541,7 @@ package body Sem_Ch9 is
                   --  reference only one component of the protected type, plus
                   --  the type of the component must support atomic operation.
 
-                  if Nkind (N) = N_Identifier
+                  if Kind = N_Identifier
                     and then Present (Entity (N))
                   then
                      declare
@@ -441,11 +594,12 @@ package body Sem_Ch9 is
                                  when 8 | 16 | 32 | 64 =>
                                     null;
                                  when others           =>
-                                    if Complain then
+                                    if Lock_Free_Given then
                                        Error_Msg_NE
                                          ("type of& must support atomic " &
                                           "operations",
                                           N, Comp_Id);
+                                       return Skip;
                                     end if;
 
                                     return Abandon;
@@ -458,10 +612,11 @@ package body Sem_Ch9 is
                                  Comp := Comp_Id;
 
                               elsif Comp /= Comp_Id then
-                                 if Complain then
+                                 if Lock_Free_Given then
                                     Error_Msg_N
                                       ("only one protected component allowed",
                                        N);
+                                    return Skip;
                                  end if;
 
                                  return Abandon;
@@ -479,7 +634,16 @@ package body Sem_Ch9 is
             --  Start of processing for Satisfies_Lock_Free_Requirements
 
             begin
-               if Check_All_Nodes (Sub_Body) = OK then
+               --  Get the number of errors detected by the compiler so far
+
+               if Lock_Free_Given then
+                  Errors_Count := Serious_Errors_Detected;
+               end if;
+
+               if Check_All_Nodes (Sub_Body) = OK
+                 and then (not Lock_Free_Given
+                            or else Errors_Count = Serious_Errors_Detected)
+               then
 
                   --  Establish a relation between the subprogram body and the
                   --  unique protected component it references.
@@ -503,12 +667,12 @@ package body Sem_Ch9 is
                if Nkind (Decl) = N_Subprogram_Body
                  and then not Satisfies_Lock_Free_Requirements (Decl)
                then
-                  if Complain then
+                  if Lock_Free_Given then
                      Error_Msg_N
-                       ("body not allowed when Lock_Free given", Decl);
+                       ("illegal body when Lock_Free given", Decl);
+                  else
+                     return False;
                   end if;
-
-                  return False;
                end if;
 
                Next (Decl);
@@ -516,6 +680,15 @@ package body Sem_Ch9 is
          end Protected_Body_Case;
       end if;
 
+      --  When Lock_Free is given, check if no error has been detected during
+      --  the process.
+
+      if Lock_Free_Given
+        and then Errors_Count /= Serious_Errors_Detected
+      then
+         return False;
+      end if;
+
       return True;
    end Allows_Lock_Free_Implementation;
 
@@ -1611,7 +1784,7 @@ package body Sem_Ch9 is
       --  otherwise Allows_Lock_Free_Implementation issues an error message.
 
       if Uses_Lock_Free (Spec_Id) then
-         if not Allows_Lock_Free_Implementation (N, Complain => True) then
+         if not Allows_Lock_Free_Implementation (N, True) then
             return;
          end if;
 
@@ -1886,7 +2059,7 @@ package body Sem_Ch9 is
             end if;
          end;
 
-         if not Allows_Lock_Free_Implementation (N, Complain => True) then
+         if not Allows_Lock_Free_Implementation (N, True) then
             return;
          end if;
       end if;