From 08f52d9f8462f6d35a82fe51818929fc563b4285 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 21 Apr 2016 10:48:04 +0200 Subject: [PATCH] [multiple changes] 2016-04-21 Philippe Gil * tracebak.c (__gnat_backtrace): handle bad RIP values (win64 only) 2016-04-21 Javier Miranda * exp_aggr.adb (Component_Not_OK_For_Backend): Return true for string literals. 2016-04-21 Hristian Kirtchev * einfo.adb (Has_Non_Null_Abstract_State): New routine. * einfo.ads New synthesized attribute Has_Non_Null_Abstract_State along with occurrences in entities. (Has_Non_Null_Abstract_State): New routine. * sem_ch7.adb (Unit_Requires_Body): Add local variable Requires_Body. A package declaring an abstract state requires a body only when the state is non-null and the package contains at least one other construct that requires completion in a body. * sem_util.adb (Mode_Is_Off): Removed. (Requires_State_Refinement): Remove an obsolete check. Code cleanup. 2016-04-21 Bob Duff * sem_attr.adb (Analyze_Attribute): In processing the 'Old attribute, a warning is given for infinite recursion. Fix the code to not crash when the prefix of 'Old denotes a protected function. * sem_ch5.adb (Analyze_Iterator_Specification): Avoid calling Is_Dependent_Component_Of_Mutable_Object in cases where the parameter would not be an object. 2016-04-21 Eric Botcazou * sem_eval.adb (Compile_Time_Compare): Be prepared for an empty Etype or Underlying_Type of the operands. 2016-04-21 Eric Botcazou * atree.adb (Print_Statistics): Protect against overflows and print the memory consumption in bytes. * table.adb (Reallocate): Do the intermediate calculation of the new size using the Memory.size_t type. From-SVN: r235312 --- gcc/ada/ChangeLog | 45 ++++++++++++++++++++++++++++++++++ gcc/ada/atree.adb | 30 ++++++++++++++++------- gcc/ada/einfo.adb | 14 +++++++++++ gcc/ada/einfo.ads | 8 ++++++- gcc/ada/exp_aggr.adb | 8 ++++++- gcc/ada/sem_attr.adb | 8 ++++++- gcc/ada/sem_ch5.adb | 40 +++++++++++++++++++------------ gcc/ada/sem_ch7.adb | 57 +++++++++++++++++++++++++------------------- gcc/ada/sem_eval.adb | 32 +++++++++++++++++-------- gcc/ada/sem_util.adb | 41 +++---------------------------- gcc/ada/table.adb | 8 ++++--- gcc/ada/tracebak.c | 8 ++++++- 12 files changed, 196 insertions(+), 103 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d0cc96ae9ca..02034158352 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2016-04-21 Philippe Gil + + * tracebak.c (__gnat_backtrace): handle bad RIP values (win64 only) + +2016-04-21 Javier Miranda + + * exp_aggr.adb (Component_Not_OK_For_Backend): Return true for string + literals. + +2016-04-21 Hristian Kirtchev + + * einfo.adb (Has_Non_Null_Abstract_State): New routine. + * einfo.ads New synthesized attribute + Has_Non_Null_Abstract_State along with occurrences in entities. + (Has_Non_Null_Abstract_State): New routine. + * sem_ch7.adb (Unit_Requires_Body): Add local variable + Requires_Body. A package declaring an abstract state requires + a body only when the state is non-null and the package contains + at least one other construct that requires completion in a body. + * sem_util.adb (Mode_Is_Off): Removed. + (Requires_State_Refinement): Remove an obsolete check. Code + cleanup. + +2016-04-21 Bob Duff + + * sem_attr.adb (Analyze_Attribute): In processing + the 'Old attribute, a warning is given for infinite recursion. Fix + the code to not crash when the prefix of 'Old denotes a protected + function. + * sem_ch5.adb (Analyze_Iterator_Specification): + Avoid calling Is_Dependent_Component_Of_Mutable_Object in cases + where the parameter would not be an object. + +2016-04-21 Eric Botcazou + + * sem_eval.adb (Compile_Time_Compare): Be prepared for an empty + Etype or Underlying_Type of the operands. + +2016-04-21 Eric Botcazou + + * atree.adb (Print_Statistics): Protect against overflows and + print the memory consumption in bytes. + * table.adb (Reallocate): Do the intermediate calculation of the new + size using the Memory.size_t type. + 2016-04-21 Gary Dismukes * exp_attr.adb (Is_Inline_Floating_Point_Attribute): Suppress diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 67b55a91c9e..a0849d253d0 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1970,13 +1970,6 @@ package body Atree is E_Count : Natural := 0; begin - Write_Str ("Maximum number of nodes per entity: "); - Write_Int (Int (Num_Extension_Nodes + 1)); - Write_Eol; - Write_Str ("Number of allocated nodes: "); - Write_Int (Int (N_Count)); - Write_Eol; - Write_Str ("Number of entities: "); Write_Eol; @@ -2051,10 +2044,29 @@ package body Atree is Write_Str ("Total number of entities: "); Write_Int (Int (E_Count)); Write_Eol; + + Write_Str ("Maximum number of nodes per entity: "); + Write_Int (Int (Num_Extension_Nodes + 1)); + Write_Eol; + + Write_Str ("Number of allocated nodes: "); + Write_Int (Int (N_Count)); + Write_Eol; + Write_Str ("Ratio allocated nodes/entities: "); - Write_Int (Int (N_Count * 100 / E_Count)); + Write_Int (Int (Long_Long_Integer (N_Count) * 100 / + Long_Long_Integer (E_Count))); Write_Str ("/100"); Write_Eol; + + Write_Str ("Size of a node in bytes: "); + Write_Int (Int (Node_Record'Size) / Storage_Unit); + Write_Eol; + + Write_Str ("Memory consumption in bytes: "); + Write_Int (Int (Long_Long_Integer (N_Count) * + (Node_Record'Size / Storage_Unit))); + Write_Eol; end Print_Statistics; ------------------- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9f1f3a9fe32..f52702f03fd 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7332,6 +7332,20 @@ package body Einfo is and then Present (Non_Limited_View (Id)); end Has_Non_Limited_View; + --------------------------------- + -- Has_Non_Null_Abstract_State -- + --------------------------------- + + function Has_Non_Null_Abstract_State (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package)); + + return + Present (Abstract_States (Id)) + and then + not Is_Null_State (Node (First_Elmt (Abstract_States (Id)))); + end Has_Non_Null_Abstract_State; + ------------------------------------- -- Has_Non_Null_Visible_Refinement -- ------------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 535fa39fc74..d403f77d830 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1761,6 +1761,10 @@ package Einfo is -- E_Abstract_State entities. True if their Non_Limited_View attribute -- is present. +-- Has_Non_Null_Abstract_State (synth) +-- Defined in package entities. True if the package is subject to a non- +-- null Abstract_State aspect/pragma. + -- Has_Non_Null_Visible_Refinement (synth) -- Defined in E_Abstract_State entities. True if the state has a visible -- refinement of at least one variable or state constituent as expressed @@ -6133,6 +6137,7 @@ package Einfo is -- SPARK_Aux_Pragma_Inherited (Flag266) -- SPARK_Pragma_Inherited (Flag265) -- Static_Elaboration_Desired (Flag77) (non-generic case only) + -- Has_Non_Null_Abstract_State (synth) -- Has_Null_Abstract_State (synth) -- Is_Wrapper_Package (synth) (non-generic case only) -- Scope_Depth (synth) @@ -7270,6 +7275,7 @@ package Einfo is function Has_Entries (Id : E) return B; function Has_Foreign_Convention (Id : E) return B; function Has_Non_Limited_View (Id : E) return B; + function Has_Non_Null_Abstract_State (Id : E) return B; function Has_Non_Null_Visible_Refinement (Id : E) return B; function Has_Null_Abstract_State (Id : E) return B; function Has_Null_Visible_Refinement (Id : E) return B; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c7a9a97e8e8..a99b6ce59ae 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -6014,6 +6014,12 @@ package body Exp_Aggr is elsif Possible_Bit_Aligned_Component (Expr_Q) then Static_Components := False; return True; + + elsif Modify_Tree_For_C + and then Ekind (Etype (Expr_Q)) = E_String_Literal_Subtype + then + Static_Components := False; + return True; end if; if Is_Elementary_Type (Etype (Expr_Q)) then diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index db02aa58cec..3a0fcbe60fe 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4940,7 +4940,13 @@ package body Sem_Attr is -- function Func (...) return ... -- with Post => Func'Old ...; - elsif Nkind (P) = N_Function_Call then + -- The function may be specified in qualified form X.Y where X is + -- a protected object and Y is a protected function. In that case + -- ensure that the qualified form has an entity. + + elsif Nkind (P) = N_Function_Call + and then Nkind (Name (P)) in N_Has_Entity + then Pref_Id := Entity (Name (P)); if Ekind_In (Spec_Id, E_Function, E_Generic_Function) diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 71ab4d0f26e..138da4dedda 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2139,11 +2139,15 @@ package body Sem_Ch5 is else declare - Element : constant Entity_Id := - Find_Value_Of_Aspect (Typ, Aspect_Iterator_Element); - Iterator : constant Entity_Id := - Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator); - Cursor_Type : Entity_Id; + Element : constant Entity_Id := + Find_Value_Of_Aspect + (Typ, Aspect_Iterator_Element); + Iterator : constant Entity_Id := + Find_Value_Of_Aspect + (Typ, Aspect_Default_Iterator); + Orig_Iter_Name : constant Node_Id := + Original_Node (Iter_Name); + Cursor_Type : Entity_Id; begin if No (Element) then @@ -2181,8 +2185,9 @@ package body Sem_Ch5 is if not Is_Variable (Iter_Name) and then not Has_Aspect (Typ, Aspect_Constant_Indexing) then - Error_Msg_N ("iteration over constant container " - & "require constant_indexing aspect", N); + Error_Msg_N + ("iteration over constant container require " + & "constant_indexing aspect", N); -- The Iterate function may have an in_out parameter, -- and a constant container is thus illegal. @@ -2193,15 +2198,20 @@ package body Sem_Ch5 is E_In_Parameter and then not Is_Variable (Iter_Name) then - Error_Msg_N - ("variable container expected", N); + Error_Msg_N ("variable container expected", N); end if; - if Nkind (Original_Node (Iter_Name)) - = N_Selected_Component - and then - Is_Dependent_Component_Of_Mutable_Object - (Original_Node (Iter_Name)) + -- It could be a function, which + -- Is_Dependent_Component_Of_Mutable_Object doesn't like, + -- so check that it's a component. + + if Nkind (Orig_Iter_Name) = N_Selected_Component + and then Ekind_In + (Entity (Selector_Name (Orig_Iter_Name)), + E_Component, + E_Discriminant) + and then Is_Dependent_Component_Of_Mutable_Object + (Orig_Iter_Name) then Error_Msg_N ("container cannot be a discriminant-dependent " diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e24de93e59f..04ad209b32c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2454,7 +2454,7 @@ package body Sem_Ch7 is elsif Ekind (Id) = E_Package and then Nkind (Original_Node (Unit_Declaration_Node (Id))) = - N_Formal_Package_Declaration + N_Formal_Package_Declaration then return False; @@ -2464,8 +2464,7 @@ package body Sem_Ch7 is -- implicit completion at some point. elsif (Is_Overloadable (Id) - and then Ekind (Id) /= E_Enumeration_Literal - and then Ekind (Id) /= E_Operator + and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator) and then not Is_Abstract_Subprogram (Id) and then not Has_Completion (Id) and then Comes_From_Source (Parent (Id))) @@ -2494,7 +2493,6 @@ package body Sem_Ch7 is or else (Is_Generic_Subprogram (Id) and then not Has_Completion (Id)) - then return True; @@ -2962,6 +2960,10 @@ package body Sem_Ch7 is is E : Entity_Id; + Requires_Body : Boolean := False; + -- Flag set when the unit has at least one construct that requries + -- completion in a body. + begin -- Imported entity never requires body. Right now, only subprograms can -- be imported, but perhaps in the future we will allow import of @@ -2996,35 +2998,42 @@ package body Sem_Ch7 is return True; end if; end; - - -- A [generic] package that introduces at least one non-null abstract - -- state requires completion. However, there is a separate rule that - -- requires that such a package have a reason other than this for a - -- body being required (if necessary a pragma Elaborate_Body must be - -- provided). If Ignore_Abstract_State is True, we don't do this check - -- (so we can use Unit_Requires_Body to check for some other reason). - - elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package) - and then not Ignore_Abstract_State - and then Present (Abstract_States (Pack_Id)) - and then not Is_Null_State - (Node (First_Elmt (Abstract_States (Pack_Id)))) - then - return True; end if; - -- Otherwise search entity chain for entity requiring completion + -- Traverse the entity chain of the package and look for constructs that + -- require a completion in a body. E := First_Entity (Pack_Id); while Present (E) loop - if Requires_Completion_In_Body (E, Pack_Id) then - return True; + + -- Skip abstract states because their completion depends on several + -- criteria (see below). + + if Ekind (E) = E_Abstract_State then + null; + + elsif Requires_Completion_In_Body (E, Pack_Id) then + Requires_Body := True; + exit; end if; Next_Entity (E); end loop; - return False; + -- A [generic] package that defines at least one non-null abstract state + -- requires a completion only when at least one other construct requires + -- a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not + -- performed if the caller requests this behavior. + + if not Ignore_Abstract_State + and then Ekind_In (Pack_Id, E_Generic_Package, E_Package) + and then Has_Non_Null_Abstract_State (Pack_Id) + and then Requires_Body + then + return True; + end if; + + return Requires_Body; end Unit_Requires_Body; ----------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 620c1663e03..5589394ede2 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -772,12 +772,8 @@ package body Sem_Eval is Assume_Valid : Boolean; Rec : Boolean := False) return Compare_Result is - Ltyp : Entity_Id := Underlying_Type (Etype (L)); - Rtyp : Entity_Id := Underlying_Type (Etype (R)); - -- These get reset to the base type for the case of entities where - -- Is_Known_Valid is not set. This takes care of handling possible - -- invalid representations using the value of the base type, in - -- accordance with RM 13.9.1(10). + Ltyp : Entity_Id := Etype (L); + Rtyp : Entity_Id := Etype (R); Discard : aliased Uint; @@ -1100,19 +1096,35 @@ package body Sem_Eval is if L = R then return EQ; + end if; -- If expressions have no types, then do not attempt to determine if -- they are the same, since something funny is going on. One case in -- which this happens is during generic template analysis, when bounds -- are not fully analyzed. - elsif No (Ltyp) or else No (Rtyp) then + if No (Ltyp) or else No (Rtyp) then + return Unknown; + end if; + + -- These get reset to the base type for the case of entities where + -- Is_Known_Valid is not set. This takes care of handling possible + -- invalid representations using the value of the base type, in + -- accordance with RM 13.9.1(10). + + Ltyp := Underlying_Type (Ltyp); + Rtyp := Underlying_Type (Rtyp); + + -- Same rationale as above, but for Underlying_Type instead of Etype + + if No (Ltyp) or else No (Rtyp) then return Unknown; + end if; - -- We do not attempt comparisons for packed arrays represented as + -- We do not attempt comparisons for packed arrays arrays represented as -- modular types, where the semantics of comparison is quite different. - elsif Is_Packed_Array_Impl_Type (Ltyp) + if Is_Packed_Array_Impl_Type (Ltyp) and then Is_Modular_Integer_Type (Ltyp) then return Unknown; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a10671144bf..a47002645bd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18267,35 +18267,7 @@ package body Sem_Util is (Spec_Id : Entity_Id; Body_Id : Entity_Id) return Boolean is - function Mode_Is_Off (Prag : Node_Id) return Boolean; - -- Given pragma SPARK_Mode, determine whether the mode is Off - - ----------------- - -- Mode_Is_Off -- - ----------------- - - function Mode_Is_Off (Prag : Node_Id) return Boolean is - Mode : Node_Id; - - begin - -- The default SPARK mode is On - - if No (Prag) then - return False; - end if; - - Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); - - -- Then the pragma lacks an argument, the default mode is On - - if No (Mode) then - return False; - else - return Chars (Mode) = Name_Off; - end if; - end Mode_Is_Off; - - -- Start of processing for Requires_State_Refinement + Prag : constant Node_Id := SPARK_Pragma (Body_Id); begin -- A package that does not define at least one abstract state cannot @@ -18314,15 +18286,8 @@ package body Sem_Util is -- it is and the mode is Off, the package body is considered to be in -- regular Ada and does not require refinement. - elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then - return False; - - -- The body's SPARK_Mode may be inherited from a similar pragma that - -- appears in the private declarations of the spec. The pragma we are - -- interested appears as the second entry in SPARK_Pragma. - - elsif Present (SPARK_Pragma (Spec_Id)) - and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id))) + elsif Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = Off then return False; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 4c745393b29..34fe7283787 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -207,9 +207,11 @@ package body Table is end if; end if; + -- Do the intermediate calculation in size_t to avoid signed overflow + New_Size := - Memory.size_t ((Max - Min + 1) * - (Table_Type'Component_Size / Storage_Unit)); + Memory.size_t (Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit); if Table = null then Table := To_Pointer (Alloc (New_Size)); diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index ff85ca5baf5..dceac0d443b 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2000-2015, Free Software Foundation, Inc. * + * Copyright (C) 2000-2016, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -99,6 +99,8 @@ extern void (*Unlock_Task) (void); #include +#define IS_BAD_PTR(ptr) (IsBadCodePtr((FARPROC)ptr)) + int __gnat_backtrace (void **array, int size, @@ -137,6 +139,10 @@ __gnat_backtrace (void **array, } else { + /* If the last unwinding step failed somehow, stop here. */ + if (IS_BAD_PTR(context.Rip)) + break; + /* Unwind. */ memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS)); RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction, -- 2.30.2