From d030f3a45173ca7496c50d47e651638e3ff2f00f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Jul 2016 15:38:37 +0200 Subject: [PATCH] [multiple changes] 2016-07-06 Arnaud Charlet * lib.adb (Check_Same_Extended_Unit): Complete previous change. * sem_intr.adb (Errint): New parameter Relaxed. Refine previous change to only disable errors selectively. * sem_util.adb: minor style fix in object declaration 2016-07-06 Yannick Moy * sem_warn.adb (Check_Infinite_Loop_Warning.Find_Var): Special case a call to a volatile function, so that it does not lead to a warning in that case. 2016-07-06 Hristian Kirtchev * sem_ch12.adb, sem_ch4.adb, sem_ch6.adb: Minor reformatting. 2016-07-06 Hristian Kirtchev * gnat1drv.adb: Code clean up. Do not emit any code generation errors when the unit is ignored Ghost. 2016-07-06 Ed Schonberg * sem_eval.adb (Check_Non_Static_Context): If the expression is a real literal of a floating point type that is part of a larger expression and is not a static expression, transform it into a machine number now so that the rest of the computation, even if other components are static, is not evaluated with extra precision. 2016-07-06 Javier Miranda * sem_ch13.adb (Freeze_Entity_Checks): Undo previous patch and move the needed functionality to Analyze_Freeze_Generic_Entity. (Analyze_Freeze_Generic_Entity): If the entity is not already frozen and has delayed aspects then analyze them. 2016-07-06 Yannick Moy * sem_prag.adb (Analyze_Pragma.Process_Inline.Set_Inline_Flags): Special case for unanalyzed body entity of ghost expression function. From-SVN: r238050 --- gcc/ada/ChangeLog | 43 +++++++++++ gcc/ada/gnat1drv.adb | 174 ++++++++++++++++++++++++------------------- gcc/ada/lib.adb | 9 ++- gcc/ada/sem_ch12.adb | 4 +- gcc/ada/sem_ch13.adb | 22 +++--- gcc/ada/sem_ch4.adb | 22 +++--- gcc/ada/sem_ch6.adb | 23 +++--- gcc/ada/sem_eval.adb | 23 ++++-- gcc/ada/sem_intr.adb | 14 ++-- gcc/ada/sem_prag.adb | 8 ++ gcc/ada/sem_util.adb | 2 +- gcc/ada/sem_warn.adb | 5 ++ 12 files changed, 224 insertions(+), 125 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8e8a370d0a1f..8f060caf8ab0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2016-07-06 Arnaud Charlet + + * lib.adb (Check_Same_Extended_Unit): Complete previous change. + * sem_intr.adb (Errint): New parameter Relaxed. Refine previous + change to only disable errors selectively. + * sem_util.adb: minor style fix in object declaration + +2016-07-06 Yannick Moy + + * sem_warn.adb (Check_Infinite_Loop_Warning.Find_Var): Special case a + call to a volatile function, so that it does not lead to a warning in + that case. + +2016-07-06 Hristian Kirtchev + + * sem_ch12.adb, sem_ch4.adb, sem_ch6.adb: Minor reformatting. + +2016-07-06 Hristian Kirtchev + + * gnat1drv.adb: Code clean up. Do not emit any + code generation errors when the unit is ignored Ghost. + +2016-07-06 Ed Schonberg + + * sem_eval.adb (Check_Non_Static_Context): If the expression + is a real literal of a floating point type that is part of a + larger expression and is not a static expression, transform it + into a machine number now so that the rest of the computation, + even if other components are static, is not evaluated with + extra precision. + +2016-07-06 Javier Miranda + + * sem_ch13.adb (Freeze_Entity_Checks): Undo previous patch and move the + needed functionality to Analyze_Freeze_Generic_Entity. + (Analyze_Freeze_Generic_Entity): If the entity is not already frozen + and has delayed aspects then analyze them. + +2016-07-06 Yannick Moy + + * sem_prag.adb (Analyze_Pragma.Process_Inline.Set_Inline_Flags): + Special case for unanalyzed body entity of ghost expression function. + 2016-07-06 Javier Miranda * sem_ch7.adb (Analyze_Package_Specification): Insert its diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 2ade204e6ab3..acb79a569809 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -89,15 +89,6 @@ with System.OS_Lib; -------------- procedure Gnat1drv is - Main_Unit_Node : Node_Id; - -- Compilation unit node for main unit - - Main_Kind : Node_Kind; - -- Kind of main compilation unit node - - Back_End_Mode : Back_End.Back_End_Mode_Type; - -- Record back-end mode - procedure Adjust_Global_Switches; -- There are various interactions between front-end switch settings, -- including debug switch settings and target dependent parameters. @@ -105,8 +96,9 @@ procedure Gnat1drv is -- We do it after scanning out all the switches, so that we are not -- depending on the order in which switches appear. - procedure Check_Bad_Body; - -- Called to check if the unit we are compiling has a bad body + procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind); + -- Called to check whether a unit described by its compilation unit node + -- and kind has a bad body. procedure Check_Rep_Info; -- Called when we are not generating code, to check if -gnatR was requested @@ -712,10 +704,8 @@ procedure Gnat1drv is -- Check_Bad_Body -- -------------------- - procedure Check_Bad_Body is - Sname : Unit_Name_Type; - Src_Ind : Source_File_Index; - Fname : File_Name_Type; + procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind) is + Fname : File_Name_Type; procedure Bad_Body_Error (Msg : String); -- Issue message for bad body found @@ -726,11 +716,16 @@ procedure Gnat1drv is procedure Bad_Body_Error (Msg : String) is begin - Error_Msg_N (Msg, Main_Unit_Node); + Error_Msg_N (Msg, Unit_Node); Error_Msg_File_1 := Fname; - Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node); + Error_Msg_N ("remove incorrect body in file{!", Unit_Node); end Bad_Body_Error; + -- Local variables + + Sname : Unit_Name_Type; + Src_Ind : Source_File_Index; + -- Start of processing for Check_Bad_Body begin @@ -743,13 +738,13 @@ procedure Gnat1drv is -- Check for body not allowed - if (Main_Kind = N_Package_Declaration - and then not Body_Required (Main_Unit_Node)) - or else (Main_Kind = N_Generic_Package_Declaration - and then not Body_Required (Main_Unit_Node)) - or else Main_Kind = N_Package_Renaming_Declaration - or else Main_Kind = N_Subprogram_Renaming_Declaration - or else Nkind (Original_Node (Unit (Main_Unit_Node))) + if (Unit_Kind = N_Package_Declaration + and then not Body_Required (Unit_Node)) + or else (Unit_Kind = N_Generic_Package_Declaration + and then not Body_Required (Unit_Node)) + or else Unit_Kind = N_Package_Renaming_Declaration + or else Unit_Kind = N_Subprogram_Renaming_Declaration + or else Nkind (Original_Node (Unit (Unit_Node))) in N_Generic_Instantiation then Sname := Unit_Name (Main_Unit); @@ -793,16 +788,16 @@ procedure Gnat1drv is -- be incorrect (we may have misinterpreted a junk spec as not -- needing a body when it really does). - if Main_Kind = N_Package_Declaration + if Unit_Kind = N_Package_Declaration and then Ada_Version = Ada_83 and then Operating_Mode = Generate_Code and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body and then not Compilation_Errors then Error_Msg_N - ("package $$ does not require a body??", Main_Unit_Node); + ("package $$ does not require a body??", Unit_Node); Error_Msg_File_1 := Fname; - Error_Msg_N ("body in file{ will be ignored??", Main_Unit_Node); + Error_Msg_N ("body in file{ will be ignored??", Unit_Node); -- Ada 95 cases of a body file present when no body is -- permitted. This we consider to be an error. @@ -810,15 +805,15 @@ procedure Gnat1drv is else -- For generic instantiations, we never allow a body - if Nkind (Original_Node (Unit (Main_Unit_Node))) in + if Nkind (Original_Node (Unit (Unit_Node))) in N_Generic_Instantiation then Bad_Body_Error ("generic instantiation for $$ does not allow a body"); - -- A library unit that is a renaming never allows a body + -- A library unit that is a renaming never allows a body - elsif Main_Kind in N_Renaming_Declaration then + elsif Unit_Kind in N_Renaming_Declaration then Bad_Body_Error ("renaming declaration for $$ does not allow a body!"); @@ -829,11 +824,11 @@ procedure Gnat1drv is -- body when in fact it does. elsif not Compilation_Errors then - if Main_Kind = N_Package_Declaration then + if Unit_Kind = N_Package_Declaration then Bad_Body_Error ("package $$ does not allow a body!"); - elsif Main_Kind = N_Generic_Package_Declaration then + elsif Unit_Kind = N_Generic_Package_Declaration then Bad_Body_Error ("generic package $$ does not allow a body!"); end if; @@ -893,9 +888,18 @@ procedure Gnat1drv is if AAMP_On_Target then Sem_Ch13.Validate_Independence; end if; - end Post_Compilation_Validation_Checks; + -- Local variables + + Back_End_Mode : Back_End.Back_End_Mode_Type; + + Main_Unit_Kind : Node_Kind; + -- Kind of main compilation unit node + + Main_Unit_Node : Node_Id; + -- Compilation unit node for main unit + -- Start of processing for Gnat1drv begin @@ -1065,8 +1069,9 @@ begin end if; Main_Unit_Node := Cunit (Main_Unit); - Main_Kind := Nkind (Unit (Main_Unit_Node)); - Check_Bad_Body; + Main_Unit_Kind := Nkind (Unit (Main_Unit_Node)); + + Check_Bad_Body (Main_Unit_Node, Main_Unit_Kind); -- In CodePeer mode we always delete old SCIL files before regenerating -- new ones, in case of e.g. errors, and also to remove obsolete scilx @@ -1159,21 +1164,23 @@ begin -- subunits. Note that we always generate code for all generic units (a -- change from some previous versions of GNAT). - elsif Main_Kind = N_Subprogram_Body and then not Subunits_Missing then + elsif Main_Unit_Kind = N_Subprogram_Body + and then not Subunits_Missing + then Back_End_Mode := Generate_Object; -- We can generate code for a package body unless there are subunits -- missing (note that we always generate code for generic units, which -- is a change from some earlier versions of GNAT). - elsif Main_Kind = N_Package_Body and then not Subunits_Missing then + elsif Main_Unit_Kind = N_Package_Body and then not Subunits_Missing then Back_End_Mode := Generate_Object; -- We can generate code for a package declaration or a subprogram -- declaration only if it does not required a body. - elsif Nkind_In (Main_Kind, N_Package_Declaration, - N_Subprogram_Declaration) + elsif Nkind_In (Main_Unit_Kind, N_Package_Declaration, + N_Subprogram_Declaration) and then (not Body_Required (Main_Unit_Node) or else Distribution_Stub_Mode = Generate_Caller_Stub_Body) @@ -1183,8 +1190,8 @@ begin -- We can generate code for a generic package declaration of a generic -- subprogram declaration only if does not require a body. - elsif Nkind_In (Main_Kind, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + elsif Nkind_In (Main_Unit_Kind, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) and then not Body_Required (Main_Unit_Node) then Back_End_Mode := Generate_Object; @@ -1192,15 +1199,15 @@ begin -- Compilation units that are renamings do not require bodies, so we can -- generate code for them. - elsif Nkind_In (Main_Kind, N_Package_Renaming_Declaration, - N_Subprogram_Renaming_Declaration) + elsif Nkind_In (Main_Unit_Kind, N_Package_Renaming_Declaration, + N_Subprogram_Renaming_Declaration) then Back_End_Mode := Generate_Object; -- Compilation units that are generic renamings do not require bodies -- so we can generate code for them. - elsif Main_Kind in N_Generic_Renaming_Declaration then + elsif Main_Unit_Kind in N_Generic_Renaming_Declaration then Back_End_Mode := Generate_Object; -- It is not an error to analyze in CodePeer mode a spec which requires @@ -1240,45 +1247,61 @@ begin -- generate code). if Back_End_Mode = Skip then - Set_Standard_Error; - Write_Str ("cannot generate code for file "); - Write_Name (Unit_File_Name (Main_Unit)); - if Subunits_Missing then - Write_Str (" (missing subunits)"); - Write_Eol; + -- An ignored Ghost unit is rewritten into a null statement because + -- it must not produce an ALI or object file. Do not emit any errors + -- related to code generation because the unit does not exist. - -- Force generation of ALI file, for backward compatibility + if Main_Unit_Kind = N_Null_Statement + and then Is_Ignored_Ghost_Node + (Original_Node (Unit (Main_Unit_Node))) + then + null; - Opt.Force_ALI_Tree_File := True; + -- Otherwise the unit is missing a crucial piece that prevents code + -- generation. - elsif Main_Kind = N_Subunit then - Write_Str (" (subunit)"); - Write_Eol; + else + Set_Standard_Error; + Write_Str ("cannot generate code for file "); + Write_Name (Unit_File_Name (Main_Unit)); - -- Force generation of ALI file, for backward compatibility + if Subunits_Missing then + Write_Str (" (missing subunits)"); + Write_Eol; - Opt.Force_ALI_Tree_File := True; + -- Force generation of ALI file, for backward compatibility - elsif Main_Kind = N_Subprogram_Declaration then - Write_Str (" (subprogram spec)"); - Write_Eol; + Opt.Force_ALI_Tree_File := True; - -- Generic package body in GNAT implementation mode + elsif Main_Unit_Kind = N_Subunit then + Write_Str (" (subunit)"); + Write_Eol; - elsif Main_Kind = N_Package_Body and then GNAT_Mode then - Write_Str (" (predefined generic)"); - Write_Eol; + -- Force generation of ALI file, for backward compatibility - -- Force generation of ALI file, for backward compatibility + Opt.Force_ALI_Tree_File := True; - Opt.Force_ALI_Tree_File := True; + elsif Main_Unit_Kind = N_Subprogram_Declaration then + Write_Str (" (subprogram spec)"); + Write_Eol; - -- Only other case is a package spec + -- Generic package body in GNAT implementation mode - else - Write_Str (" (package spec)"); - Write_Eol; + elsif Main_Unit_Kind = N_Package_Body and then GNAT_Mode then + Write_Str (" (predefined generic)"); + Write_Eol; + + -- Force generation of ALI file, for backward compatibility + + Opt.Force_ALI_Tree_File := True; + + -- Only other case is a package spec + + else + Write_Str (" (package spec)"); + Write_Eol; + end if; end if; Set_Standard_Output; @@ -1320,7 +1343,7 @@ begin if Back_End_Mode = Declarations_Only and then (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode) - or else Main_Kind = N_Subunit + or else Main_Unit_Kind = N_Subunit or else Frontend_Layout_On_Target or else ASIS_GNSA_Mode) then @@ -1465,11 +1488,10 @@ begin when Program_Error => Comperr.Compiler_Abort ("Program_Error"); - when Storage_Error => - - -- Assume this is a bug. If it is real, the message will in any case - -- say Storage_Error, giving a strong hint. + -- Assume this is a bug. If it is real, the message will in any case + -- say Storage_Error, giving a strong hint. + when Storage_Error => Comperr.Compiler_Abort ("Storage_Error"); when Unrecoverable_Error => @@ -1482,7 +1504,7 @@ begin <> null; - -- The outer exception handles an unrecoverable error +-- The outer exception handler handles an unrecoverable error exception when Unrecoverable_Error => diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index c4edc7f1ebbf..0ba9f9ad245d 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -445,7 +445,14 @@ package body Lib is -- Prevent looping forever if Counter > Max_Iterations then - raise Program_Error; + -- ??? Not quite right, but return a value to be able to generate + -- SCIL files and hope for the best. + + if CodePeer_Mode then + return No; + else + raise Program_Error; + end if; end if; end loop; end Check_Same_Extended_Unit; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index d79a8453adaf..aecf7d4355d2 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -14879,8 +14879,8 @@ package body Sem_Ch12 is and then Is_Global (Entity (Orig_N2_Parent)) then N2 := Aux_N2; - Set_Associated_Node (Parent (N), - Original_Node (Parent (N2))); + Set_Associated_Node + (Parent (N), Original_Node (Parent (N2))); -- Common case diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index aad9f68fe96b..89a17c8755f0 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6618,7 +6618,13 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is + E : constant Entity_Id := Entity (N); + begin + if not Is_Frozen (E) and then Has_Delayed_Aspects (E) then + Analyze_Aspects_At_Freeze_Point (E); + end if; + Freeze_Entity_Checks (N); end Analyze_Freeze_Generic_Entity; @@ -10789,20 +10795,10 @@ package body Sem_Ch13 is -- the subtype name in the saved expression so that they will not cause -- trouble in the preanalysis. - -- Case 1: Generic case. For freezing nodes of types defined in generics - -- we must perform the analysis of its aspects; needed to ensure that - -- they have the minimum decoration needed by ASIS. - - if not Non_Generic_Case then - if Has_Delayed_Aspects (E) then - Push_Scope (Scope (E)); - Analyze_Aspects_At_Freeze_Point (E); - Pop_Scope; - end if; - - -- Case 2: Non-generic case + -- This is also not needed in the generic case - elsif Has_Delayed_Aspects (E) + if Non_Generic_Case + and then Has_Delayed_Aspects (E) and then Scope (E) = Current_Scope then -- Retrieve the visibility to the discriminants in order to properly diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5bbc1a34d17e..45ad8d63a116 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3495,11 +3495,11 @@ package body Sem_Ch4 is -- generic -- type Inner_T is private; -- with function Func (Formal : Inner_T) -- (1) - -- return ... is <>; + -- return ... is <>; -- package Inner_Gen is -- function Inner_Func (Formal : Inner_T) -- (2) - -- return ... is (Func (Formal)); + -- return ... is (Func (Formal)); -- end Inner_Gen; -- end Outer_Generic; @@ -3509,15 +3509,15 @@ package body Sem_Ch4 is -- In the example above, the type of parameter -- Inner_Func.Formal at (2) is incompatible with the type of -- Func.Formal at (1) in the context of instantiations - -- Outer_Inst and Inner_Inst. In reality both types are - -- generic actual subtypes renaming base type Actual_T as - -- part of the generic prologues for the instantiations. - - -- Recognize this case and add a type conversion to allow - -- this kind of generic actual subtype conformance. Note that - -- this is done only when the call is non-overloaded because - -- the resolution mechanism already has the means to - -- disambiguate similar cases. + -- Outer_Inst and Inner_Inst. In reality both types are generic + -- actual subtypes renaming base type Actual_T as part of the + -- generic prologues for the instantiations. + + -- Recognize this case and add a type conversion to allow this + -- kind of generic actual subtype conformance. Note that this + -- is done only when the call is non-overloaded because the + -- resolution mechanism already has the means to disambiguate + -- similar cases. elsif not Is_Overloaded (Name (N)) and then Is_Type (Etype (Actual)) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a91d62e5ce91..86083eb69550 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2143,17 +2143,18 @@ package body Sem_Ch6 is -- the subprogram, or to perform conformance checks. procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Body_Spec : Node_Id := Specification (N); - Body_Id : Entity_Id := Defining_Entity (Body_Spec); - Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); - Exch_Views : Elist_Id := No_Elist; - Desig_View : Entity_Id := Empty; - Conformant : Boolean; - HSS : Node_Id; - Prot_Typ : Entity_Id := Empty; - Spec_Id : Entity_Id; - Spec_Decl : Node_Id := Empty; + Body_Spec : Node_Id := Specification (N); + Body_Id : Entity_Id := Defining_Entity (Body_Spec); + Loc : constant Source_Ptr := Sloc (N); + Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); + + Conformant : Boolean; + Desig_View : Entity_Id := Empty; + Exch_Views : Elist_Id := No_Elist; + HSS : Node_Id; + Prot_Typ : Entity_Id := Empty; + Spec_Decl : Node_Id := Empty; + Spec_Id : Entity_Id; Last_Real_Spec_Entity : Entity_Id := Empty; -- When we analyze a separate spec, the entity chain ends up containing diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 6ce93639b89a..314c110fb8d8 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -445,11 +445,24 @@ package body Sem_Eval is -- that an infinity will result. if not Is_Static_Expression (N) then - if Is_Floating_Point_Type (T) - and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) - then - Error_Msg_N - ("??float value out of range, infinity will be generated", N); + if Is_Floating_Point_Type (T) then + if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then + Error_Msg_N + ("??float value out of range, infinity will be generated", N); + + -- The literal may be the result of constant-folding of a non- + -- static subexpression of a larger expression (e.g. a conversion + -- of a non-static variable whose value happens to be known). At + -- this point we must reduce the value of the subexpression to a + -- machine number (RM 4.9 (38/2)). + + elsif Nkind (N) = N_Real_Literal + and then Nkind (Parent (N)) in N_Subexpr + then + Rewrite (N, New_Copy (N)); + Set_Realval + (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); + end if; end if; return; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index e26443aa9809..c038dc4d799c 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -62,11 +62,14 @@ package body Sem_Intr is -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram -- declaration, and the node for the pragma argument, used for messages). - procedure Errint (Msg : String; S : Node_Id; N : Node_Id); + procedure Errint + (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False); -- Post error message for bad intrinsic, the message itself is posted -- on the appropriate spec node and another message is placed on the -- pragma itself, referring to the spec. S is the node in the spec on -- which the message is to be placed, and N is the pragma argument node. + -- Relaxed is True if the message should not be emitted in + -- Relaxed_RM_Semantics mode. ------------------------------ -- Check_Exception_Function -- @@ -432,7 +435,7 @@ package body Sem_Intr is then Errint ("first argument for shift must have size 8, 16, 32 or 64", - Ptyp1, N); + Ptyp1, N, Relaxed => True); return; elsif Non_Binary_Modulus (Typ1) then @@ -450,7 +453,7 @@ package body Sem_Intr is then Errint ("modular type for shift must have modulus of 2'*'*8, " - & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N); + & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N, Relaxed => True); elsif Etype (Arg1) /= Etype (E) then Errint @@ -465,12 +468,13 @@ package body Sem_Intr is -- Errint -- ------------ - procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is + procedure Errint + (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False) is begin -- Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can -- be more liberal. - if not Relaxed_RM_Semantics then + if not (Relaxed and Relaxed_RM_Semantics) then Error_Msg_N (Msg, S); Error_Msg_N ("incorrect intrinsic subprogram, see spec", N); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f603e317af47..3b9d9841f47a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9080,6 +9080,14 @@ package body Sem_Prag is Ghost_Id := Subp; end if; + -- Do not issue an error on an unanalyzed subprogram body entity. + -- It may lead to spurious errors on unanalyzed body entities of + -- expression functions, which are not yet marked as ghost, yet + -- identified as the Corresponding_Body of the ghost declaration. + + elsif Ekind (Subp) = E_Void then + null; + -- Otherwise the subprogram is non-Ghost. It is illegal to mix -- references to Ghost and non-Ghost entities (SPARK RM 6.9). diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index fd6421cad579..e8a22fa64e1a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11500,7 +11500,7 @@ package body Sem_Util is ------------------------------------------ procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is - Decl : Node_Id; + Decl : Node_Id; begin Decl := First (Decls); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index cb0a09293aa7..d9050959ff24 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -314,6 +314,11 @@ package body Sem_Warn is elsif Is_Suspicious_Function_Name (Entity (Name (N))) then return; + -- Forget it if function is marked Volatile_Function + + elsif Is_Volatile_Function (Entity (Name (N))) then + return; + -- Forget it if warnings are suppressed on function entity elsif Has_Warnings_Off (Entity (Name (N))) then -- 2.39.2