From f991bd8ec959efdc59d8eeafb72a9a8589774a8c Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 23 Jan 2017 11:21:37 +0000 Subject: [PATCH] sem_ch3.adb, [...]: Minor reformatting. 2017-01-23 Hristian Kirtchev * 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 * 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 --- gcc/ada/ChangeLog | 15 +++++++++ gcc/ada/exp_attr.adb | 6 ++-- gcc/ada/exp_ch3.adb | 41 ++++++++++++----------- gcc/ada/exp_spark.adb | 7 ++-- gcc/ada/freeze.adb | 76 ++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 37 ++++++++++++++++++++- gcc/ada/sem_ch9.adb | 1 + gcc/ada/sem_prag.adb | 15 +++++---- gcc/ada/sem_util.adb | 1 + gcc/ada/sem_warn.adb | 8 ++--- 11 files changed, 166 insertions(+), 43 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cc26c9f3793..6d68dc1d7d5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2017-01-23 Hristian Kirtchev + + * 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 + + * 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 * exp_spark.adb (Expand_SPARK_Attribute_Reference): For attributes diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 72a7f53a4d1..e3f3f70ca5e 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 402434964bc..788cf7f0da7 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 e93f71dad05..bd898904865 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 c6cb52e9cec..e6b934f3e59 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 096170bdf5e..79127a38ffd 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 5152ac1988c..2591aafbb85 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 b26e2b4eabd..fe9f4ba621b 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 f34e2ff7f5a..e30ab13f29e 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 f8ac8ce0d38..694e112a504 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 ad278e89d1f..29bdfd4886f 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 -- 2.30.2