[multiple changes]

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Move
	Has_Non_Trivial_Precondition to sem_util. for use elsewhere.
	Improve error message on operations that inherit non-conforming
	classwide preconditions from ancestor and progenitor.
	* sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition):
	moved here from sem_ch3.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality
	check given in RM 6.1.1 (17) concerning renamings of overriding
	operations that inherits class-wide preconditions from ancestor
	or progenitor.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup.
	(Build_Adjust_Statements): Code cleanup.
	(Build_Finalizer): Update the initialization of
	Exceptions_OK.
	(Build_Finalize_Statements): Code cleanup.
	(Build_Initialize_Statements): Code cleanup.
	(Make_Deep_Array_Body): Update the initialization of
	Exceptions_OK.
	(Make_Deep_Record_Body): Update the initialization of Exceptions_OK.
	(Process_Object_Declaration): Generate a null exception handler only
	when exceptions are allowed.
	(Process_Transients_In_Scope): Update the initialization of
	Exceptions_OK.
	* exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New
	routine.
	* sem_ch11.adb (Analyze_Exception_Handlers): Do not check any
	restrictions when the handler is internally generated and the
	mode is warnings.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to
	enforce legality rule on classwide preconditions inherited from
	both an ancestor and a progenitor (RM 6.1.1 (10-13).
	* sem_disp.adb (Check_Dispatching_Context): A call to an abstract
	subprogram need not be dispatching if it appears in a precondition
	for an abstract or null subprogram.

2017-04-25  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch10.adb: Minor typo fix.

From-SVN: r247192

gcc/ada/ChangeLog

+2017-04-25  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Add_Internal_Interface_Entities): Move
+	Has_Non_Trivial_Precondition to sem_util. for use elsewhere.
+	Improve error message on operations that inherit non-conforming
+	classwide preconditions from ancestor and progenitor.
+	* sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition):
+	moved here from sem_ch3.
+	* sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality
+	check given in RM 6.1.1 (17) concerning renamings of overriding
+	operations that inherits class-wide preconditions from ancestor
+	or progenitor.
+
+2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup.
+	(Build_Adjust_Statements): Code cleanup.
+	(Build_Finalizer): Update the initialization of
+	Exceptions_OK.
+	(Build_Finalize_Statements): Code cleanup.
+	(Build_Initialize_Statements): Code cleanup.
+	(Make_Deep_Array_Body): Update the initialization of
+	Exceptions_OK.
+	(Make_Deep_Record_Body): Update the initialization of Exceptions_OK.
+	(Process_Object_Declaration): Generate a null exception handler only
+	when exceptions are allowed.
+	(Process_Transients_In_Scope): Update the initialization of
+	Exceptions_OK.
+	* exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New
+	routine.
+	* sem_ch11.adb (Analyze_Exception_Handlers): Do not check any
+	restrictions when the handler is internally generated and the
+	mode is warnings.
+
+2017-04-25  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to
+	enforce legality rule on classwide preconditions inherited from
+	both an ancestor and a progenitor (RM 6.1.1 (10-13).
+	* sem_disp.adb (Check_Dispatching_Context): A call to an abstract
+	subprogram need not be dispatching if it appears in a precondition
+	for an abstract or null subprogram.
+
+2017-04-25  Gary Dismukes  <dismukes@adacore.com>
+
+	* sem_ch10.adb: Minor typo fix.
+
 2017-04-25  Arnaud Charlet  <charlet@adacore.com>
 
 	* gcc-interface/Makefile.in: Cleanup VxWorks targets.

gcc/ada/exp_ch7.adb

@@ -1327,8 +1327,7 @@ package body Exp_Ch7 is
                              or else
                                (Present (Clean_Stmts)
                                  and then Is_Non_Empty_List (Clean_Stmts));
-      Exceptions_OK    : constant Boolean :=
-                           not Restriction_Active (No_Exception_Propagation);
+      Exceptions_OK    : constant Boolean := Exceptions_In_Finalization_OK;
       For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
       For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
       For_Package      : constant Boolean :=
@@ -2844,7 +2843,7 @@ package body Exp_Ch7 is
          Body_Ins  : Node_Id;
          Count_Ins : Node_Id;
          Fin_Call  : Node_Id;
-         Fin_Stmts : List_Id;
+         Fin_Stmts : List_Id := No_List;
          Inc_Decl  : Node_Id;
          Label     : Node_Id;
          Label_Id  : Entity_Id;
@@ -3004,8 +3003,6 @@ package body Exp_Ch7 is
          --  manual finalization of their lock managers.
 
          if Is_Protected then
-            Fin_Stmts := No_List;
-
             if Is_Simple_Protected_Type (Obj_Typ) then
                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
 
@@ -3031,8 +3028,8 @@ package body Exp_Ch7 is
             --          null;
             --    end;
 
-            if Present (Fin_Stmts) then
-               Append_To (Finalizer_Stmts,
+            if Present (Fin_Stmts) and then Exceptions_OK then
+               Fin_Stmts := New_List (
                  Make_Block_Statement (Loc,
                    Handled_Statement_Sequence =>
                      Make_Handled_Sequence_Of_Statements (Loc,
@@ -4866,8 +4863,7 @@ package body Exp_Ch7 is
          Last_Object  : Node_Id;
          Related_Node : Node_Id)
       is
-         Exceptions_OK : constant Boolean :=
-                           not Restriction_Active (No_Exception_Propagation);
+         Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
 
          Must_Hook : Boolean := False;
          --  Flag denoting whether the context requires transient object
@@ -5529,6 +5525,8 @@ package body Exp_Ch7 is
      (Prim : Final_Primitives;
       Typ  : Entity_Id) return List_Id
    is
+      Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
+
       function Build_Adjust_Or_Finalize_Statements
         (Typ : Entity_Id) return List_Id;
       --  Create the statements necessary to adjust or finalize an array of
@@ -5645,12 +5643,10 @@ package body Exp_Ch7 is
       function Build_Adjust_Or_Finalize_Statements
         (Typ : Entity_Id) return List_Id
       is
-         Comp_Typ      : constant Entity_Id  := Component_Type (Typ);
-         Exceptions_OK : constant Boolean    :=
-                           not Restriction_Active (No_Exception_Propagation);
-         Index_List    : constant List_Id    := New_List;
-         Loc           : constant Source_Ptr := Sloc (Typ);
-         Num_Dims      : constant Int        := Number_Dimensions (Typ);
+         Comp_Typ   : constant Entity_Id  := Component_Type (Typ);
+         Index_List : constant List_Id    := New_List;
+         Loc        : constant Source_Ptr := Sloc (Typ);
+         Num_Dims   : constant Int        := Number_Dimensions (Typ);
 
          procedure Build_Indexes;
          --  Generate the indexes used in the dimension loops
@@ -5822,13 +5818,11 @@ package body Exp_Ch7 is
       ---------------------------------
 
       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
-         Comp_Typ      : constant Entity_Id  := Component_Type (Typ);
-         Exceptions_OK : constant Boolean    :=
-                           not Restriction_Active (No_Exception_Propagation);
-         Final_List    : constant List_Id    := New_List;
-         Index_List    : constant List_Id    := New_List;
-         Loc           : constant Source_Ptr := Sloc (Typ);
-         Num_Dims      : constant Int        := Number_Dimensions (Typ);
+         Comp_Typ   : constant Entity_Id  := Component_Type (Typ);
+         Final_List : constant List_Id    := New_List;
+         Index_List : constant List_Id    := New_List;
+         Loc        : constant Source_Ptr := Sloc (Typ);
+         Num_Dims   : constant Int        := Number_Dimensions (Typ);
 
          function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
          --  Generate the following assignment:
@@ -6349,6 +6343,8 @@ package body Exp_Ch7 is
       Typ      : Entity_Id;
       Is_Local : Boolean := False) return List_Id
    is
+      Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
+
       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
       --  Build the statements necessary to adjust a record type. The type may
       --  have discriminants and contain variant parts. Generate:
@@ -6498,17 +6494,10 @@ package body Exp_Ch7 is
       -----------------------------
 
       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
-         Exceptions_OK  : constant Boolean    :=
-                            not Restriction_Active (No_Exception_Propagation);
-         Loc            : constant Source_Ptr := Sloc (Typ);
-         Typ_Def        : constant Node_Id    :=
-                            Type_Definition (Parent (Typ));
+         Loc     : constant Source_Ptr := Sloc (Typ);
+         Typ_Def : constant Node_Id    := Type_Definition (Parent (Typ));
 
-         Bod_Stmts       : List_Id;
-         Finalizer_Data  : Finalization_Exception_Data;
-         Finalizer_Decls : List_Id := No_List;
-         Rec_Def         : Node_Id;
-         Var_Case        : Node_Id;
+         Finalizer_Data : Finalization_Exception_Data;
 
          function Process_Component_List_For_Adjust
            (Comps : Node_Id) return List_Id;
@@ -6581,6 +6570,7 @@ package body Exp_Ch7 is
             Decl_Typ  : Entity_Id;
             Has_POC   : Boolean;
             Num_Comps : Nat;
+            Var_Case  : Node_Id;
 
          --  Start of processing for Process_Component_List_For_Adjust
 
@@ -6710,6 +6700,12 @@ package body Exp_Ch7 is
             return Stmts;
          end Process_Component_List_For_Adjust;
 
+         --  Local variables
+
+         Bod_Stmts       : List_Id;
+         Finalizer_Decls : List_Id := No_List;
+         Rec_Def         : Node_Id;
+
       --  Start of processing for Build_Adjust_Statements
 
       begin
@@ -6914,18 +6910,12 @@ package body Exp_Ch7 is
       -------------------------------
 
       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
-         Exceptions_OK  : constant Boolean    :=
-                            not Restriction_Active (No_Exception_Propagation);
-         Loc            : constant Source_Ptr := Sloc (Typ);
-         Typ_Def        : constant Node_Id    :=
-                            Type_Definition (Parent (Typ));
+         Loc     : constant Source_Ptr := Sloc (Typ);
+         Typ_Def : constant Node_Id    := Type_Definition (Parent (Typ));
 
-         Bod_Stmts       : List_Id;
-         Counter         : Int := 0;
-         Finalizer_Data  : Finalization_Exception_Data;
-         Finalizer_Decls : List_Id := No_List;
-         Rec_Def         : Node_Id;
-         Var_Case        : Node_Id;
+         Counter        : Int := 0;
+         Finalizer_Data : Finalization_Exception_Data;
+         Num_Comps      : Nat := 0;
 
          function Process_Component_List_For_Finalize
            (Comps : Node_Id) return List_Id;
@@ -6940,19 +6930,6 @@ package body Exp_Ch7 is
          function Process_Component_List_For_Finalize
            (Comps : Node_Id) return List_Id
          is
-            Alts       : List_Id;
-            Counter_Id : Entity_Id;
-            Decl       : Node_Id;
-            Decl_Id    : Entity_Id;
-            Decl_Typ   : Entity_Id;
-            Decls      : List_Id;
-            Has_POC    : Boolean;
-            Jump_Block : Node_Id;
-            Label      : Node_Id;
-            Label_Id   : Entity_Id;
-            Num_Comps  : Nat;
-            Stmts      : List_Id;
-
             procedure Process_Component_For_Finalize
               (Decl  : Node_Id;
                Alts  : List_Id;
@@ -7066,6 +7043,21 @@ package body Exp_Ch7 is
                end if;
             end Process_Component_For_Finalize;
 
+            --  Local variables
+
+            Alts       : List_Id;
+            Counter_Id : Entity_Id;
+            Decl       : Node_Id;
+            Decl_Id    : Entity_Id;
+            Decl_Typ   : Entity_Id;
+            Decls      : List_Id;
+            Has_POC    : Boolean;
+            Jump_Block : Node_Id;
+            Label      : Node_Id;
+            Label_Id   : Entity_Id;
+            Stmts      : List_Id;
+            Var_Case   : Node_Id;
+
          --  Start of processing for Process_Component_List_For_Finalize
 
          begin
@@ -7286,6 +7278,12 @@ package body Exp_Ch7 is
             end if;
          end Process_Component_List_For_Finalize;
 
+         --  Local variables
+
+         Bod_Stmts       : List_Id;
+         Finalizer_Decls : List_Id := No_List;
+         Rec_Def         : Node_Id;
+
       --  Start of processing for Build_Finalize_Statements
 
       begin

gcc/ada/exp_util.adb

@@ -4784,6 +4784,18 @@ package body Exp_Util is
       end if;
    end Evolve_Or_Else;
 
+   -----------------------------------
+   -- Exceptions_In_Finalization_OK --
+   -----------------------------------
+
+   function Exceptions_In_Finalization_OK return Boolean is
+   begin
+      return
+        not (Restriction_Active (No_Exception_Handlers)    or else
+             Restriction_Active (No_Exception_Propagation) or else
+             Restriction_Active (No_Exceptions));
+   end Exceptions_In_Finalization_OK;
+
    -----------------------------------------
    -- Expand_Static_Predicates_In_Choices --
    -----------------------------------------

gcc/ada/exp_util.ads

@@ -535,6 +535,10 @@ package Exp_Util is
    --  indicating that no checks were required). The Sloc field of the
    --  constructed N_Or_Else node is copied from Cond1.
 
+   function Exceptions_In_Finalization_OK return Boolean;
+   --  Determine whether the finalization machinery can safely add exception
+   --  handlers and recovery circuitry.
+
    procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
    --  N is either a case alternative or a variant. The Discrete_Choices field
    --  of N points to a list of choices. If any of these choices is the name

gcc/ada/sem_ch10.adb

@@ -1134,7 +1134,7 @@ package body Sem_Ch10 is
             Style_Check := Save_Style_Check;
          end;
 
-         --  In GNATprove mode, force the loading of a Interrupt_Priority when
+         --  In GNATprove mode, force the loading of an Interrupt_Priority when
          --  processing compilation units with potentially "main" subprograms.
          --  This is required for the ceiling priority protocol checks, which
          --  are triggered by these subprograms.

gcc/ada/sem_ch11.adb

@@ -165,8 +165,24 @@ package body Sem_Ch11 is
 
    begin
       Handler := First (L);
-      Check_Restriction (No_Exceptions, Handler);
-      Check_Restriction (No_Exception_Handlers, Handler);
+
+      --  Pragma Restriction_Warnings has more related semantics than pragma
+      --  Restrictions in that it flags exception handlers as violators. Note
+      --  that the compiler must still generate handlers for certain critical
+      --  scenarios such as finalization. As a result, these handlers should
+      --  not be subjected to the restriction check when in warnings mode.
+
+      if not Comes_From_Source (Handler)
+        and then (Restriction_Warnings (No_Exception_Handlers)
+                   or else Restriction_Warnings (No_Exception_Propagation)
+                   or else Restriction_Warnings (No_Exceptions))
+      then
+         null;
+
+      else
+         Check_Restriction (No_Exceptions, Handler);
+         Check_Restriction (No_Exception_Handlers, Handler);
+      end if;
 
       --  Kill current remembered values, since we don't know where we were
       --  when the exception was raised.

gcc/ada/sem_ch3.adb

@@ -1717,6 +1717,43 @@ package body Sem_Ch3 is
                   Derived_Type => Tagged_Type,
                   Parent_Type  => Iface);
 
+               declare
+                  Anc : Entity_Id;
+               begin
+                  if Is_Inherited_Operation (Prim)
+                    and then Present (Alias (Prim))
+                  then
+                     Anc := Alias (Prim);
+                  else
+                     Anc := Overridden_Operation (Prim);
+                  end if;
+
+                  --  Apply legality checks in RM 6.1.1 (10-13) concerning
+                  --  non-conforming preconditions in both an ancestor and
+                  --  a progenitor operation.
+
+                  if Present (Anc)
+                    and then Has_Non_Trivial_Precondition (Anc)
+                    and then Has_Non_Trivial_Precondition (Iface_Prim)
+                  then
+                     if Is_Abstract_Subprogram (Prim)
+                       or else (Ekind (Prim) = E_Procedure
+                         and then
+                           Nkind (Parent (Prim)) = N_Procedure_Specification
+                         and then Null_Present (Parent (Prim)))
+                     then
+                        null;
+
+                     --  The inherited operation must be overridden
+
+                     elsif not Comes_From_Source (Prim) then
+                        Error_Msg_NE ("&inherits non-conforming preconditions "
+                          & "and must be overridden (RM 6.1.1 (10-16)",
+                            Parent (Tagged_Type), Prim);
+                     end if;
+                  end if;
+               end;
+
                --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
                --  associated with interface types. These entities are
                --  only registered in the list of primitives of its

gcc/ada/sem_ch8.adb

@@ -3191,6 +3191,19 @@ package body Sem_Ch8 is
               ("renamed entity cannot be subprogram that requires overriding "
                & "(RM 8.5.4 (5.1))", N);
          end if;
+
+         declare
+            Prev : constant Entity_Id := Overridden_Operation (New_S);
+         begin
+            if Present (Prev)
+              and then
+                 (Has_Non_Trivial_Precondition (Prev)
+                    or else Has_Non_Trivial_Precondition (Old_S))
+            then
+               Error_Msg_NE ("conflicting inherited classwide preconditions "
+                 & "in renaming of& (RM 6.1.1 (17)", N, Old_S);
+            end if;
+         end;
       end if;
 
       if Old_S /= Any_Id then

gcc/ada/sem_disp.adb

@@ -574,9 +574,7 @@ package body Sem_Disp is
             --  a primitive of an abstract type. The call is non-dispatching
             --  but will be legal in overridings of the operation.
 
-            elsif In_Spec_Expression
-              and then
-                (Is_Subprogram (Scop)
+            elsif (Is_Subprogram (Scop)
                   or else Chars (Scop) = Name_Postcondition)
               and then
                 (Is_Abstract_Subprogram (Scop)

gcc/ada/sem_util.adb

@@ -9820,6 +9820,18 @@ package body Sem_Util is
           and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
    end Has_Non_Null_Refinement;
 
+   ----------------------------------
+   -- Has_Non_Trivial_Precondition --
+   ----------------------------------
+
+   function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is
+      Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre);
+   begin
+      return Present (Cont)
+        and then Class_Present (Cont)
+        and then not Is_Entity_Name (Expression (Cont));
+   end Has_Non_Trivial_Precondition;
+
    -------------------
    -- Has_Null_Body --
    -------------------

gcc/ada/sem_util.ads

@@ -1169,6 +1169,10 @@ package Sem_Util is
    --  null statement, possibly followed by an optional return. Used to
    --  optimize useless calls to assertion checks.
 
+      function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean;
+      --  True if subprogram has a class-wide precondition that is not
+      --  statically True.
+
    function Has_Null_Exclusion (N : Node_Id) return Boolean;
    --  Determine whether node N has a null exclusion