sem_ch3.adb, [...]: Minor reformatting.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb, exp_spark.adb, exp_attr.adb, sem_ch9.adb, sem_prag.adb,
	sem_util.adb, sem_warn.adb, exp_ch3.adb: Minor reformatting.

2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* freeze.adb (Freeze_Subprogram): Ensure that all anonymous
	access-to-subprogram types inherit the convention of the
	associated subprogram.	(Set_Profile_Convention): New routine.
	* sem_ch6.adb (Check_Conformance): Do not compare the conventions
	of the two entities directly, use Conventions_Match to account
	for anonymous access-to-subprogram and subprogram types.
	(Conventions_Match): New routine.

From-SVN: r244778

11 files changed, 166 insertions, 43 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cc26c9f..6d68dc1 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch3.adb, exp_spark.adb, exp_attr.adb, sem_ch9.adb, sem_prag.adb,
+	sem_util.adb, sem_warn.adb, exp_ch3.adb: Minor reformatting.
+
+2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* freeze.adb (Freeze_Subprogram): Ensure that all anonymous
+	access-to-subprogram types inherit the convention of the
+	associated subprogram.	(Set_Profile_Convention): New routine.
+	* sem_ch6.adb (Check_Conformance): Do not compare the conventions
+	of the two entities directly, use Conventions_Match to account
+	for anonymous access-to-subprogram and subprogram types.
+	(Conventions_Match): New routine.
+
 2017-01-23  Claire Dross  <dross@adacore.com>
 
 	* exp_spark.adb (Expand_SPARK_Attribute_Reference): For attributes
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 72a7f53..e3f3f70 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2682,8 +2682,8 @@ package body Exp_Attr is
                         Res := True;
                      end if;
                   end if;
-               else
 
+               else
                   --  For access type, apply access check as needed
 
                   if Is_Access_Type (Ptyp) then
@@ -2700,9 +2700,9 @@ package body Exp_Attr is
                   if not Is_Variable (Pref)
                     or else Present (Formal_Ent)
                     or else (Ada_Version < Ada_2005
-                               and then Is_Aliased_View (Pref))
+                              and then Is_Aliased_View (Pref))
                     or else (Ada_Version >= Ada_2005
-                               and then Is_Constrained_Aliased_View (Pref))
+                              and then Is_Constrained_Aliased_View (Pref))
                   then
                      Res := True;
 
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 4024349..788cf7f 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -5620,42 +5620,45 @@ package body Exp_Ch3 is
          if Is_Array_Type (Typ)
            and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
          then
-            --  To prevent arithmetic overflow with large values, we
-            --  raise Storage_Error under the following guard:
-            --
-            --  (Arr'Last / 2 - Arr'First / 2) > (Typ'Last - 1) / 2
-
-            --  This takes care of the boundary case, but it is preferable
-            --  to use a smaller limit, because even on 64-bit architectures
-            --  an array of more than 2 ** 30 bytes is likely to raise
+            --  To prevent arithmetic overflow with large values, we raise
+            --  Storage_Error under the following guard:
+
+            --    (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
+
+            --  This takes care of the boundary case, but it is preferable to
+            --  use a smaller limit, because even on 64-bit architectures an
+            --  array of more than 2 ** 30 bytes is likely to raise
             --  Storage_Error.
 
             Index_Typ := Etype (First_Index (Typ));
+
             if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
                Insert_Action (N,
-                  Make_Raise_Storage_Error (Loc,
+                 Make_Raise_Storage_Error (Loc,
                    Condition =>
                      Make_Op_Ge (Loc,
                        Left_Opnd  =>
                          Make_Op_Subtract (Loc,
-                           Left_Opnd =>
+                           Left_Opnd  =>
                              Make_Op_Divide (Loc,
-                               Left_Opnd =>
+                               Left_Opnd  =>
                                  Make_Attribute_Reference (Loc,
-                                   Prefix => New_Occurrence_Of (Typ, Loc),
-                                 Attribute_Name => Name_Last),
-                                Right_Opnd =>
-                                  Make_Integer_Literal (Loc, Uint_2)),
+                                   Prefix         =>
+                                     New_Occurrence_Of (Typ, Loc),
+                                   Attribute_Name => Name_Last),
+                               Right_Opnd =>
+                                 Make_Integer_Literal (Loc, Uint_2)),
                            Right_Opnd =>
                              Make_Op_Divide (Loc,
                                Left_Opnd =>
                                  Make_Attribute_Reference (Loc,
-                                   Prefix => New_Occurrence_Of (Typ, Loc),
+                                   Prefix         =>
+                                     New_Occurrence_Of (Typ, Loc),
                                    Attribute_Name => Name_First),
-                                Right_Opnd =>
-                                  Make_Integer_Literal (Loc, Uint_2))),
+                               Right_Opnd =>
+                                 Make_Integer_Literal (Loc, Uint_2))),
                        Right_Opnd =>
-                         Make_Integer_Literal (Loc,  (Uint_2 ** 30))),
+                         Make_Integer_Literal (Loc, (Uint_2 ** 30))),
                    Reason    => SE_Object_Too_Large));
             end if;
          end if;
diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb
index e93f71d..bd89890 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -174,7 +174,6 @@ package body Exp_SPARK is
         or else Attr_Id = Attribute_Aft
         or else Attr_Id = Attribute_Max_Alignment_For_Allocation
       then
-
          --  If the expected type is Long_Long_Integer, there will be no check
          --  flag as the compiler assumes attributes always fit in this type.
          --  Since in SPARK_Mode we do not take Storage_Error into account, we
@@ -187,12 +186,14 @@ package body Exp_SPARK is
          begin
             if Attr_Id = Attribute_Range_Length then
                Typ := Etype (Prefix (N));
+
             elsif Attr_Id = Attribute_Length then
                Typ := Etype (Prefix (N));
 
                declare
-                  Indx   : Node_Id;
-                  J      : Int;
+                  Indx : Node_Id;
+                  J    : Int;
+
                begin
                   if Is_Access_Type (Typ) then
                      Typ := Designated_Type (Typ);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index c6cb52e..e6b934f 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7945,8 +7945,61 @@ package body Freeze is
    -----------------------
 
    procedure Freeze_Subprogram (E : Entity_Id) is
-      Retype : Entity_Id;
+      procedure Set_Profile_Convention (Subp_Id : Entity_Id);
+      --  Set the conventions of all anonymous access-to-subprogram formals and
+      --  result subtype of subprogram Subp_Id to the convention of Subp_Id.
+
+      ----------------------------
+      -- Set_Profile_Convention --
+      ----------------------------
+
+      procedure Set_Profile_Convention (Subp_Id : Entity_Id) is
+         Conv : constant Convention_Id := Convention (Subp_Id);
+
+         procedure Set_Type_Convention (Typ : Entity_Id);
+         --  Set the convention of anonymous access-to-subprogram type Typ and
+         --  its designated type to Conv.
+
+         -------------------------
+         -- Set_Type_Convention --
+         -------------------------
+
+         procedure Set_Type_Convention (Typ : Entity_Id) is
+         begin
+            --  Set the convention on both the anonymous access-to-subprogram
+            --  type and the subprogram type it points to because both types
+            --  participate in conformance-related checks.
+
+            if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+               Set_Convention (Typ, Conv);
+               Set_Convention (Designated_Type (Typ), Conv);
+            end if;
+         end Set_Type_Convention;
+
+         --  Local variables
+
+         Formal : Entity_Id;
+
+      --  Start of processing for Set_Profile_Convention
+
+      begin
+         Formal := First_Formal (Subp_Id);
+         while Present (Formal) loop
+            Set_Type_Convention (Etype (Formal));
+            Next_Formal (Formal);
+         end loop;
+
+         if Ekind (Subp_Id) = E_Function then
+            Set_Type_Convention (Etype (Subp_Id));
+         end if;
+      end Set_Profile_Convention;
+
+      --  Local variables
+
       F      : Entity_Id;
+      Retype : Entity_Id;
+
+   --  Start of processing for Freeze_Subprogram
 
    begin
       --  Subprogram may not have an address clause unless it is imported
@@ -7954,8 +8007,7 @@ package body Freeze is
       if Present (Address_Clause (E)) then
          if not Is_Imported (E) then
             Error_Msg_N
-              ("address clause can only be given " &
-               "for imported subprogram",
+              ("address clause can only be given for imported subprogram",
                Name (Address_Clause (E)));
          end if;
       end if;
@@ -7986,8 +8038,8 @@ package body Freeze is
       --  referenced data may change even if the address value does not.
 
       --  Note that if the programmer gave an explicit Pure_Function pragma,
-      --  then we believe the programmer, and leave the subprogram Pure.
-      --  We also suppress this check on run-time files.
+      --  then we believe the programmer, and leave the subprogram Pure. We
+      --  also suppress this check on run-time files.
 
       if Is_Pure (E)
         and then Is_Subprogram (E)
@@ -7997,6 +8049,20 @@ package body Freeze is
          Check_Function_With_Address_Parameter (E);
       end if;
 
+      --  Ensure that all anonymous access-to-subprogram types inherit the
+      --  covention of their related subprogram (RM 6.3.1 13.1/3). This is
+      --  not done for a defaulted convention Ada because those types also
+      --  default to Ada. Convention Protected must not be propagated when
+      --  the subprogram is an entry because this would be illegal. The only
+      --  way to force convention Protected on these kinds of types is to
+      --  include keyword "protected" in the access definition.
+
+      if Convention (E) /= Convention_Ada
+        and then Convention (E) /= Convention_Protected
+      then
+         Set_Profile_Convention (E);
+      end if;
+
       --  For non-foreign convention subprograms, this is where we create
       --  the extra formals (for accessibility level and constrained bit
       --  information). We delay this till the freeze point precisely so
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 096170b..79127a3 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -11943,7 +11943,7 @@ package body Sem_Ch3 is
          else
             Set_Has_Delayed_Freeze (Full,
               Has_Delayed_Freeze (Full_Base)
-                and then (not Is_Frozen (Full_Base)));
+                and then not Is_Frozen (Full_Base));
          end if;
       end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 5152ac1..2591aaf 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4870,6 +4870,12 @@ package body Sem_Ch6 is
       --  in the message, and also provides the location for posting the
       --  message in the absence of a specified Err_Loc location.
 
+      function Conventions_Match
+        (Id1 : Entity_Id;
+         Id2 : Entity_Id) return Boolean;
+      --  Determine whether the conventions of arbitrary entities Id1 and Id2
+      --  match.
+
       -----------------------
       -- Conformance_Error --
       -----------------------
@@ -4929,6 +4935,35 @@ package body Sem_Ch6 is
          end if;
       end Conformance_Error;
 
+      -----------------------
+      -- Conventions_Match --
+      -----------------------
+
+      function Conventions_Match
+        (Id1 : Entity_Id;
+         Id2 : Entity_Id) return Boolean
+      is
+      begin
+         --  Ignore the conventions of anonymous access-to-subprogram types
+         --  and subprogram types because these are internally generated and
+         --  the only way these may receive a convention is if they inherit
+         --  the convention of a related subprogram.
+
+         if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
+                           E_Subprogram_Type)
+              or else
+            Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
+                           E_Subprogram_Type)
+         then
+            return True;
+
+         --  Otherwise compare the conventions directly
+
+         else
+            return Convention (Id1) = Convention (Id2);
+         end if;
+      end Conventions_Match;
+
       --  Local Variables
 
       Old_Type           : constant Entity_Id := Etype (Old_Id);
@@ -5015,7 +5050,7 @@ package body Sem_Ch6 is
       --  entity is inherited.
 
       if Ctype >= Subtype_Conformant then
-         if Convention (Old_Id) /= Convention (New_Id) then
+         if not Conventions_Match (Old_Id, New_Id) then
             if not Is_Frozen (New_Id) then
                null;
 
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index b26e2b4..fe9f4ba 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -1154,6 +1154,7 @@ package body Sem_Ch9 is
 
    procedure Analyze_Delay_Relative (N : Node_Id) is
       E : constant Node_Id := Expression (N);
+
    begin
       Tasking_Used := True;
       Check_SPARK_05_Restriction ("delay statement is not allowed", N);
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index f34e2ff..e30ab13 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -23950,9 +23950,9 @@ package body Sem_Prag is
 
             --  Attribute 'Result matches attribute 'Result
 
-            elsif Is_Attribute_Result (Dep_Item)
-               and then Is_Attribute_Result (Ref_Item)
-            then
+            --  ??? this is incorrect, Ref_Item should be checked as well
+
+            elsif Is_Attribute_Result (Dep_Item) then
                Matched := True;
 
             --  Abstract states, current instances of concurrent types,
@@ -29491,13 +29491,14 @@ package body Sem_Prag is
         and then not ASIS_Mode
       then
          if Chars (N) = Name_Precondition
-          or else Chars (N) = Name_Postcondition
+           or else Chars (N) = Name_Postcondition
          then
-            Error_Msg_N (" Check_Policy is a non-standard pragma??", N);
+            Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
             Error_Msg_N
-              (" \use Assertion_Policy and aspect names Pre/Post"
-                & " for Ada2012 conformance?", N);
+              ("\use Assertion_Policy and aspect names Pre/Post for "
+               & "Ada2012 conformance?", N);
          end if;
+
          return;
       end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index f8ac8ce..694e112 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5006,6 +5006,7 @@ package body Sem_Util is
    procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
       pragma Assert (not Has_Aspects (To));
       Asp : Node_Id;
+
    begin
       if Has_Aspects (From) then
          Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index ad278e8..29bdfd4 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -4336,12 +4336,12 @@ package body Sem_Warn is
                         --  Give appropriate message, distinguishing between
                         --  assignment statements and out parameters.
 
-                        if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
-                                                  N_Parameter_Association)
+                        if Nkind_In (Parent (LA), N_Parameter_Association,
+                                                  N_Procedure_Call_Statement)
                         then
                            Error_Msg_NE
-                             ("?m?& modified by call, but value might not "
-                              & "be referenced", LA, Ent);
+                             ("?m?& modified by call, but value might not be "
+                              & "referenced", LA, Ent);
 
                         else
                            Error_Msg_NE -- CODEFIX