+2016-04-21 Philippe Gil <gil@adacore.com>
+
+ * tracebak.c (__gnat_backtrace): handle bad RIP values (win64 only)
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): Return true for string
+ literals.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * 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 <duff@adacore.com>
+
+ * 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 <ebotcazou@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Compare): Be prepared for an empty
+ Etype or Underlying_Type of the operands.
+
+2016-04-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * 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 <dismukes@adacore.com>
* exp_attr.adb (Is_Inline_Floating_Point_Attribute): Suppress
-- --
-- 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- --
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;
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;
-------------------
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 --
-------------------------------------
-- --
-- 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- --
-- 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
-- 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)
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;
-- --
-- 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- --
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
-- 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)
-- --
-- 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- --
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
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.
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 "
-- --
-- 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- --
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;
-- 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)))
or else
(Is_Generic_Subprogram (Id)
and then not Has_Completion (Id))
-
then
return True;
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
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;
-----------------------------
-- --
-- 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- --
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;
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;
(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
-- 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;
-- --
-- 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- --
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));
* *
* 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- *
#include <windows.h>
+#define IS_BAD_PTR(ptr) (IsBadCodePtr((FARPROC)ptr))
+
int
__gnat_backtrace (void **array,
int size,
}
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,
projects / gcc.git / commitdiff