[multiple changes]

2017-01-06  Yannick Moy  <moy@adacore.com>

	* ghost.adb Minor fixing of references to SPARK RM.
	(Check_Ghost_Context): Check whether reference is to a lvalue
	before issuing an error about violation of SPARK RM 6.9(13)
	when declaration has Ghost policy Check and reference has Ghost
	policy Ignore.
	* sem_util.adb Minor indentation.
	* sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub,
	Analyze_Task_Body_Stub): Set Ekind of the defining identifier.
	* sem_util.ads (Unique_Defining_Entity): Document the result
	for package body stubs.

2017-01-06  Tristan Gingold  <gingold@adacore.com>

	* raise-gcc.c (abort): Macro to call Abort_Propagation.
	* s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access
	constant.
	* exp_ch9.adb (Expand_N_Protected_Type_Declaration):
	Do not generate the Entry_Max_Queue_Lengths_Array if all default
	values.
	* exp_util.adb (Corresponding_Runtime_Package): Consider
	Max_Queue_Length pragma.

From-SVN: r244129

gcc/ada/ChangeLog

+2017-01-06  Yannick Moy  <moy@adacore.com>
+
+	* ghost.adb Minor fixing of references to SPARK RM.
+	(Check_Ghost_Context): Check whether reference is to a lvalue
+	before issuing an error about violation of SPARK RM 6.9(13)
+	when declaration has Ghost policy Check and reference has Ghost
+	policy Ignore.
+	* sem_util.adb Minor indentation.
+	* sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub,
+	Analyze_Task_Body_Stub): Set Ekind of the defining identifier.
+	* sem_util.ads (Unique_Defining_Entity): Document the result
+	for package body stubs.
+
+2017-01-06  Tristan Gingold  <gingold@adacore.com>
+
+	* raise-gcc.c (abort): Macro to call Abort_Propagation.
+	* s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access
+	constant.
+	* exp_ch9.adb (Expand_N_Protected_Type_Declaration):
+	Do not generate the Entry_Max_Queue_Lengths_Array if all default
+	values.
+	* exp_util.adb (Corresponding_Runtime_Package): Consider
+	Max_Queue_Length pragma.
+
 2017-01-06  Justin Squirek  <squirek@adacore.com>
 
 	* exp_ch9.adb (Expand_N_Protected_Type_Declaration):

gcc/ada/exp_ch9.adb

@@ -9767,102 +9767,85 @@ package body Exp_Ch9 is
       --  type. This object is later passed to the appropriate protected object
       --  initialization routine.
 
-      declare
-         Max      : Uint;
-         Maxs     : constant List_Id := New_List;
-         Count    : Int;
-         Item     : Entity_Id;
-         Maxs_Id  : Entity_Id;
-         Max_Vals : Node_Id;
-
-      begin
-         if Has_Entries (Prot_Typ) then
+      if Has_Entries (Prot_Typ) then
+         declare
+            Need_Array : Boolean := False;
+            Maxs       : List_Id;
+            Count      : Int;
+            Item       : Entity_Id;
+            Maxs_Id    : Entity_Id;
+            Max_Vals   : Node_Id;
 
-            --  Gather the Max_Queue_Length values of all entries in a list. A
-            --  value of zero indicates that the entry has no limitation on its
-            --  queue length.
+         begin
+            --  First check if there is any Max_Queue_Length pragma
 
-            Count := 0;
             Item  := First_Entity (Prot_Typ);
             while Present (Item) loop
-               if Is_Entry (Item) then
-                  Count := Count + 1;
-                  Max   := Get_Max_Queue_Length (Item);
-
-                  --  The package System_Tasking_Protected_Objects_Single_Entry
-                  --  is only used in cases where queue length is 1, so if this
-                  --  package is being used and there is a value supplied for
-                  --  it print an error message and halt compilation.
-
-                  if Max /= 0
-                    and then Corresponding_Runtime_Package (Prot_Typ) =
-                               System_Tasking_Protected_Objects_Single_Entry
-                  then
-                     Error_Msg_N
-                       ("max_queue_length cannot be applied to entries under "
-                        & "the Ravenscar profile", Item);
-                     raise Program_Error;
-                  end if;
-
-                  Append_To (Maxs, Make_Integer_Literal (Loc, Intval => Max));
+               if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
+                  Need_Array := True;
+                  exit;
                end if;
-
                Next_Entity (Item);
             end loop;
 
-            case Corresponding_Runtime_Package (Prot_Typ) is
-               when System_Tasking_Protected_Objects_Entries =>
-
-                  --  Create the declaration of the array object. Generate:
-
-                  --    Maxs_Id : aliased Protected_Entry_Queue_Max_Array
-                  --                        (1 .. Count) := (..., ...);
-
-                  Maxs_Id :=
-                    Make_Defining_Identifier (Loc,
-                      Chars => New_External_Name (Chars (Prot_Typ), 'B'));
-
-                  Max_Vals :=
-                    Make_Object_Declaration (Loc,
-                      Defining_Identifier => Maxs_Id,
-                      Aliased_Present     => True,
-                      Object_Definition   =>
-                        Make_Subtype_Indication (Loc,
-                          Subtype_Mark =>
-                            New_Occurrence_Of
-                              (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
-                          Constraint   =>
-                            Make_Index_Or_Discriminant_Constraint (Loc,
-                              Constraints => New_List (
-                                Make_Range (Loc,
-                                  Make_Integer_Literal (Loc, 1),
-                                  Make_Integer_Literal (Loc, Count))))),
-                      Expression          => Make_Aggregate (Loc, Maxs));
-
-                  --  A pointer to this array will be placed in the
-                  --  corresponding record by its initialization procedure so
-                  --  this needs to be analyzed here.
+            --  Gather the Max_Queue_Length values of all entries in a list. A
+            --  value of zero indicates that the entry has no limitation on its
+            --  queue length.
 
-                  Insert_After (Current_Node, Max_Vals);
-                  Current_Node := Max_Vals;
-                  Analyze (Max_Vals);
+            if Need_Array then
+               Maxs := New_List;
+               Count := 0;
+               Item  := First_Entity (Prot_Typ);
+               while Present (Item) loop
+                  if Is_Entry (Item) then
+                     Count := Count + 1;
+                     Append_To (Maxs,
+                        Make_Integer_Literal (Loc,
+                           Get_Max_Queue_Length (Item)));
+                  end if;
 
-                  Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
+                  Next_Entity (Item);
+               end loop;
 
-               when System_Tasking_Protected_Objects_Single_Entry =>
+               --  Create the declaration of the array object. Generate:
 
-                  --  If this section is entered this means the package
-                  --  System_Tasking_Protected_Objects_Single_Entry is being
-                  --  used and that it correctly has no Max_Queue_Length
-                  --  specified, so fall through and continue normally.
+               --    Maxs_Id : aliased Protected_Entry_Queue_Max_Array
+               --                        (1 .. Count) := (..., ...);
 
-                  null;
+               Maxs_Id :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Chars (Prot_Typ), 'B'));
 
-               when others =>
-                  raise Program_Error;
-            end case;
-         end if;
-      end;
+               Max_Vals :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Maxs_Id,
+                   Aliased_Present     => True,
+                   Constant_Present    => True,
+                   Object_Definition   =>
+                     Make_Subtype_Indication (Loc,
+                       Subtype_Mark =>
+                         New_Occurrence_Of
+                           (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
+                       Constraint   =>
+                         Make_Index_Or_Discriminant_Constraint (Loc,
+                           Constraints => New_List (
+                             Make_Range (Loc,
+                               Make_Integer_Literal (Loc, 1),
+                               Make_Integer_Literal (Loc, Count))))),
+                   Expression          => Make_Aggregate (Loc, Maxs));
+
+               --  A pointer to this array will be placed in the
+               --  corresponding record by its initialization procedure so
+               --  this needs to be analyzed here.
+
+               Insert_After (Current_Node, Max_Vals);
+               Current_Node := Max_Vals;
+               Analyze (Max_Vals);
+
+               Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
+            end if;
+         end;
+      end if;
 
       --  Emit declaration for Entry_Bodies_Array, now that the addresses of
       --  all protected subprograms have been collected.
@@ -14209,19 +14192,24 @@ package body Exp_Ch9 is
                      raise Program_Error;
             end case;
 
-            --  Entry_Queue_Maxs parameter. This is a pointer to an array of
+            --  Entry_Queue_Maxs parameter. This is an access to an array of
             --  naturals representing the entry queue maximums for each entry
-            --  in the protected type. Zero represents no max.
+            --  in the protected type. Zero represents no max. The access is
+            --  null if there is no limit for all entries (usual case).
 
             if Has_Entry
               and then Pkg_Id /= System_Tasking_Protected_Objects_Single_Entry
             then
-               Append_To (Args,
-                 Make_Attribute_Reference (Loc,
-                   Prefix         =>
-                     New_Occurrence_Of
-                       (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
-                   Attribute_Name => Name_Unrestricted_Access));
+               if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
+                  Append_To (Args,
+                    Make_Attribute_Reference (Loc,
+                      Prefix         =>
+                        New_Occurrence_Of
+                          (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
+                      Attribute_Name => Name_Unrestricted_Access));
+               else
+                  Append_To (Args, Make_Null (Loc));
+               end if;
 
             --  Edge cases exist where entry initialization functions are
             --  called, but no entries exist, so null is appended.

gcc/ada/exp_util.adb

@@ -2020,6 +2020,45 @@ package body Exp_Util is
    -----------------------------------
 
    function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
+
+      function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
+      --  Return True if protected type T has one entry and the maximum queue
+      --  length is one.
+
+      --------------------------------
+      -- Has_One_Entry_And_No_Queue --
+      --------------------------------
+
+      function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
+         Is_First : Boolean := True;
+         Ent      : Entity_Id;
+      begin
+         Ent := First_Entity (T);
+         while Present (Ent) loop
+            if Is_Entry (Ent) then
+               if not Is_First then
+                  --  More than one entry
+
+                  return False;
+               end if;
+
+               if not Restriction_Active (No_Entry_Queue)
+                 and then Get_Max_Queue_Length (Ent) /= Uint_1
+               then
+                  --  Max queue length is not 1
+
+                  return False;
+               end if;
+
+               Is_First := False;
+            end if;
+
+            Ent := Next_Entity (Ent);
+         end loop;
+
+         return True;
+      end Has_One_Entry_And_No_Queue;
+
       Pkg_Id : RTU_Id := RTU_Null;
 
    begin
@@ -2047,9 +2086,8 @@ package body Exp_Util is
            or else Has_Interrupt_Handler (Typ)
          then
             if Abort_Allowed
-              or else Restriction_Active (No_Entry_Queue) = False
               or else Restriction_Active (No_Select_Statements) = False
-              or else Number_Entries (Typ) > 1
+              or else not Has_One_Entry_And_No_Queue (Typ)
               or else (Has_Attach_Handler (Typ)
                         and then not Restricted_Profile)
             then

gcc/ada/ghost.adb

@@ -148,10 +148,10 @@ package body Ghost is
    -------------------------
 
    procedure Check_Ghost_Context (Ghost_Id : Entity_Id; Ghost_Ref : Node_Id) is
-      procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id);
+      procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id);
       --  Verify that the Ghost policy at the point of declaration of entity Id
-      --  matches the policy at the point of reference. If this is not the case
-      --  emit an error at Err_N.
+      --  matches the policy at the point of reference Ref. If this is not the
+      --  case emit an error at Ref.
 
       function Is_OK_Ghost_Context (Context : Node_Id) return Boolean;
       --  Determine whether node Context denotes a Ghost-friendly context where
@@ -539,26 +539,29 @@ package body Ghost is
       -- Check_Ghost_Policy --
       ------------------------
 
-      procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id) is
+      procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id) is
          Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
 
       begin
          --  The Ghost policy in effect a the point of declaration and at the
          --  point of use must match (SPARK RM 6.9(13)).
 
-         if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then
-            Error_Msg_Sloc := Sloc (Err_N);
+         if Is_Checked_Ghost_Entity (Id)
+           and then Policy = Name_Ignore
+           and then May_Be_Lvalue (Ref)
+         then
+            Error_Msg_Sloc := Sloc (Ref);
 
-            Error_Msg_N  ("incompatible ghost policies in effect", Err_N);
-            Error_Msg_NE ("\& declared with ghost policy `Check`", Err_N, Id);
-            Error_Msg_NE ("\& used # with ghost policy `Ignore`",  Err_N, Id);
+            Error_Msg_N  ("incompatible ghost policies in effect", Ref);
+            Error_Msg_NE ("\& declared with ghost policy `Check`", Ref, Id);
+            Error_Msg_NE ("\& used # with ghost policy `Ignore`",  Ref, Id);
 
          elsif Is_Ignored_Ghost_Entity (Id) and then Policy = Name_Check then
-            Error_Msg_Sloc := Sloc (Err_N);
+            Error_Msg_Sloc := Sloc (Ref);
 
-            Error_Msg_N  ("incompatible ghost policies in effect",  Err_N);
-            Error_Msg_NE ("\& declared with ghost policy `Ignore`", Err_N, Id);
-            Error_Msg_NE ("\& used # with ghost policy `Check`",    Err_N, Id);
+            Error_Msg_N  ("incompatible ghost policies in effect",  Ref);
+            Error_Msg_NE ("\& declared with ghost policy `Ignore`", Ref, Id);
+            Error_Msg_NE ("\& used # with ghost policy `Check`",    Ref, Id);
          end if;
       end Check_Ghost_Policy;
 
@@ -573,7 +576,7 @@ package body Ghost is
          Check_Ghost_Policy (Ghost_Id, Ghost_Ref);
 
       --  Otherwise the Ghost entity appears in a non-Ghost context and affects
-      --  its behavior or value (SPARK RM 6.9(11,12)).
+      --  its behavior or value (SPARK RM 6.9(10,11)).
 
       else
          Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref);

gcc/ada/raise-gcc.c

@@ -86,12 +86,9 @@ extern struct Exception_Occurrence *__gnat_setup_current_excep
 extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
 
 #ifdef CERT
+/* Called in case of error during propagation.  */
+extern void __gnat_raise_abort (void) __attribute__ ((noreturn));
 #define abort() __gnat_raise_abort()
-static void __gnat_raise_abort(void)
-{
-  while (1)
-    ;
-}
 #endif
 
 #include "unwind-pe.h"

gcc/ada/s-tpoben.ads

@@ -70,7 +70,7 @@ package System.Tasking.Protected_Objects.Entries is
      array (Positive_Protected_Entry_Index range <>) of Natural;
 
    type Protected_Entry_Queue_Max_Access is
-     access all Protected_Entry_Queue_Max_Array;
+     access constant Protected_Entry_Queue_Max_Array;
 
    --  The following declarations define an array that contains the string
    --  names of entries and entry family members, together with an associated

gcc/ada/sem_ch10.adb

@@ -1590,6 +1590,7 @@ package body Sem_Ch10 is
 
          Set_Has_Completion (Nam);
          Set_Scope (Defining_Entity (N), Current_Scope);
+         Set_Ekind (Defining_Entity (N), E_Package_Body);
          Set_Corresponding_Spec_Of_Stub (N, Nam);
          Generate_Reference (Nam, Id, 'b');
          Analyze_Proper_Body (N, Nam);
@@ -1931,6 +1932,7 @@ package body Sem_Ch10 is
 
       else
          Set_Scope (Defining_Entity (N), Current_Scope);
+         Set_Ekind (Defining_Entity (N), E_Protected_Body);
          Set_Has_Completion (Etype (Nam));
          Set_Corresponding_Spec_Of_Stub (N, Nam);
          Generate_Reference (Nam, Defining_Identifier (N), 'b');
@@ -2384,6 +2386,7 @@ package body Sem_Ch10 is
 
       else
          Set_Scope (Defining_Entity (N), Current_Scope);
+         Set_Ekind (Defining_Entity (N), E_Task_Body);
          Generate_Reference (Nam, Defining_Identifier (N), 'b');
          Set_Corresponding_Spec_Of_Stub (N, Nam);
 

gcc/ada/sem_util.adb

@@ -8375,13 +8375,14 @@ package body Sem_Util is
    --------------------------
 
    function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
+      pragma Assert (Is_Entry (Id));
       Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
 
    begin
       --  A value of 0 represents no maximum specified, and entries and entry
       --  families with no Max_Queue_Length aspect or pragma default to it.
 
-      if not Has_Max_Queue_Length (Id) or else not Present (Prag) then
+      if not Present (Prag) then
          return Uint_0;
       end if;
 
@@ -15677,7 +15678,7 @@ package body Sem_Util is
          when N_Assignment_Statement =>
             return N = Name (P);
 
-            --  Function call arguments are never lvalues
+         --  Function call arguments are never lvalues
 
          when N_Function_Call =>
             return False;

gcc/ada/sem_util.ads

@@ -2344,12 +2344,12 @@ package Sem_Util is
    --  Return the entity which represents declaration N, so that different
    --  views of the same entity have the same unique defining entity:
    --    * entry declaration and entry body
-   --    * package spec and body
-   --    * protected type declaration, protected body stub and protected body
+   --    * package spec, package body, and package body stub
+   --    * protected type declaration, protected body and protected body stub
    --    * private view and full view of a deferred constant
    --    * private view and full view of a type
-   --    * subprogram declaration, subprogram stub and subprogram body
-   --    * task type declaration, task body stub and task body
+   --    * subprogram declaration, subprogram and subprogram body stub
+   --    * task type declaration, task body and task body stub
    --  In other cases, return the defining entity for N.
 
    function Unique_Entity (E : Entity_Id) return Entity_Id;