Skip to content

R
riscv-gcc-1
Commit d5fa5335 by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch6.adb (Expand_N_Extended_Return_Statement): Use New_Copy_Tree instead of… 

exp_ch6.adb (Expand_N_Extended_Return_Statement): Use New_Copy_Tree instead of Relocate_Node as any subsequent copies of the...

2017-04-28  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Use
	New_Copy_Tree instead of Relocate_Node as any subsequent copies
	of the relocated node will have mangled Parent pointers.
	* sem_util.adb (Build_NCT_Hash_Tables): Reset both hash
	tables used in conjunction with entity and itype replication.
	(Visit_Entity): Rewrite the restriction on which entities
	require duplication.  The restriction now includes all types.

2017-04-28  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-cofuse.ads, a-cfdlli.ads, a-cfhase.adb, a-cfhase.ads, a-cfinve.adb,
	a-cfinve.ads, a-cforma.adb, a-cforma.ads, a-cofuma.adb, a-cofuma.ads,
	a-cfhama.adb, a-cfhama.ads, a-cforse.adb: Minor reformatting and code
	cleanups.

From-SVN: r247384
parent ef952fd5
Showing with 162 additions and 102 deletions
gcc/ada/ChangeLog
2017-04-28 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Use
New_Copy_Tree instead of Relocate_Node as any subsequent copies
of the relocated node will have mangled Parent pointers.
* sem_util.adb (Build_NCT_Hash_Tables): Reset both hash
tables used in conjunction with entity and itype replication.
(Visit_Entity): Rewrite the restriction on which entities
require duplication. The restriction now includes all types.
2017-04-28 Hristian Kirtchev <kirtchev@adacore.com>
* a-cofuse.ads, a-cfdlli.ads, a-cfhase.adb, a-cfhase.ads, a-cfinve.adb,
a-cfinve.ads, a-cforma.adb, a-cforma.ads, a-cofuma.adb, a-cofuma.ads,
a-cfhama.adb, a-cfhama.ads, a-cforse.adb: Minor reformatting and code
cleanups.
2017-04-28 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb, g-dyntab.adb, par-ch4.adb, sem_util.adb, sem_attr.adb,
gnat1drv.adb, exp_disp.adb, namet.adb, alloc.ads: Minor reformatting.
......
gcc/ada/a-cfdlli.ads
......@@ -1541,9 +1541,9 @@ is
Post =>
M_Elements_Sorted'Result =
(for all I in 1 .. M.Length (Container) =>
(for all J in I .. M.Length (Container) =>
Element (Container, I) = Element (Container, J)
or Element (Container, I) < Element (Container, J)));
(for all J in I .. M.Length (Container) =>
Element (Container, I) = Element (Container, J)
or Element (Container, I) < Element (Container, J)));
pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
end Formal_Model;
......
gcc/ada/a-cfhama.adb
......@@ -370,7 +370,9 @@ is
-- Find --
----------
function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
function Find
(Container : K.Sequence;
Key : Key_Type) return Count_Type
is
begin
for I in 1 .. K.Length (Container) loop
......@@ -385,8 +387,9 @@ is
-- K_Keys_Included --
---------------------
function K_Keys_Included (Left : K.Sequence;
Right : K.Sequence) return Boolean
function K_Keys_Included
(Left : K.Sequence;
Right : K.Sequence) return Boolean
is
begin
for I in 1 .. K.Length (Left) loop
......
gcc/ada/a-cfhama.ads
......@@ -126,8 +126,8 @@ is
Global => null,
Post =>
(if Find'Result > 0 then
Find'Result <= K.Length (Container)
and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
Find'Result <= K.Length (Container)
and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
function K_Keys_Included
(Left : K.Sequence;
......@@ -139,9 +139,9 @@ is
Post =>
K_Keys_Included'Result =
(for all I in 1 .. K.Length (Left) =>
Find (Right, K.Get (Left, I)) > 0
and then K.Get (Right, Find (Right, K.Get (Left, I))) =
K.Get (Left, I));
Find (Right, K.Get (Left, I)) > 0
and then K.Get (Right, Find (Right, K.Get (Left, I))) =
K.Get (Left, I));
package P is new Ada.Containers.Functional_Maps
(Key_Type => Cursor,
......@@ -203,14 +203,15 @@ is
-- It only contains keys contained in Model
and (for all Key of Keys'Result =>
M.Has_Key (Model (Container), Key))
M.Has_Key (Model (Container), Key))
-- It contains all the keys contained in Model
and (for all Key of Model (Container) =>
(Find (Keys'Result, Key) > 0
and then Equivalent_Keys
(K.Get (Keys'Result, Find (Keys'Result, Key)), Key)))
and then Equivalent_Keys
(K.Get (Keys'Result, Find (Keys'Result, Key)),
Key)))
-- It has no duplicate
......@@ -221,7 +222,8 @@ is
(for all J in 1 .. Length (Container) =>
(if Equivalent_Keys
(K.Get (Keys'Result, I), K.Get (Keys'Result, J))
then I = J)));
then
I = J)));
pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
function Positions (Container : Map) return P.Map with
......@@ -246,7 +248,7 @@ is
and then
(for all J of Positions'Result =>
(if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
then I = J)));
then I = J)));
procedure Lift_Abstraction_Level (Container : Map) with
-- Lift_Abstraction_Level is a ghost procedure that does nothing but
......@@ -547,9 +549,9 @@ is
-- Key is inserted in Container
and K.Get (Keys (Container),
P.Get (Positions (Container), Find (Container, Key))) =
Key
and K.Get
(Keys (Container),
P.Get (Positions (Container), Find (Container, Key))) = Key
-- Mapping from cursors to keys is preserved
......
gcc/ada/a-cfinve.adb
......@@ -705,12 +705,11 @@ is
function "<" (Left : Holder; Right : Holder) return Boolean is
(E (Left) < E (Right));
procedure Sort is
new Generic_Array_Sort
(Index_Type => Array_Index,
Element_Type => Holder,
Array_Type => Elements_Array,
"<" => "<");
procedure Sort is new Generic_Array_Sort
(Index_Type => Array_Index,
Element_Type => Holder,
Array_Type => Elements_Array,
"<" => "<");
Len : constant Capacity_Range := Length (Container);
......@@ -1065,8 +1064,9 @@ is
then
Reserve_Capacity
(Container,
Capacity_Range'Max (Current_Capacity (Container) * Growth_Factor,
Capacity_Range (New_Length)));
Capacity_Range'Max
(Current_Capacity (Container) * Growth_Factor,
Capacity_Range (New_Length)));
end if;
declare
......@@ -1348,10 +1348,10 @@ is
-- hence we also know that
-- Index - Index_Type'First >= 0
-- The issue is that even though 0 is guaranteed to be a value in
-- the type Index_Type'Base, there's no guarantee that the difference
-- is a value in that type. To prevent overflow we use the wider
-- of Count_Type'Base and Index_Type'Base to perform intermediate
-- The issue is that even though 0 is guaranteed to be a value in the
-- type Index_Type'Base, there's no guarantee that the difference is a
-- value in that type. To prevent overflow we use the wider of
-- Count_Type'Base and Index_Type'Base to perform intermediate
-- calculations.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
......@@ -1362,8 +1362,8 @@ is
Count_Type'Base (Index_Type'First);
end if;
-- The array index subtype for all container element arrays
-- always starts with 1.
-- The array index subtype for all container element arrays always
-- starts with 1.
return 1 + Offset;
end To_Array_Index;
......
gcc/ada/a-cfinve.ads
......@@ -830,9 +830,9 @@ is
Post =>
M_Elements_Sorted'Result =
(for all I in Index_Type'First .. M.Last (Container) =>
(for all J in I .. M.Last (Container) =>
Element (Container, I) = Element (Container, J)
or Element (Container, I) < Element (Container, J)));
(for all J in I .. M.Last (Container) =>
Element (Container, I) = Element (Container, J)
or Element (Container, I) < Element (Container, J)));
pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
end Formal_Model;
......
gcc/ada/a-cforma.adb
......@@ -518,7 +518,9 @@ is
-- Find --
----------
function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
function Find
(Container : K.Sequence;
Key : Key_Type) return Count_Type
is
begin
for I in 1 .. K.Length (Container) loop
......@@ -634,9 +636,12 @@ is
-- for their postconditions.
while Position /= 0 loop
R := M.Add (Container => R,
New_Key => Container.Nodes (Position).Key,
New_Item => Container.Nodes (Position).Element);
R :=
M.Add
(Container => R,
New_Key => Container.Nodes (Position).Key,
New_Item => Container.Nodes (Position).Element);
Position := Tree_Operations.Next (Container, Position);
end loop;
......
gcc/ada/a-cforma.ads
......@@ -159,16 +159,16 @@ is
Pre => Position - 1 <= K.Length (Container),
Post =>
K_Is_Find'Result =
((if Position > 0 then
K_Bigger_Than_Range (Container, 1, Position - 1, Key))
((if Position > 0 then
K_Bigger_Than_Range (Container, 1, Position - 1, Key))
and (if Position < K.Length (Container) then
K_Smaller_Than_Range
(Container,
Position + 1,
K.Length (Container),
Key)));
and
(if Position < K.Length (Container) then
K_Smaller_Than_Range
(Container,
Position + 1,
K.Length (Container),
Key)));
pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find);
function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
......@@ -178,8 +178,8 @@ is
Global => null,
Post =>
(if Find'Result > 0 then
Find'Result <= K.Length (Container)
and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
Find'Result <= K.Length (Container)
and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
package P is new Ada.Containers.Functional_Maps
(Key_Type => Cursor,
......@@ -246,20 +246,21 @@ is
-- It only contains keys contained in Model
and (for all Key of Keys'Result =>
M.Has_Key (Model (Container), Key))
M.Has_Key (Model (Container), Key))
-- It contains all the keys contained in Model
and (for all Key of Model (Container) =>
(Find (Keys'Result, Key) > 0
and then Equivalent_Keys
(K.Get (Keys'Result, Find (Keys'Result, Key)), Key)))
and then Equivalent_Keys
(K.Get (Keys'Result, Find (Keys'Result, Key)),
Key)))
-- It is sorted in increasing order
and (for all I in 1 .. Length (Container) =>
Find (Keys'Result, K.Get (Keys'Result, I)) = I
and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I));
and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I));
pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
function Positions (Container : Map) return P.Map with
......@@ -284,7 +285,7 @@ is
and then
(for all J of Positions'Result =>
(if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
then I = J)));
then I = J)));
procedure Lift_Abstraction_Level (Container : Map) with
-- Lift_Abstraction_Level is a ghost procedure that does nothing but
......@@ -942,7 +943,7 @@ is
Contract_Cases =>
(Position = No_Element
or else P.Get (Positions (Container), Position) = 1
=>
=>
Position = No_Element,
others =>
......@@ -983,6 +984,7 @@ is
Contract_Cases =>
(Length (Container) = 0 or else Key < First_Key (Container) =>
Floor'Result = No_Element,
others =>
Has_Element (Container, Floor'Result)
and not (Key < K.Get (Keys (Container),
......@@ -999,9 +1001,9 @@ is
Ceiling'Result = No_Element,
others =>
Has_Element (Container, Ceiling'Result)
and
not (K.Get (Keys (Container),
P.Get (Positions (Container), Ceiling'Result)) < Key)
and not (K.Get
(Keys (Container),
P.Get (Positions (Container), Ceiling'Result)) < Key)
and K_Is_Find
(Keys (Container),
Key,
......
gcc/ada/a-cforse.adb
......@@ -608,6 +608,7 @@ is
return False;
end if;
end loop;
return True;
end E_Bigger_Than_Range;
......@@ -700,6 +701,7 @@ is
end if;
end loop;
end if;
return True;
end E_Is_Find;
......@@ -719,6 +721,7 @@ is
return False;
end if;
end loop;
return True;
end E_Smaller_Than_Range;
......@@ -736,6 +739,7 @@ is
return I;
end if;
end loop;
return 0;
end Find;
......
gcc/ada/a-cofuma.adb
......@@ -152,8 +152,11 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
-- Has_Witness --
-----------------
function Has_Witness (Container : Map; Witness : Count_Type) return Boolean
is (Witness in 1 .. Length (Container.Keys));
function Has_Witness
(Container : Map;
Witness : Count_Type) return Boolean
is
(Witness in 1 .. Length (Container.Keys));
--------------
-- Is_Empty --
......@@ -265,7 +268,9 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
-- W_Get --
-----------
function W_Get (Container : Map; Witness : Count_Type) return Element_Type
function W_Get
(Container : Map;
Witness : Count_Type) return Element_Type
is
(Get (Container.Elements, Witness));
......
gcc/ada/a-cofuma.ads
......@@ -35,9 +35,11 @@ private with Ada.Containers.Functional_Base;
generic
type Key_Type (<>) is private;
type Element_Type (<>) is private;
with function Equivalent_Keys
(Left : Key_Type;
Right : Key_Type) return Boolean is "=";
Enable_Handling_Of_Equivalence : Boolean := True;
-- This constant should only be set to False when no particular handling
-- of equivalence over keys is needed, that is, Equivalent_Keys defines a
......@@ -77,7 +79,7 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is
-- Has_Key returns the same result on all equivalent keys
(if (for some K of Container => Equivalent_Keys (K, Key)) then
Has_Key'Result));
Has_Key'Result));
function Get (Container : Map; Key : Key_Type) return Element_Type with
-- Return the element associated with Key in Container
......@@ -90,8 +92,8 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is
-- Get returns the same result on all equivalent keys
Get'Result = W_Get (Container, Witness (Container, Key))
and (for all K of Container =>
(Equivalent_Keys (K, Key) =
and (for all K of Container =>
(Equivalent_Keys (K, Key) =
(Witness (Container, Key) = Witness (Container, K)))));
function Length (Container : Map) return Count_Type with
......
gcc/ada/a-cofuse.ads
......@@ -34,9 +34,11 @@ private with Ada.Containers.Functional_Base;
generic
type Element_Type (<>) is private;
with function Equivalent_Elements
(Left : Element_Type;
Right : Element_Type) return Boolean is "=";
Enable_Handling_Of_Equivalence : Boolean := True;
-- This constant should only be set to False when no particular handling
-- of equivalence over elements is needed, that is, Equivalent_Elements
......@@ -75,7 +77,7 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is
-- Contains returns the same result on all equivalent elements
(if (for some E of Container => Equivalent_Elements (E, Item)) then
Contains'Result));
Contains'Result));
function Length (Container : Set) return Count_Type with
Global => null;
......@@ -89,8 +91,7 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is
-- Set inclusion
Global => null,
Post => "<="'Result = (for all Item of Left => Contains (Right, Item))
and (if "<="'Result then Length (Left) <= Length (Right));
Post => "<="'Result = (for all Item of Left => Contains (Right, Item));
function "=" (Left : Set; Right : Set) return Boolean with
-- Extensional equality over sets
......@@ -187,7 +188,12 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is
Global => null,
Post =>
Num_Overlaps'Result = Length (Intersection (Left, Right));
Num_Overlaps'Result = Length (Intersection (Left, Right))
and (if Left <= Right then Num_Overlaps'Result = Length (Left)
else Num_Overlaps'Result < Length (Left))
and (if Right <= Left then Num_Overlaps'Result = Length (Right)
else Num_Overlaps'Result < Length (Right))
and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right);
----------------------------
-- Construction Functions --
......
gcc/ada/exp_ch6.adb
......@@ -4798,7 +4798,7 @@ package body Exp_Ch6 is
Init_Assignment :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
Expression => Relocate_Node (Ret_Obj_Expr));
Expression => New_Copy_Tree (Ret_Obj_Expr));
Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
Set_Assignment_OK (Name (Init_Assignment));
......
gcc/ada/sem_util.adb
......@@ -17003,7 +17003,7 @@ package body Sem_Util is
package NCT_Itype_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
Element => Node_Or_Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
......@@ -17114,37 +17114,45 @@ package body Sem_Util is
---------------------------
procedure Build_NCT_Hash_Tables is
Elmt : Elmt_Id;
Ent : Entity_Id;
Assoc : Entity_Id;
Elmt : Elmt_Id;
Key : Entity_Id;
Value : Entity_Id;
begin
if No (Map) then
return;
end if;
-- Clear both hash tables associated with entry replication since
-- multiple calls to New_Copy_Tree could cause multiple collisions
-- and produce long linked lists in individual buckets.
NCT_Assoc.Reset;
NCT_Itype_Assoc.Reset;
Elmt := First_Elmt (Map);
while Present (Elmt) loop
Ent := Node (Elmt);
-- Get new entity, and associate old and new
-- Extract a (key, value) pair from the map
Key := Node (Elmt);
Next_Elmt (Elmt);
NCT_Assoc.Set (Ent, Node (Elmt));
Value := Node (Elmt);
if Is_Type (Ent) then
declare
Anode : constant Entity_Id :=
Associated_Node_For_Itype (Ent);
-- Add the pair in the association hash table
begin
-- Enter the link between the associated node of the old
-- Itype and the new Itype, for updating later when node
-- is copied.
NCT_Assoc.Set (Key, Value);
if Present (Anode) then
NCT_Itype_Assoc.Set (Anode, Node (Elmt));
end if;
end;
-- Add a link between the associated node of the old Itype and the
-- new Itype, for updating later when node is copied.
if Is_Type (Key) then
Assoc := Associated_Node_For_Itype (Key);
if Present (Assoc) then
NCT_Itype_Assoc.Set (Assoc, Value);
end if;
end if;
Next_Elmt (Elmt);
......@@ -17540,23 +17548,29 @@ package body Sem_Util is
pragma Assert (not Is_Itype (Old_Entity));
pragma Assert (Nkind (Old_Entity) in N_Entity);
-- Restrict entity creation to declarations of constants, variables
-- and subtypes. There is no need to duplicate entities declared in
-- inner scopes.
-- Do not duplicate an entity when it is declared within an inner
-- scope enclosed by an expression with actions.
if (not Ekind_In (Old_Entity, E_Constant, E_Variable)
and then Nkind (Parent (Old_Entity)) /= N_Subtype_Declaration)
or else EWA_Inner_Scope_Level > 0
then
if EWA_Inner_Scope_Level > 0 then
return;
-- Entity duplication is currently performed only for objects and
-- types. Relaxing this restriction leads to a performance penalty.
elsif Ekind_In (Old_Entity, E_Constant, E_Variable) then
null;
elsif Is_Type (Old_Entity) then
null;
else
return;
end if;
New_E := New_Copy (Old_Entity);
-- The new entity has all the attributes of the old one, and we
-- just copy the contents of the entity. However, the back-end
-- needs different names for debugging purposes, so we create a
-- new internal name for it in all cases.
-- The new entity has all the attributes of the old one, however it
-- requires a new name for debugging purposes.
Set_Chars (New_E, New_Internal_Name ('T'));
......@@ -17830,8 +17844,8 @@ package body Sem_Util is
while Present (New_E) loop
-- Skip entities that were not created in the first phase
-- (that is, old entities specified by the caller in the
-- set of mappings to be applied to the tree).
-- (that is, old entities specified by the caller in the set of
-- mappings to be applied to the tree).
if Is_Itype (New_E)
or else No (Map)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment