[multiple changes]

2017-01-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry):
	Hnadle properly the attribute reference when it appears as part
	of an expression in another loop aspect.

2017-01-12  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Check_Predicated_Discriminant): New procedure,
	subsidiary of Build_Initialization_Call, to complete generation
	of predicate checks on discriminants whose (sub)types have
	predicates, and to add checks on variants that do not have an
	others clause.
	* sem_util.adb (Gather_Components): A missing Others alternative is
	not an error when the type of the discriminant is a static predicate
	(and coverage has been checked when analyzing the case statement). A
	runtime check is generated to verify that a given discriminant
	satisfies the predicate (RM 3.8.1. (21.1/2)).

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

	* gnat1drv.adb (Adjust_Global_Switches): Only
	perform checking of exception mechanism when generating code.

2017-01-12  Justin Squirek  <squirek@adacore.com>

	* exp_ch7.adb (Add_Type_Invariants, Process_Array_Component):
	Remove handling of access component with invariant.
	(Build_Invariant_Procedure_Declaration): Remove return on class
	wide type.
	* freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove
	conditional exception for component or array so Has_Own_Invariants
	flag is not falsly set.
	* sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class
	wide type to have no invariant flags.

From-SVN: r244366

gcc/ada/ChangeLog

+2017-01-12  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry):
+	Hnadle properly the attribute reference when it appears as part
+	of an expression in another loop aspect.
+
+2017-01-12  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch3.adb (Check_Predicated_Discriminant): New procedure,
+	subsidiary of Build_Initialization_Call, to complete generation
+	of predicate checks on discriminants whose (sub)types have
+	predicates, and to add checks on variants that do not have an
+	others clause.
+	* sem_util.adb (Gather_Components): A missing Others alternative is
+	not an error when the type of the discriminant is a static predicate
+	(and coverage has been checked when analyzing the case statement). A
+	runtime check is generated to verify that a given discriminant
+	satisfies the predicate (RM 3.8.1. (21.1/2)).
+
+2017-01-12  Yannick Moy  <moy@adacore.com>
+
+	* gnat1drv.adb (Adjust_Global_Switches): Only
+	perform checking of exception mechanism when generating code.
+
+2017-01-12  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch7.adb (Add_Type_Invariants, Process_Array_Component):
+	Remove handling of access component with invariant.
+	(Build_Invariant_Procedure_Declaration): Remove return on class
+	wide type.
+	* freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove
+	conditional exception for component or array so Has_Own_Invariants
+	flag is not falsly set.
+	* sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class
+	wide type to have no invariant flags.
+
 2017-01-12  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb,

gcc/ada/exp_ch3.adb

@@ -1286,7 +1286,118 @@ package body Exp_Ch3 is
       With_Default_Init : Boolean := False;
       Constructor_Ref   : Node_Id := Empty) return List_Id
    is
-      Res            : constant List_Id := New_List;
+      Res : constant List_Id := New_List;
+
+      Full_Type : Entity_Id;
+
+      procedure Check_Predicated_Discriminant
+        (Val   : Node_Id;
+         Discr : Entity_Id);
+      --  Discriminants whose subtypes have predicates are checked in two
+      --  cases:
+      --    a) When an object is default-initialized and assertions are enabled
+      --       we check that the value of the discriminant obeys the predicate.
+
+      --    b) In all cases, if the discriminant controls a variant and the
+      --       variant has no others_choice, Constraint_Error must be raised if
+      --       the predicate is violated, because there is no variant covered
+      --       by the illegal discriminant value.
+
+      -----------------------------------
+      -- Check_Predicated_Discriminant --
+      -----------------------------------
+
+      procedure Check_Predicated_Discriminant
+        (Val   : Node_Id;
+         Discr : Entity_Id)
+      is
+         Typ : constant Entity_Id := Etype (Discr);
+
+         procedure Check_Missing_Others (V : Node_Id);
+         --  ???
+
+         --------------------------
+         -- Check_Missing_Others --
+         --------------------------
+
+         procedure Check_Missing_Others (V : Node_Id) is
+            Alt      : Node_Id;
+            Choice   : Node_Id;
+            Last_Var : Node_Id;
+
+         begin
+            Last_Var := Last_Non_Pragma (Variants (V));
+            Choice   := First (Discrete_Choices (Last_Var));
+
+            --  An others_choice is added during expansion for gcc use, but
+            --  does not cover the illegality.
+
+            if Entity (Name (V)) = Discr then
+               if Present (Choice)
+                 and then (Nkind (Choice) /= N_Others_Choice
+                            or else not Comes_From_Source (Choice))
+               then
+                  Check_Expression_Against_Static_Predicate (Val, Typ);
+
+                  if not Is_Static_Expression (Val) then
+                     Prepend_To (Res,
+                        Make_Raise_Constraint_Error (Loc,
+                          Condition =>
+                            Make_Op_Not (Loc,
+                              Right_Opnd => Make_Predicate_Call (Typ, Val)),
+                          Reason    => CE_Invalid_Data));
+                  end if;
+               end if;
+            end if;
+
+            --  Check whether some nested variant is ruled by the predicated
+            --  discriminant.
+
+            Alt := First (Variants (V));
+            while Present (Alt) loop
+               if Nkind (Alt) = N_Variant
+                 and then Present (Variant_Part (Component_List (Alt)))
+               then
+                  Check_Missing_Others
+                    (Variant_Part (Component_List (Alt)));
+               end if;
+
+               Next (Alt);
+            end loop;
+         end Check_Missing_Others;
+
+         --  Local variables
+
+         Def : Node_Id;
+
+      --  Start of processing for Check_Predicated_Discriminant
+
+      begin
+         if Ekind (Base_Type (Full_Type)) = E_Record_Type then
+            Def := Type_Definition (Parent (Base_Type (Full_Type)));
+         else
+            return;
+         end if;
+
+         if Policy_In_Effect (Name_Assert) = Name_Check
+           and then not Predicates_Ignored (Etype (Discr))
+         then
+            Prepend_To (Res, Make_Predicate_Check (Typ, Val));
+         end if;
+
+         --  If discriminant controls a variant, verify that predicate is
+         --  obeyed or else an Others_Choice is present.
+
+         if Nkind (Def) = N_Record_Definition
+           and then Present (Variant_Part (Component_List (Def)))
+           and then Policy_In_Effect (Name_Assert) = Name_Ignore
+         then
+            Check_Missing_Others (Variant_Part (Component_List (Def)));
+         end if;
+      end Check_Predicated_Discriminant;
+
+      --  Local variables
+
       Arg            : Node_Id;
       Args           : List_Id;
       Decls          : List_Id;
@@ -1294,11 +1405,12 @@ package body Exp_Ch3 is
       Discr          : Entity_Id;
       First_Arg      : Node_Id;
       Full_Init_Type : Entity_Id;
-      Full_Type      : Entity_Id;
       Init_Call      : Node_Id;
       Init_Type      : Entity_Id;
       Proc           : Entity_Id;
 
+   --  Start of processing for Build_Initialization_Call
+
    begin
       pragma Assert (Constructor_Ref = Empty
         or else Is_CPP_Constructor_Call (Constructor_Ref));
@@ -1490,14 +1602,10 @@ package body Exp_Ch3 is
                   --  of the discriminant, insert it ahead of the call.
 
                   Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
+               end if;
 
-                  if Has_Predicates (Etype (Discr))
-                    and then not Predicate_Checks_Suppressed (Empty)
-                    and then not Predicates_Ignored (Etype (Discr))
-                  then
-                     Prepend_To (Res,
-                       Make_Predicate_Check (Etype (Discr), Arg));
-                  end if;
+               if Has_Predicates (Etype (Discr)) then
+                  Check_Predicated_Discriminant (Arg, Discr);
                end if;
             end if;
 

gcc/ada/exp_ch7.adb

@@ -3605,60 +3605,6 @@ package body Exp_Ch7 is
 
                Produced_Check := True;
             end if;
-
-            --  In a rare case the designated type of an access component may
-            --  have an invariant. In this case verify the dereference of the
-            --  component.
-
-            if Is_Access_Type (Comp_Typ)
-              and then Has_Invariants (Designated_Type (Comp_Typ))
-            then
-               Proc_Id :=
-                 Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
-
-               --  The designated type should have an invariant procedure if it
-               --  has invariants of its own or inherits class-wide invariants
-               --  from parent or interface types.
-
-               pragma Assert (Present (Proc_Id));
-
-               --  Generate:
-               --    if _object (<Indexes>) /= null then
-               --       <Desig_Comp_Typ>Invariant (_object (<Indices>).all);
-               --    end if;
-
-               --  Note that the invariant procedure may have a null body if
-               --  assertions are disabled or Assertion_Polity Ignore is in
-               --  effect.
-
-               if not Has_Null_Body (Proc_Id) then
-                  Append_New_To (Comp_Checks,
-                    Make_If_Statement (Loc,
-                      Condition       =>
-                        Make_Op_Ne (Loc,
-                          Left_Opnd  =>
-                            Make_Indexed_Component (Loc,
-                              Prefix      => New_Occurrence_Of (Obj_Id, Loc),
-                              Expressions => New_Copy_List (Indices)),
-                          Right_Opnd => Make_Null (Loc)),
-
-                      Then_Statements => New_List (
-                        Make_Procedure_Call_Statement (Loc,
-                          Name                   =>
-                            New_Occurrence_Of (Proc_Id, Loc),
-
-                          Parameter_Associations => New_List (
-                            Make_Explicit_Dereference (Loc,
-                              Prefix =>
-                                Make_Indexed_Component (Loc,
-                                  Prefix      =>
-                                    New_Occurrence_Of (Obj_Id, Loc),
-                                  Expressions =>
-                                    New_Copy_List (Indices))))))));
-               end if;
-
-               Produced_Check := True;
-            end if;
          end Process_Array_Component;
 
          ---------------------------
@@ -4001,65 +3947,6 @@ package body Exp_Ch7 is
                Produced_Component_Check := True;
             end if;
 
-            --  In a rare case the designated type of an access component may
-            --  have a invariant. In this case verify the dereference of the
-            --  component.
-
-            if Is_Access_Type (Comp_Typ)
-              and then Has_Invariants (Designated_Type (Comp_Typ))
-            then
-               Proc_Id :=
-                 Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
-
-               --  The designated type should have an invariant procedure if it
-               --  has invariants of its own or inherits class-wide invariants
-               --  from parent or interface types.
-
-               pragma Assert (Present (Proc_Id));
-
-               --  Generate:
-               --    if T (_object).<Comp_Id> /= null then
-               --       <Desig_Comp_Typ>Invariant (T (_object).<Comp_Id>.all);
-               --    end if;
-
-               --  Note that the invariant procedure may have a null body if
-               --  assertions are disabled or Assertion_Polity Ignore is in
-               --  effect.
-
-               if not Has_Null_Body (Proc_Id) then
-                  Append_New_To (Comp_Checks,
-                    Make_If_Statement (Loc,
-                      Condition       =>
-                        Make_Op_Ne (Loc,
-                          Left_Opnd  =>
-                            Make_Selected_Component (Loc,
-                              Prefix        =>
-                                Unchecked_Convert_To
-                                  (T, New_Occurrence_Of (Obj_Id, Loc)),
-                              Selector_Name =>
-                                New_Occurrence_Of (Comp_Id, Loc)),
-                          Right_Opnd => Make_Null (Loc)),
-
-                      Then_Statements => New_List (
-                        Make_Procedure_Call_Statement (Loc,
-                          Name                   =>
-                            New_Occurrence_Of (Proc_Id, Loc),
-
-                          Parameter_Associations => New_List (
-                            Make_Explicit_Dereference (Loc,
-                              Prefix =>
-                                Make_Selected_Component (Loc,
-                                  Prefix        =>
-                                    Unchecked_Convert_To
-                                      (T, New_Occurrence_Of (Obj_Id, Loc)),
-                                  Selector_Name =>
-                                    New_Occurrence_Of (Comp_Id, Loc))))))));
-               end if;
-
-               Produced_Check           := True;
-               Produced_Component_Check := True;
-            end if;
-
             if Produced_Component_Check and then Has_Unchecked_Union (T) then
                Error_Msg_NE
                  ("invariants cannot be checked on components of "
@@ -4525,15 +4412,10 @@ package body Exp_Ch7 is
 
       pragma Assert (Has_Invariants (Work_Typ));
 
-      --  ??? invariants of class-wide types are not properly implemented
-
-      if Is_Class_Wide_Type (Work_Typ) then
-         return;
-
       --  Nothing to do for interface types as their class-wide invariants are
       --  inherited by implementing types.
 
-      elsif Is_Interface (Work_Typ) then
+      if Is_Interface (Work_Typ) then
          return;
       end if;
 
@@ -4849,15 +4731,10 @@ package body Exp_Ch7 is
 
       pragma Assert (Has_Invariants (Work_Typ));
 
-      --  ??? invariants of class-wide types are not properly implemented
-
-      if Is_Class_Wide_Type (Work_Typ) then
-         return;
-
       --  Nothing to do for interface types as their class-wide invariants are
       --  inherited by implementing types.
 
-      elsif Is_Interface (Work_Typ) then
+      if Is_Interface (Work_Typ) then
          return;
 
       --  Nothing to do if the type already has a "partial" invariant procedure

gcc/ada/freeze.adb

@@ -2377,12 +2377,7 @@ package body Freeze is
             --  The array type requires its own invariant procedure in order to
             --  verify the component invariant over all elements.
 
-            if Has_Invariants (Component_Type (Arr))
-              or else
-                (Is_Access_Type (Component_Type (Arr))
-                  and then Has_Invariants
-                             (Designated_Type (Component_Type (Arr))))
-            then
+            if Has_Invariants (Component_Type (Arr)) then
                Set_Has_Own_Invariants (Arr);
 
                --  The array type is an implementation base type. Propagate the
@@ -4305,12 +4300,7 @@ package body Freeze is
                --  parent class-wide invariants are always inherited.
 
                if Comes_From_Source (Comp)
-                 and then
-                   (Has_Invariants (Etype (Comp))
-                     or else
-                       (Is_Access_Type (Etype (Comp))
-                         and then Has_Invariants
-                                    (Designated_Type (Etype (Comp)))))
+                 and then Has_Invariants (Etype (Comp))
                then
                   Set_Has_Own_Invariants (Rec);
                end if;

gcc/ada/gnat1drv.adb

@@ -521,28 +521,35 @@ procedure Gnat1drv is
          Targparm.Frontend_Layout_On_Target := True;
       end if;
 
-      --  Set and check exception mechanism
-
-      case Targparm.Frontend_Exceptions_On_Target is
-         when True =>
-            case Targparm.ZCX_By_Default_On_Target is
-               when True =>
-                  Write_Line
-                    ("Run-time library configured incorrectly");
-                  Write_Line
-                    ("(requesting support for Frontend ZCX exceptions)");
-                  raise Unrecoverable_Error;
-               when False =>
-                  Exception_Mechanism := Front_End_SJLJ;
-            end case;
-         when False =>
-            case Targparm.ZCX_By_Default_On_Target is
-               when True =>
-                  Exception_Mechanism := Back_End_ZCX;
-               when False =>
-                  Exception_Mechanism := Back_End_SJLJ;
-            end case;
-      end case;
+      --  Set and check exception mechanism. This is only meaningful when
+      --  compiling, and in particular not meaningful for special modes used
+      --  for program analysis rather than compilation: ASIS mode, CodePeer
+      --  mode and GNATprove mode.
+
+      if Operating_Mode = Generate_Code
+        and then not (ASIS_Mode or CodePeer_Mode or GNATprove_Mode)
+      then
+         case Targparm.Frontend_Exceptions_On_Target is
+            when True =>
+               case Targparm.ZCX_By_Default_On_Target is
+                  when True =>
+                     Write_Line
+                       ("Run-time library configured incorrectly");
+                     Write_Line
+                       ("(requesting support for Frontend ZCX exceptions)");
+                     raise Unrecoverable_Error;
+                  when False =>
+                     Exception_Mechanism := Front_End_SJLJ;
+               end case;
+            when False =>
+               case Targparm.ZCX_By_Default_On_Target is
+                  when True =>
+                     Exception_Mechanism := Back_End_ZCX;
+                  when False =>
+                     Exception_Mechanism := Back_End_SJLJ;
+               end case;
+         end case;
+      end if;
 
       --  Set proper status for overflow check mechanism
 

gcc/ada/sem_attr.adb

@@ -4465,7 +4465,17 @@ package body Sem_Attr is
          --  purpose if they appear in an appropriate location in a loop,
          --  which was already checked by the top level pragma circuit).
 
-         if No (Enclosing_Pragma) then
+         --  Loop_Entry also denotes a value and as such can appear within an
+         --  expression that is an argument for another loop aspect. In that
+         --  case it will have been expanded into the corresponding assignment.
+
+         if Expander_Active
+           and then Nkind (Parent (N)) = N_Assignment_Statement
+           and then not Comes_From_Source (Parent (N))
+         then
+            null;
+
+         elsif No (Enclosing_Pragma) then
             Error_Attr ("attribute% must appear within appropriate pragma", N);
          end if;
 
@@ -4519,7 +4529,9 @@ package body Sem_Attr is
          --  early transformation also avoids the generation of a useless loop
          --  entry constant.
 
-         if Is_Ignored (Enclosing_Pragma) then
+         if Present (Enclosing_Pragma)
+           and then Is_Ignored (Enclosing_Pragma)
+         then
             Rewrite (N, Relocate_Node (P));
             Preanalyze_And_Resolve (N);
 
@@ -11039,7 +11051,7 @@ package body Sem_Attr is
 
             if Is_Entity_Name (P)
              and then (Attr_Id = Attribute_Unrestricted_Access
-                       or else Is_Subprogram (Entity (P)))
+                        or else Is_Subprogram (Entity (P)))
             then
                Set_Address_Taken (Entity (P));
             end if;

gcc/ada/sem_ch3.adb

@@ -18307,7 +18307,8 @@ package body Sem_Ch3 is
       Set_Freeze_Node (CW_Type, Empty);
 
       --  Customize the class-wide type: It has no prim. op., it cannot be
-      --  abstract and its Etype points back to the specific root type.
+      --  abstract, its Etype points back to the specific root type, and it
+      --  cannot have any invariants.
 
       Set_Ekind                       (CW_Type, E_Class_Wide_Type);
       Set_Is_Tagged_Type              (CW_Type, True);
@@ -18316,6 +18317,9 @@ package body Sem_Ch3 is
       Set_Is_Constrained              (CW_Type, False);
       Set_Is_First_Subtype            (CW_Type, Is_First_Subtype (T));
       Set_Default_SSO                 (CW_Type);
+      Set_Has_Inheritable_Invariants  (CW_Type, False);
+      Set_Has_Inherited_Invariants    (CW_Type, False);
+      Set_Has_Own_Invariants          (CW_Type, False);
 
       if Ekind (T) = E_Class_Wide_Subtype then
          Set_Etype (CW_Type, Etype (Base_Type (T)));

gcc/ada/sem_util.adb

@@ -7572,7 +7572,14 @@ package body Sem_Util is
          end loop Find_Discrete_Value;
       end Search_For_Discriminant_Value;
 
-      if No (Variant) then
+      --  The case statement must include a variant that corresponds to the
+      --  value of the discriminant, unless the discriminant type has a
+      --  static predicate. In that case the absence of an others_choice that
+      --  would cover this value becomes a run-time error (3.8,1 (21.1/2)).
+
+      if No (Variant)
+        and then not Has_Static_Predicate (Etype (Discrim_Name))
+      then
          Error_Msg_NE
            ("value of discriminant & is out of range", Discrim_Value, Discrim);
          Report_Errors := True;
@@ -7583,8 +7590,10 @@ package body Sem_Util is
       --  components to the Into list. The nested components are part of
       --  the same record type.
 
-      Gather_Components
-        (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+      if Present (Variant) then
+         Gather_Components
+           (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+      end if;
    end Gather_Components;
 
    ------------------------