Skip to content

R
riscv-gcc-1
Commit e7f11067 by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Johannes Kanig  <kanig@adacore.com>

	* debug.adb: Document usage of -gnatd.Q switch.

2013-04-11  Matthew Heaney  <heaney@adacore.com>

	* a-crbtgk.adb (Ceiling, Find, Floor): Adjust locks
	before element comparisons.
	(Generic_Conditional_Insert, Generic_Conditional_Insert_With_Hint):
	Ditto.
	* a-crbtgo.adb, a-rbtgbo.adb (Generic_Equal): Adjust locks before
	element comparisons.
	* a-rbtgso.adb (Difference, Intersection): Adjust locks
	before element comparisons.
	(Is_Subset, Overlap): Ditto
	(Symmetric_Difference, Union): Ditto
	* a-btgbso.adb (Set_Difference, Set_Intersection): Adjust locks
	before element comparisons.
	(Set_Subset, Set_Overlap): Ditto
	(Set_Symmetric_Difference, Set_Union): Ditto
	* a-coorse.adb, a-ciorse.adb, a-cborse.adb
	(Update_Element_Preserving_Key): Adjust locks before element
	comparisons (Replace_Element): Ditto

2013-04-11  Pascal Obry  <obry@adacore.com>

	* prj-attr.adb, projects.texi, snames.ads-tmpl: Remove Build_Slaves
	attribute.

2013-04-11  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Build_Equivalent_Aggregate): Subsidiary of
	Expand_N_Object_Declaration, used to construct an aggregate
	with static components whenever possible, so that objects of a
	discriminated type can be initialized without calling the init.
	proc for the type.

2013-04-11  Vincent Celier  <celier@adacore.com>

	* prj-makr.adb (Process_Directory): On VMS, always delete,
	then recreate the temporary file with Create_Output_Text_File,
	otherwise the output redirection does not work properly.

2013-04-11  Eric Botcazou  <ebotcazou@adacore.com>

	* urealp.ads: Fix minor typo.

2013-04-11  Fabien Chouteau  <chouteau@adacore.com>

	* cio.c (mktemp): Don't use tmpnam function from the
	system on VxWorks in kernel mode.

From-SVN: r197784
parent e03c5253
Showing with 1911 additions and 495 deletions
gcc/ada/ChangeLog
2013-04-11 Johannes Kanig <kanig@adacore.com>
* debug.adb: Document usage of -gnatd.Q switch.
2013-04-11 Matthew Heaney <heaney@adacore.com>
* a-crbtgk.adb (Ceiling, Find, Floor): Adjust locks
before element comparisons.
(Generic_Conditional_Insert, Generic_Conditional_Insert_With_Hint):
Ditto.
* a-crbtgo.adb, a-rbtgbo.adb (Generic_Equal): Adjust locks before
element comparisons.
* a-rbtgso.adb (Difference, Intersection): Adjust locks
before element comparisons.
(Is_Subset, Overlap): Ditto
(Symmetric_Difference, Union): Ditto
* a-btgbso.adb (Set_Difference, Set_Intersection): Adjust locks
before element comparisons.
(Set_Subset, Set_Overlap): Ditto
(Set_Symmetric_Difference, Set_Union): Ditto
* a-coorse.adb, a-ciorse.adb, a-cborse.adb
(Update_Element_Preserving_Key): Adjust locks before element
comparisons (Replace_Element): Ditto
2013-04-11 Pascal Obry <obry@adacore.com>
* prj-attr.adb, projects.texi, snames.ads-tmpl: Remove Build_Slaves
attribute.
2013-04-11 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Build_Equivalent_Aggregate): Subsidiary of
Expand_N_Object_Declaration, used to construct an aggregate
with static components whenever possible, so that objects of a
discriminated type can be initialized without calling the init.
proc for the type.
2013-04-11 Vincent Celier <celier@adacore.com>
* prj-makr.adb (Process_Directory): On VMS, always delete,
then recreate the temporary file with Create_Output_Text_File,
otherwise the output redirection does not work properly.
2013-04-11 Eric Botcazou <ebotcazou@adacore.com>
* urealp.ads: Fix minor typo.
2013-04-11 Fabien Chouteau <chouteau@adacore.com>
* cio.c (mktemp): Don't use tmpnam function from the
system on VxWorks in kernel mode.
2013-04-11 Vincent Celier <celier@adacore.com> 2013-04-11 Vincent Celier <celier@adacore.com>
* make.adb (Compile): Clarify the error message reported * make.adb (Compile): Clarify the error message reported
......
gcc/ada/a-btgbso.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -53,11 +53,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -53,11 +53,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
---------------- ----------------
procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is
BT : Natural renames Target.Busy;
LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt, Src : Count_Type; Tgt, Src : Count_Type;
TN : Nodes_Type renames Target.Nodes; TN : Nodes_Type renames Target.Nodes;
SN : Nodes_Type renames Source.Nodes; SN : Nodes_Type renames Source.Nodes;
Compare : Integer;
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
if Target.Busy > 0 then if Target.Busy > 0 then
...@@ -82,17 +90,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -82,17 +90,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
Src := Source.First; Src := Source.First;
loop loop
if Tgt = 0 then if Tgt = 0 then
return; exit;
end if; end if;
if Src = 0 then if Src = 0 then
return; exit;
end if; end if;
if Is_Less (TN (Tgt), SN (Src)) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (TN (Tgt), SN (Src)) then
Compare := -1;
elsif Is_Less (SN (Src), TN (Tgt)) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
Tgt := Tree_Operations.Next (Target, Tgt); Tgt := Tree_Operations.Next (Target, Tgt);
elsif Is_Less (SN (Src), TN (Tgt)) then elsif Compare > 0 then
Src := Tree_Operations.Next (Source, Src); Src := Tree_Operations.Next (Source, Src);
else else
...@@ -111,12 +153,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -111,12 +153,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
end Set_Difference; end Set_Difference;
function Set_Difference (Left, Right : Set_Type) return Set_Type is function Set_Difference (Left, Right : Set_Type) return Set_Type is
L_Node : Count_Type;
R_Node : Count_Type;
Dst_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return S : Set_Type (0); -- Empty set return S : Set_Type (0); -- Empty set
...@@ -131,15 +167,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -131,15 +167,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
end if; end if;
return Result : Set_Type (Left.Length) do return Result : Set_Type (Left.Length) do
L_Node := Left.First; -- Per AI05-0022, the container implementation is required to detect
R_Node := Right.First; -- element tampering by a generic actual subprogram.
loop
if L_Node = 0 then
return;
end if;
if R_Node = 0 then declare
while L_Node /= 0 loop BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
L_Node : Count_Type;
R_Node : Count_Type;
Dst_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0 then
exit;
end if;
if R_Node = 0 then
while L_Node /= 0 loop
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node);
end loop;
exit;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
Insert_With_Hint Insert_With_Hint
(Dst_Set => Result, (Dst_Set => Result,
Dst_Hint => 0, Dst_Hint => 0,
...@@ -147,28 +219,31 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -147,28 +219,31 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
Dst_Node => Dst_Node); Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node); L_Node := Tree_Operations.Next (Left, L_Node);
end loop;
return; elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
end if; R_Node := Tree_Operations.Next (Right, R_Node);
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then else
Insert_With_Hint L_Node := Tree_Operations.Next (Left, L_Node);
(Dst_Set => Result, R_Node := Tree_Operations.Next (Right, R_Node);
Dst_Hint => 0, end if;
Src_Node => Left.Nodes (L_Node), end loop;
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node); BL := BL - 1;
LL := LL - 1;
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then BR := BR - 1;
R_Node := Tree_Operations.Next (Right, R_Node); LR := LR - 1;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
else BR := BR - 1;
L_Node := Tree_Operations.Next (Left, L_Node); LR := LR - 1;
R_Node := Tree_Operations.Next (Right, R_Node);
end if; raise;
end loop; end;
end return; end return;
end Set_Difference; end Set_Difference;
...@@ -180,9 +255,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -180,9 +255,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
(Target : in out Set_Type; (Target : in out Set_Type;
Source : Set_Type) Source : Set_Type)
is is
BT : Natural renames Target.Busy;
LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt : Count_Type; Tgt : Count_Type;
Src : Count_Type; Src : Count_Type;
Compare : Integer;
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
...@@ -203,7 +286,41 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -203,7 +286,41 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
while Tgt /= 0 while Tgt /= 0
and then Src /= 0 and then Src /= 0
loop loop
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
Compare := -1;
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
declare declare
X : constant Count_Type := Tgt; X : constant Count_Type := Tgt;
begin begin
...@@ -213,7 +330,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -213,7 +330,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
Tree_Operations.Free (Target, X); Tree_Operations.Free (Target, X);
end; end;
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then elsif Compare > 0 then
Src := Tree_Operations.Next (Source, Src); Src := Tree_Operations.Next (Source, Src);
else else
...@@ -235,46 +352,80 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -235,46 +352,80 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
end Set_Intersection; end Set_Intersection;
function Set_Intersection (Left, Right : Set_Type) return Set_Type is function Set_Intersection (Left, Right : Set_Type) return Set_Type is
L_Node : Count_Type;
R_Node : Count_Type;
Dst_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Copy (Left); return Copy (Left);
end if; end if;
return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0 then
return;
end if;
if R_Node = 0 then -- Per AI05-0022, the container implementation is required to detect
return; -- element tampering by a generic actual subprogram.
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then declare
L_Node := Tree_Operations.Next (Left, L_Node); BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then BR : Natural renames Right'Unrestricted_Access.Busy;
R_Node := Tree_Operations.Next (Right, R_Node); LR : Natural renames Right'Unrestricted_Access.Lock;
else L_Node : Count_Type;
Insert_With_Hint R_Node : Count_Type;
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node); Dst_Node : Count_Type;
R_Node := Tree_Operations.Next (Right, R_Node); pragma Warnings (Off, Dst_Node);
end if;
end loop; begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0 then
exit;
end if;
if R_Node = 0 then
exit;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
L_Node := Tree_Operations.Next (Left, L_Node);
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
R_Node := Tree_Operations.Next (Right, R_Node);
else
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node);
R_Node := Tree_Operations.Next (Right, R_Node);
end if;
end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end;
end return; end return;
end Set_Intersection; end Set_Intersection;
...@@ -286,9 +437,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -286,9 +437,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
(Subset : Set_Type; (Subset : Set_Type;
Of_Set : Set_Type) return Boolean Of_Set : Set_Type) return Boolean
is is
Subset_Node : Count_Type;
Set_Node : Count_Type;
begin begin
if Subset'Address = Of_Set'Address then if Subset'Address = Of_Set'Address then
return True; return True;
...@@ -298,28 +446,75 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -298,28 +446,75 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
return False; return False;
end if; end if;
Subset_Node := Subset.First; -- Per AI05-0022, the container implementation is required to detect
Set_Node := Of_Set.First; -- element tampering by a generic actual subprogram.
loop
if Set_Node = 0 then
return Subset_Node = 0;
end if;
if Subset_Node = 0 then declare
return True; BL : Natural renames Subset'Unrestricted_Access.Busy;
end if; LL : Natural renames Subset'Unrestricted_Access.Lock;
if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then BR : Natural renames Of_Set'Unrestricted_Access.Busy;
return False; LR : Natural renames Of_Set'Unrestricted_Access.Lock;
end if;
if Is_Less (Of_Set.Nodes (Set_Node), Subset.Nodes (Subset_Node)) then Subset_Node : Count_Type;
Set_Node := Tree_Operations.Next (Of_Set, Set_Node); Set_Node : Count_Type;
else
Set_Node := Tree_Operations.Next (Of_Set, Set_Node); Result : Boolean;
Subset_Node := Tree_Operations.Next (Subset, Subset_Node);
end if; begin
end loop; BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Subset_Node := Subset.First;
Set_Node := Of_Set.First;
loop
if Set_Node = 0 then
Result := Subset_Node = 0;
exit;
end if;
if Subset_Node = 0 then
Result := True;
exit;
end if;
if Is_Less (Subset.Nodes (Subset_Node),
Of_Set.Nodes (Set_Node))
then
Result := False;
exit;
end if;
if Is_Less (Of_Set.Nodes (Set_Node),
Subset.Nodes (Subset_Node))
then
Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
else
Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
Subset_Node := Tree_Operations.Next (Subset, Subset_Node);
end if;
end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end;
end Set_Subset; end Set_Subset;
------------- -------------
...@@ -327,33 +522,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -327,33 +522,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
------------- -------------
function Set_Overlap (Left, Right : Set_Type) return Boolean is function Set_Overlap (Left, Right : Set_Type) return Boolean is
L_Node : Count_Type;
R_Node : Count_Type;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Left.Length /= 0; return Left.Length /= 0;
end if; end if;
L_Node := Left.First; -- Per AI05-0022, the container implementation is required to detect
R_Node := Right.First; -- element tampering by a generic actual subprogram.
loop
if L_Node = 0
or else R_Node = 0
then
return False;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then declare
L_Node := Tree_Operations.Next (Left, L_Node); BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then BR : Natural renames Right'Unrestricted_Access.Busy;
R_Node := Tree_Operations.Next (Right, R_Node); LR : Natural renames Right'Unrestricted_Access.Lock;
else L_Node : Count_Type;
return True; R_Node : Count_Type;
end if;
end loop; Result : Boolean;
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0
or else R_Node = 0
then
Result := False;
exit;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
L_Node := Tree_Operations.Next (Left, L_Node);
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
R_Node := Tree_Operations.Next (Right, R_Node);
else
Result := True;
exit;
end if;
end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end;
end Set_Overlap; end Set_Overlap;
-------------------------- --------------------------
...@@ -364,18 +598,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -364,18 +598,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
(Target : in out Set_Type; (Target : in out Set_Type;
Source : Set_Type) Source : Set_Type)
is is
BT : Natural renames Target.Busy;
LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt : Count_Type; Tgt : Count_Type;
Src : Count_Type; Src : Count_Type;
New_Tgt_Node : Count_Type; New_Tgt_Node : Count_Type;
pragma Warnings (Off, New_Tgt_Node); pragma Warnings (Off, New_Tgt_Node);
begin Compare : Integer;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
Tree_Operations.Clear_Tree (Target); Tree_Operations.Clear_Tree (Target);
return; return;
...@@ -402,10 +639,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -402,10 +639,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
return; return;
end if; end if;
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
Compare := -1;
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
Tgt := Tree_Operations.Next (Target, Tgt); Tgt := Tree_Operations.Next (Target, Tgt);
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then elsif Compare > 0 then
Insert_With_Hint Insert_With_Hint
(Dst_Set => Target, (Dst_Set => Target,
Dst_Hint => Tgt, Dst_Hint => Tgt,
...@@ -432,12 +703,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -432,12 +703,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
function Set_Symmetric_Difference function Set_Symmetric_Difference
(Left, Right : Set_Type) return Set_Type (Left, Right : Set_Type) return Set_Type
is is
L_Node : Count_Type;
R_Node : Count_Type;
Dst_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return S : Set_Type (0); -- Empty set return S : Set_Type (0); -- Empty set
...@@ -452,25 +717,62 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -452,25 +717,62 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
end if; end if;
return Result : Set_Type (Left.Length + Right.Length) do return Result : Set_Type (Left.Length + Right.Length) do
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0 then
while R_Node /= 0 loop
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Right.Nodes (R_Node),
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (Right, R_Node); -- Per AI05-0022, the container implementation is required to detect
end loop; -- element tampering by a generic actual subprogram.
return; declare
end if; BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
if R_Node = 0 then BR : Natural renames Right'Unrestricted_Access.Busy;
while L_Node /= 0 loop LR : Natural renames Right'Unrestricted_Access.Lock;
L_Node : Count_Type;
R_Node : Count_Type;
Dst_Node : Count_Type;
pragma Warnings (Off, Dst_Node);
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = 0 then
while R_Node /= 0 loop
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Right.Nodes (R_Node),
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (Right, R_Node);
end loop;
exit;
end if;
if R_Node = 0 then
while L_Node /= 0 loop
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node);
end loop;
exit;
end if;
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
Insert_With_Hint Insert_With_Hint
(Dst_Set => Result, (Dst_Set => Result,
Dst_Hint => 0, Dst_Hint => 0,
...@@ -478,34 +780,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -478,34 +780,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
Dst_Node => Dst_Node); Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node); L_Node := Tree_Operations.Next (Left, L_Node);
end loop;
return; elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
end if; Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Right.Nodes (R_Node),
Dst_Node => Dst_Node);
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then R_Node := Tree_Operations.Next (Right, R_Node);
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node); else
L_Node := Tree_Operations.Next (Left, L_Node);
R_Node := Tree_Operations.Next (Right, R_Node);
end if;
end loop;
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then BL := BL - 1;
Insert_With_Hint LL := LL - 1;
(Dst_Set => Result,
Dst_Hint => 0,
Src_Node => Right.Nodes (R_Node),
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (Right, R_Node); BR := BR - 1;
LR := LR - 1;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
else BR := BR - 1;
L_Node := Tree_Operations.Next (Left, L_Node); LR := LR - 1;
R_Node := Tree_Operations.Next (Right, R_Node);
end if; raise;
end loop; end;
end return; end return;
end Set_Symmetric_Difference; end Set_Symmetric_Difference;
...@@ -541,17 +846,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -541,17 +846,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
return; return;
end if; end if;
if Target.Busy > 0 then -- Per AI05-0022, the container implementation is required to detect
raise Program_Error with -- element tampering by a generic actual subprogram.
"attempt to tamper with cursors (container is busy)";
end if;
-- Note that there's no way to decide a priori whether the target has declare
-- enough capacity for the union with source. We cannot simply compare BS : Natural renames Source'Unrestricted_Access.Busy;
-- the sum of the existing lengths to the capacity of the target, LS : Natural renames Source'Unrestricted_Access.Lock;
-- because equivalent items from source are not included in the union.
Iterate (Source); begin
BS := BS + 1;
LS := LS + 1;
-- Note that there's no way to decide a priori whether the target has
-- enough capacity for the union with source. We cannot simply
-- compare the sum of the existing lengths to the capacity of the
-- target, because equivalent items from source are not included in
-- the union.
Iterate (Source);
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BS := BS - 1;
LS := LS - 1;
raise;
end;
end Set_Union; end Set_Union;
function Set_Union (Left, Right : Set_Type) return Set_Type is function Set_Union (Left, Right : Set_Type) return Set_Type is
...@@ -569,35 +891,65 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ...@@ -569,35 +891,65 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
end if; end if;
return Result : Set_Type (Left.Length + Right.Length) do return Result : Set_Type (Left.Length + Right.Length) do
Assign (Target => Result, Source => Left); declare
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
begin
BL := BL + 1;
LL := LL + 1;
Insert_Right : declare BR := BR + 1;
Hint : Count_Type := 0; LR := LR + 1;
procedure Process (Node : Count_Type); Assign (Target => Result, Source => Left);
pragma Inline (Process);
procedure Iterate is Insert_Right : declare
new Tree_Operations.Generic_Iteration (Process); Hint : Count_Type := 0;
------------- procedure Process (Node : Count_Type);
-- Process -- pragma Inline (Process);
-------------
procedure Iterate is
new Tree_Operations.Generic_Iteration (Process);
-------------
-- Process --
-------------
procedure Process (Node : Count_Type) is
begin
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => Hint,
Src_Node => Right.Nodes (Node),
Dst_Node => Hint);
end Process;
-- Start of processing for Insert_Right
procedure Process (Node : Count_Type) is
begin begin
Insert_With_Hint Iterate (Right);
(Dst_Set => Result, end Insert_Right;
Dst_Hint => Hint,
Src_Node => Right.Nodes (Node),
Dst_Node => Hint);
end Process;
-- Start of processing for Insert_Right BL := BL - 1;
LL := LL - 1;
begin BR := BR - 1;
Iterate (Right); LR := LR - 1;
end Insert_Right; exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end;
end return; end return;
end Set_Union; end Set_Union;
......
gcc/ada/a-cborse.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -979,6 +979,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -979,6 +979,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is
pragma Assert (Vet (Container, Position.Node), pragma Assert (Vet (Container, Position.Node),
"bad cursor in Update_Element_Preserving_Key"); "bad cursor in Update_Element_Preserving_Key");
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
N : Node_Type renames Container.Nodes (Position.Node); N : Node_Type renames Container.Nodes (Position.Node);
E : Element_Type renames N.Element; E : Element_Type renames N.Element;
...@@ -987,12 +990,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -987,12 +990,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is
B : Natural renames Container.Busy; B : Natural renames Container.Busy;
L : Natural renames Container.Lock; L : Natural renames Container.Lock;
Eq : Boolean;
begin begin
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
begin begin
Process (E); Process (E);
Eq := Equivalent_Keys (K, Key (E));
exception exception
when others => when others =>
L := L - 1; L := L - 1;
...@@ -1003,7 +1009,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -1003,7 +1009,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
L := L - 1; L := L - 1;
B := B - 1; B := B - 1;
if Equivalent_Keys (K, Key (E)) then if Eq then
return; return;
end if; end if;
end; end;
...@@ -1727,16 +1733,52 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -1727,16 +1733,52 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Hint : Count_Type; Hint : Count_Type;
Result : Count_Type; Result : Count_Type;
Inserted : Boolean; Inserted : Boolean;
Compare : Boolean;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
-- Start of processing for Replace_Element -- Start of processing for Replace_Element
begin begin
if Item < Node.Element -- Replace_Element assigns value Item to the element designated by Node,
or else Node.Element < Item -- per certain semantic constraints, described as follows.
then
null; -- If Item is equivalent to the element, then element is replaced and
-- there's nothing else to do. This is the easy case.
-- If Item is not equivalent, then the node will (possibly) have to move
-- to some other place in the tree. This is slighly more complicated,
-- because we must ensure that Item is not equivalent to some other
-- element in the tree (in which case, the replacement is not allowed).
-- Determine whether Item is equivalent to element on the specified
-- node.
begin
B := B + 1;
L := L + 1;
Compare := (if Item < Node.Element then False
elsif Node.Element < Item then False
else True);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
else
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (set is locked)"; "attempt to tamper with elements (set is locked)";
...@@ -1746,12 +1788,63 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -1746,12 +1788,63 @@ package body Ada.Containers.Bounded_Ordered_Sets is
return; return;
end if; end if;
-- The replacement Item is not equivalent to the element on the
-- specified node, which means that it will need to be re-inserted in a
-- different position in the tree. We must now determine whether Item is
-- equivalent to some other element in the tree (which would prohibit
-- the assignment and hence the move).
-- Ceiling returns the smallest element equivalent or greater than the
-- specified Item; if there is no such element, then it returns 0.
Hint := Element_Keys.Ceiling (Container, Item); Hint := Element_Keys.Ceiling (Container, Item);
if Hint = 0 then if Hint /= 0 then -- Item <= Nodes (Hint).Element
null; begin
B := B + 1;
L := L + 1;
Compare := Item < Nodes (Hint).Element;
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if not Compare then -- Item is equivalent to Nodes (Hint).Element
-- Ceiling returns an element that is equivalent or greater than
-- Item. If Item is "not less than" the element, then by
-- elimination we know that Item is equivalent to the element.
-- But this means that it is not possible to assign the value of
-- Item to the specified element (on Node), because a different
-- element (on Hint) equivalent to Item already exsits. (Were we
-- to change Node's element value, we would have to move Node, but
-- we would be unable to move the Node, because its new position
-- in the tree is already occupied by an equivalent element.)
raise Program_Error with "attempt to replace existing element";
end if;
-- Item is not equivalent to any other element in the tree
-- (specifically, it is less then Nodes (Hint).Element), so it is
-- safe to assign the value of Item to Node.Element. This means that
-- the node will have to move to a different position in the tree
-- (because its element will have a different value).
-- The nearest (greater) neighbor of Item is Hint. This will be the
-- insertion position of Node (because its element will have Item as
-- its new value).
-- If Node equals Hint, the relative position of Node does not
-- change. This allows us to perform an optimization: we need not
-- remove Node from the tree and then reinsert it with its new value,
-- because it would only be placed in the exact same position.
elsif Item < Nodes (Hint).Element then
if Hint = Index then if Hint = Index then
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error with raise Program_Error with
...@@ -1761,12 +1854,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is ...@@ -1761,12 +1854,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Node.Element := Item; Node.Element := Item;
return; return;
end if; end if;
else
pragma Assert (not (Nodes (Hint).Element < Item));
raise Program_Error with "attempt to replace existing element";
end if; end if;
-- If we get here, it is because Item was greater than all elements in
-- the tree (Hint = 0), or because Item was less than some element at a
-- different place in the tree (Item < Nodes (Hint).Element and Hint /=
-- Index). In either case, we remove Node from the tree and then insert
-- Item into the tree, onto the same Node.
Tree_Operations.Delete_Node_Sans_Free (Container, Index); Tree_Operations.Delete_Node_Sans_Free (Container, Index);
Local_Insert_With_Hint Local_Insert_With_Hint
......
gcc/ada/a-ciorse.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1088,12 +1088,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1088,12 +1088,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
B : Natural renames Tree.Busy; B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock; L : Natural renames Tree.Lock;
Eq : Boolean;
begin begin
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
begin begin
Process (E); Process (E);
Eq := Equivalent_Keys (K, Key (E));
exception exception
when others => when others =>
L := L - 1; L := L - 1;
...@@ -1104,7 +1107,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1104,7 +1107,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
L := L - 1; L := L - 1;
B := B - 1; B := B - 1;
if Equivalent_Keys (K, Key (E)) then if Eq then
return; return;
end if; end if;
end; end;
...@@ -1884,16 +1887,54 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1884,16 +1887,54 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Hint : Node_Access; Hint : Node_Access;
Result : Node_Access; Result : Node_Access;
Inserted : Boolean; Inserted : Boolean;
Compare : Boolean;
X : Element_Access := Node.Element; X : Element_Access := Node.Element;
-- Start of processing for Replace_Element -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
-- Start of processing for Replace_Element
begin begin
if Item < Node.Element.all or else Node.Element.all < Item then -- Replace_Element assigns value Item to the element designated by Node,
null; -- per certain semantic constraints, described as follows.
-- If Item is equivalent to the element, then element is replaced and
-- there's nothing else to do. This is the easy case.
-- If Item is not equivalent, then the node will (possibly) have to move
-- to some other place in the tree. This is slighly more complicated,
-- because we must ensure that Item is not equivalent to some other
-- element in the tree (in which case, the replacement is not allowed).
-- Determine whether Item is equivalent to element on the specified
-- node.
begin
B := B + 1;
L := L + 1;
Compare := (if Item < Node.Element.all then False
elsif Node.Element.all < Item then False
else True);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (set is locked)"; "attempt to tamper with elements (set is locked)";
...@@ -1914,12 +1955,62 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1914,12 +1955,62 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return; return;
end if; end if;
-- The replacement Item is not equivalent to the element on the
-- specified node, which means that it will need to be re-inserted in a
-- different position in the tree. We must now determine whether Item is
-- equivalent to some other element in the tree (which would prohibit
-- the assignment and hence the move).
-- Ceiling returns the smallest element equivalent or greater than the
-- specified Item; if there is no such element, then it returns null.
Hint := Element_Keys.Ceiling (Tree, Item); Hint := Element_Keys.Ceiling (Tree, Item);
if Hint = null then if Hint /= null then
null; begin
B := B + 1;
L := L + 1;
Compare := Item < Hint.Element.all;
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if not Compare then -- Item >= Hint.Element
-- Ceiling returns an element that is equivalent or greater than
-- Item. If Item is "not less than" the element, then by
-- elimination we know that Item is equivalent to the element.
-- But this means that it is not possible to assign the value of
-- Item to the specified element (on Node), because a different
-- element (on Hint) equivalent to Item already exsits. (Were we
-- to change Node's element value, we would have to move Node, but
-- we would be unable to move the Node, because its new position
-- in the tree is already occupied by an equivalent element.)
raise Program_Error with "attempt to replace existing element";
end if;
-- Item is not equivalent to any other element in the tree, so it is
-- safe to assign the value of Item to Node.Element. This means that
-- the node will have to move to a different position in the tree
-- (because its element will have a different value).
-- The nearest (greater) neighbor of Item is Hint. This will be the
-- insertion position of Node (because its element will have Item as
-- its new value).
-- If Node equals Hint, the relative position of Node does not
-- change. This allows us to perform an optimization: we need not
-- remove Node from the tree and then reinsert it with its new value,
-- because it would only be placed in the exact same position.
elsif Item < Hint.Element.all then
if Hint = Node then if Hint = Node then
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
...@@ -1940,12 +2031,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1940,12 +2031,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return; return;
end if; end if;
else
pragma Assert (not (Hint.Element.all < Item));
raise Program_Error with "attempt to replace existing element";
end if; end if;
-- If we get here, it is because Item was greater than all elements in
-- the tree (Hint = null), or because Item was less than some element at
-- a different place in the tree (Item < Hint.Element.all). In either
-- case, we remove Node from the tree (without actually deallocating
-- it), and then insert Item into the tree, onto the same Node (so no
-- new node is actually allocated).
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Local_Insert_With_Hint Local_Insert_With_Hint
......
gcc/ada/a-coorse.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -987,12 +987,15 @@ package body Ada.Containers.Ordered_Sets is ...@@ -987,12 +987,15 @@ package body Ada.Containers.Ordered_Sets is
B : Natural renames Tree.Busy; B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock; L : Natural renames Tree.Lock;
Eq : Boolean;
begin begin
B := B + 1; B := B + 1;
L := L + 1; L := L + 1;
begin begin
Process (E); Process (E);
Eq := Equivalent_Keys (K, Key (E));
exception exception
when others => when others =>
L := L - 1; L := L - 1;
...@@ -1003,7 +1006,7 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1003,7 +1006,7 @@ package body Ada.Containers.Ordered_Sets is
L := L - 1; L := L - 1;
B := B - 1; B := B - 1;
if Equivalent_Keys (K, Key (E)) then if Eq then
return; return;
end if; end if;
end; end;
...@@ -1716,17 +1719,55 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1716,17 +1719,55 @@ package body Ada.Containers.Ordered_Sets is
return Node; return Node;
end New_Node; end New_Node;
Hint : Node_Access; Hint : Node_Access;
Result : Node_Access; Result : Node_Access;
Inserted : Boolean; Inserted : Boolean;
Compare : Boolean;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
-- Start of processing for Replace_Element -- Start of processing for Replace_Element
begin begin
if Item < Node.Element or else Node.Element < Item then -- Replace_Element assigns value Item to the element designated by Node,
null; -- per certain semantic constraints.
-- If Item is equivalent to the element, then element is replaced and
-- there's nothing else to do. This is the easy case.
-- If Item is not equivalent, then the node will (possibly) have to move
-- to some other place in the tree. This is slighly more complicated,
-- because we must ensure that Item is not equivalent to some other
-- element in the tree (in which case, the replacement is not allowed).
-- Determine whether Item is equivalent to element on the specified
-- node.
begin
B := B + 1;
L := L + 1;
Compare := (if Item < Node.Element then False
elsif Node.Element < Item then False
else True);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
-- Item is equivalent to the node's element, so we will not have to
-- move the node.
else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (set is locked)"; "attempt to tamper with elements (set is locked)";
...@@ -1736,12 +1777,62 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1736,12 +1777,62 @@ package body Ada.Containers.Ordered_Sets is
return; return;
end if; end if;
-- The replacement Item is not equivalent to the element on the
-- specified node, which means that it will need to be re-inserted in a
-- different position in the tree. We must now determine whether Item is
-- equivalent to some other element in the tree (which would prohibit
-- the assignment and hence the move).
-- Ceiling returns the smallest element equivalent or greater than the
-- specified Item; if there is no such element, then it returns null.
Hint := Element_Keys.Ceiling (Tree, Item); Hint := Element_Keys.Ceiling (Tree, Item);
if Hint = null then if Hint /= null then
null; begin
B := B + 1;
L := L + 1;
Compare := Item < Hint.Element;
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if not Compare then -- Item >= Hint.Element
-- Ceiling returns an element that is equivalent or greater than
-- Item. If Item is "not less than" the element, then by
-- elimination we know that Item is equivalent to the element.
-- But this means that it is not possible to assign the value of
-- Item to the specified element (on Node), because a different
-- element (on Hint) equivalent to Item already exsits. (Were we
-- to change Node's element value, we would have to move Node, but
-- we would be unable to move the Node, because its new position
-- in the tree is already occupied by an equivalent element.)
raise Program_Error with "attempt to replace existing element";
end if;
-- Item is not equivalent to any other element in the tree, so it is
-- safe to assign the value of Item to Node.Element. This means that
-- the node will have to move to a different position in the tree
-- (because its element will have a different value).
-- The nearest (greater) neighbor of Item is Hint. This will be the
-- insertion position of Node (because its element will have Item as
-- its new value).
-- If Node equals Hint, the relative position of Node does not
-- change. This allows us to perform an optimization: we need not
-- remove Node from the tree and then reinsert it with its new value,
-- because it would only be placed in the exact same position.
elsif Item < Hint.Element then
if Hint = Node then if Hint = Node then
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
...@@ -1751,15 +1842,18 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1751,15 +1842,18 @@ package body Ada.Containers.Ordered_Sets is
Node.Element := Item; Node.Element := Item;
return; return;
end if; end if;
else
pragma Assert (not (Hint.Element < Item));
raise Program_Error with "attempt to replace existing element";
end if; end if;
-- If we get here, it is because Item was greater than all elements in
-- the tree (Hint = null), or because Item was less than some element at
-- a different place in the tree (Item < Hint.Element). In either case,
-- we remove Node from the tree (without actually deallocating it), and
-- then insert Item into the tree, onto the same Node (so no new node is
-- actually allocated).
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Local_Insert_With_Hint Local_Insert_With_Hint -- use unconditional insert here instead???
(Tree => Tree, (Tree => Tree,
Position => Hint, Position => Hint,
Key => Item, Key => Item,
......
gcc/ada/a-crbtgk.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,10 +38,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -38,10 +38,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- AKA Lower_Bound -- AKA Lower_Bound
function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
B : Natural renames Tree'Unrestricted_Access.Busy;
L : Natural renames Tree'Unrestricted_Access.Lock;
Y : Node_Access; Y : Node_Access;
X : Node_Access; X : Node_Access;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
X := Tree.Root; X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Greater_Key_Node (Key, X) then if Is_Greater_Key_Node (Key, X) then
...@@ -52,18 +61,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -52,18 +61,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
return Y; return Y;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Ceiling; end Ceiling;
---------- ----------
-- Find -- -- Find --
---------- ----------
function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
B : Natural renames Tree'Unrestricted_Access.Busy;
L : Natural renames Tree'Unrestricted_Access.Lock;
Y : Node_Access; Y : Node_Access;
X : Node_Access; X : Node_Access;
Result : Node_Access;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
X := Tree.Root; X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Greater_Key_Node (Key, X) then if Is_Greater_Key_Node (Key, X) then
...@@ -75,25 +103,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -75,25 +103,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
end loop; end loop;
if Y = null then if Y = null then
return null; Result := null;
end if;
elsif Is_Less_Key_Node (Key, Y) then
Result := null;
if Is_Less_Key_Node (Key, Y) then else
return null; Result := Y;
end if; end if;
return Y; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find; end Find;
----------- -----------
-- Floor -- -- Floor --
----------- -----------
function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
B : Natural renames Tree'Unrestricted_Access.Busy;
L : Natural renames Tree'Unrestricted_Access.Lock;
Y : Node_Access; Y : Node_Access;
X : Node_Access; X : Node_Access;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
X := Tree.Root; X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Less_Key_Node (Key, X) then if Is_Less_Key_Node (Key, X) then
...@@ -104,7 +151,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -104,7 +151,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
return Y; return Y;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Floor; end Floor;
-------------------------------- --------------------------------
...@@ -117,8 +172,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -117,8 +172,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Node : out Node_Access; Node : out Node_Access;
Inserted : out Boolean) Inserted : out Boolean)
is is
Y : Node_Access := null; X : Node_Access;
X : Node_Access := Tree.Root; Y : Node_Access;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
Compare : Boolean;
begin begin
-- This is a "conditional" insertion, meaning that the insertion request -- This is a "conditional" insertion, meaning that the insertion request
...@@ -136,12 +199,27 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -136,12 +199,27 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- either the smallest node greater than Key (Inserted is True), or the -- either the smallest node greater than Key (Inserted is True), or the
-- largest node less or equivalent to Key (Inserted is False). -- largest node less or equivalent to Key (Inserted is False).
Inserted := True; begin
while X /= null loop B := B + 1;
Y := X; L := L + 1;
Inserted := Is_Less_Key_Node (Key, X);
X := (if Inserted then Ops.Left (X) else Ops.Right (X)); X := Tree.Root;
end loop; Y := null;
Inserted := True;
while X /= null loop
Y := X;
Inserted := Is_Less_Key_Node (Key, X);
X := (if Inserted then Ops.Left (X) else Ops.Right (X));
end loop;
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Inserted then if Inserted then
...@@ -172,7 +250,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -172,7 +250,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- Key is equivalent to or greater than Node. We must resolve which is -- Key is equivalent to or greater than Node. We must resolve which is
-- the case, to determine whether the conditional insertion succeeds. -- the case, to determine whether the conditional insertion succeeds.
if Is_Greater_Key_Node (Key, Node) then begin
B := B + 1;
L := L + 1;
Compare := Is_Greater_Key_Node (Key, Node);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
-- Key is strictly greater than Node, which means that Key is not -- Key is strictly greater than Node, which means that Key is not
-- equivalent to Node. In this case, the insertion succeeds, and we -- equivalent to Node. In this case, the insertion succeeds, and we
...@@ -201,6 +294,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -201,6 +294,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Node : out Node_Access; Node : out Node_Access;
Inserted : out Boolean) Inserted : out Boolean)
is is
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
Test : Node_Access;
Compare : Boolean;
begin begin
-- The purpose of a hint is to avoid a search from the root of -- The purpose of a hint is to avoid a search from the root of
-- tree. If we have it hint it means we only need to traverse the -- tree. If we have it hint it means we only need to traverse the
...@@ -215,9 +317,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -215,9 +317,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- done; otherwise the hint was "wrong" and we must search. -- done; otherwise the hint was "wrong" and we must search.
if Position = null then -- largest if Position = null then -- largest
if Tree.Last = null begin
or else Is_Greater_Key_Node (Key, Tree.Last) B := B + 1;
then L := L + 1;
Compare := Tree.Last = null
or else Is_Greater_Key_Node (Key, Tree.Last);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
Insert_Post (Tree, Tree.Last, False, Node); Insert_Post (Tree, Tree.Last, False, Node);
Inserted := True; Inserted := True;
else else
...@@ -246,28 +362,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -246,28 +362,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- then its neighbor must be anterior and so we insert before the -- then its neighbor must be anterior and so we insert before the
-- hint. -- hint.
if Is_Less_Key_Node (Key, Position) then begin
declare B := B + 1;
Before : constant Node_Access := Ops.Previous (Position); L := L + 1;
Compare := Is_Less_Key_Node (Key, Position);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
begin if Compare then
if Before = null then Test := Ops.Previous (Position); -- "before"
Insert_Post (Tree, Tree.First, True, Node);
Inserted := True;
elsif Is_Greater_Key_Node (Key, Before) then if Test = null then -- new first node
if Ops.Right (Before) = null then Insert_Post (Tree, Tree.First, True, Node);
Insert_Post (Tree, Before, False, Node);
else
Insert_Post (Tree, Position, True, Node);
end if;
Inserted := True; Inserted := True;
return;
end if;
begin
B := B + 1;
L := L + 1;
Compare := Is_Greater_Key_Node (Key, Test);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
if Ops.Right (Test) = null then
Insert_Post (Tree, Test, False, Node);
else else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); Insert_Post (Tree, Position, True, Node);
end if; end if;
end;
Inserted := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
return; return;
end if; end if;
...@@ -278,28 +424,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -278,28 +424,58 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- greater than the hint and less than the hint's next neighbor, -- greater than the hint and less than the hint's next neighbor,
-- then we're done; otherwise we must search. -- then we're done; otherwise we must search.
if Is_Greater_Key_Node (Key, Position) then begin
declare B := B + 1;
After : constant Node_Access := Ops.Next (Position); L := L + 1;
Compare := Is_Greater_Key_Node (Key, Position);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
begin if Compare then
if After = null then Test := Ops.Next (Position); -- "after"
Insert_Post (Tree, Tree.Last, False, Node);
Inserted := True;
elsif Is_Less_Key_Node (Key, After) then if Test = null then -- new last node
if Ops.Right (Position) = null then Insert_Post (Tree, Tree.Last, False, Node);
Insert_Post (Tree, Position, False, Node);
else
Insert_Post (Tree, After, True, Node);
end if;
Inserted := True; Inserted := True;
return;
end if;
begin
B := B + 1;
L := L + 1;
Compare := Is_Less_Key_Node (Key, Test);
L := L - 1;
B := B - 1;
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
if Compare then
if Ops.Right (Position) = null then
Insert_Post (Tree, Position, False, Node);
else else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); Insert_Post (Tree, Test, True, Node);
end if; end if;
end;
Inserted := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
return; return;
end if; end if;
......
gcc/ada/a-crbtgo.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -626,9 +626,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -626,9 +626,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
------------------- -------------------
function Generic_Equal (Left, Right : Tree_Type) return Boolean is function Generic_Equal (Left, Right : Tree_Type) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
L_Node : Node_Access; L_Node : Node_Access;
R_Node : Node_Access; R_Node : Node_Access;
Result : Boolean;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return True; return True;
...@@ -638,18 +646,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -638,18 +646,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First; L_Node := Left.First;
R_Node := Right.First; R_Node := Right.First;
Result := True;
while L_Node /= null loop while L_Node /= null loop
if not Is_Equal (L_Node, R_Node) then if not Is_Equal (L_Node, R_Node) then
return False; Result := False;
exit;
end if; end if;
L_Node := Next (L_Node); L_Node := Next (L_Node);
R_Node := Next (R_Node); R_Node := Next (R_Node);
end loop; end loop;
return True; BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end Generic_Equal; end Generic_Equal;
----------------------- -----------------------
......
gcc/ada/a-rbtgbo.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -606,9 +606,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ...@@ -606,9 +606,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
------------------- -------------------
function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
L_Node : Count_Type; L_Node : Count_Type;
R_Node : Count_Type; R_Node : Count_Type;
Result : Boolean;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return True; return True;
...@@ -618,18 +626,43 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ...@@ -618,18 +626,43 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First; L_Node := Left.First;
R_Node := Right.First; R_Node := Right.First;
while L_Node /= 0 loop while L_Node /= 0 loop
if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
return False; Result := False;
exit;
end if; end if;
L_Node := Next (Left, L_Node); L_Node := Next (Left, L_Node);
R_Node := Next (Right, R_Node); R_Node := Next (Right, R_Node);
end loop; end loop;
return True; BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end Generic_Equal; end Generic_Equal;
----------------------- -----------------------
......
gcc/ada/a-rbtgso.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -84,8 +84,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -84,8 +84,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
---------------- ----------------
procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
Tgt : Node_Access := Target.First; BT : Natural renames Target.Busy;
Src : Node_Access := Source.First; LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt : Node_Access;
Src : Node_Access;
Compare : Integer;
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
...@@ -107,19 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -107,19 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
"attempt to tamper with cursors (container is busy)"; "attempt to tamper with cursors (container is busy)";
end if; end if;
Tgt := Target.First;
Src := Source.First;
loop loop
if Tgt = null then if Tgt = null then
return; exit;
end if; end if;
if Src = null then if Src = null then
return; exit;
end if; end if;
if Is_Less (Tgt, Src) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
Tgt := Tree_Operations.Next (Tgt); Tgt := Tree_Operations.Next (Tgt);
elsif Is_Less (Src, Tgt) then elsif Compare > 0 then
Src := Tree_Operations.Next (Src); Src := Tree_Operations.Next (Src);
else else
...@@ -137,34 +181,66 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -137,34 +181,66 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end Difference; end Difference;
function Difference (Left, Right : Tree_Type) return Tree_Type is function Difference (Left, Right : Tree_Type) return Tree_Type is
Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Tree; -- Empty set return Tree_Type'(others => <>); -- Empty set
end if; end if;
if Left.Length = 0 then if Left.Length = 0 then
return Tree; -- Empty set return Tree_Type'(others => <>); -- Empty set
end if; end if;
if Right.Length = 0 then if Right.Length = 0 then
return Copy (Left); return Copy (Left);
end if; end if;
loop -- Per AI05-0022, the container implementation is required to detect
if L_Node = null then -- element tampering by a generic actual subprogram.
return Tree;
end if; declare
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Tree : Tree_Type;
L_Node : Node_Access;
R_Node : Node_Access;
Dst_Node : Node_Access;
pragma Warnings (Off, Dst_Node);
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = null then
exit;
end if;
if R_Node = null then
while L_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node);
end loop;
exit;
end if;
if R_Node = null then if Is_Less (L_Node, R_Node) then
while L_Node /= null loop
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Tree, (Dst_Tree => Tree,
Dst_Hint => null, Dst_Hint => null,
...@@ -173,33 +249,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -173,33 +249,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
L_Node := Tree_Operations.Next (L_Node); L_Node := Tree_Operations.Next (L_Node);
end loop; elsif Is_Less (R_Node, L_Node) then
R_Node := Tree_Operations.Next (R_Node);
return Tree; else
end if; L_Node := Tree_Operations.Next (L_Node);
R_Node := Tree_Operations.Next (R_Node);
end if;
end loop;
if Is_Less (L_Node, R_Node) then BL := BL - 1;
Insert_With_Hint LL := LL - 1;
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node); BR := BR - 1;
LR := LR - 1;
elsif Is_Less (R_Node, L_Node) then return Tree;
R_Node := Tree_Operations.Next (R_Node); exception
when others =>
BL := BL - 1;
LL := LL - 1;
else BR := BR - 1;
L_Node := Tree_Operations.Next (L_Node); LR := LR - 1;
R_Node := Tree_Operations.Next (R_Node);
end if;
end loop;
exception Delete_Tree (Tree.Root);
when others => raise;
Delete_Tree (Tree.Root); end;
raise;
end Difference; end Difference;
------------------ ------------------
...@@ -210,8 +286,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -210,8 +286,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
(Target : in out Tree_Type; (Target : in out Tree_Type;
Source : Tree_Type) Source : Tree_Type)
is is
Tgt : Node_Access := Target.First; BT : Natural renames Target.Busy;
Src : Node_Access := Source.First; LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt : Node_Access;
Src : Node_Access;
Compare : Integer;
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
...@@ -228,10 +312,46 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -228,10 +312,46 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return; return;
end if; end if;
Tgt := Target.First;
Src := Source.First;
while Tgt /= null while Tgt /= null
and then Src /= null and then Src /= null
loop loop
if Is_Less (Tgt, Src) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
declare declare
X : Node_Access := Tgt; X : Node_Access := Tgt;
begin begin
...@@ -240,7 +360,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -240,7 +360,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
Free (X); Free (X);
end; end;
elsif Is_Less (Src, Tgt) then elsif Compare > 0 then
Src := Tree_Operations.Next (Src); Src := Tree_Operations.Next (Src);
else else
...@@ -261,50 +381,83 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -261,50 +381,83 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end Intersection; end Intersection;
function Intersection (Left, Right : Tree_Type) return Tree_Type is function Intersection (Left, Right : Tree_Type) return Tree_Type is
Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Copy (Left); return Copy (Left);
end if; end if;
loop -- Per AI05-0022, the container implementation is required to detect
if L_Node = null then -- element tampering by a generic actual subprogram.
return Tree;
end if;
if R_Node = null then declare
return Tree; BL : Natural renames Left'Unrestricted_Access.Busy;
end if; LL : Natural renames Left'Unrestricted_Access.Lock;
if Is_Less (L_Node, R_Node) then BR : Natural renames Right'Unrestricted_Access.Busy;
L_Node := Tree_Operations.Next (L_Node); LR : Natural renames Right'Unrestricted_Access.Lock;
elsif Is_Less (R_Node, L_Node) then Tree : Tree_Type;
R_Node := Tree_Operations.Next (R_Node);
else L_Node : Node_Access;
Insert_With_Hint R_Node : Node_Access;
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node); Dst_Node : Node_Access;
R_Node := Tree_Operations.Next (R_Node); pragma Warnings (Off, Dst_Node);
end if;
end loop; begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = null then
exit;
end if;
if R_Node = null then
exit;
end if;
if Is_Less (L_Node, R_Node) then
L_Node := Tree_Operations.Next (L_Node);
elsif Is_Less (R_Node, L_Node) then
R_Node := Tree_Operations.Next (R_Node);
exception else
when others => Insert_With_Hint
Delete_Tree (Tree.Root); (Dst_Tree => Tree,
raise; Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node);
R_Node := Tree_Operations.Next (R_Node);
end if;
end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Tree;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
Delete_Tree (Tree.Root);
raise;
end;
end Intersection; end Intersection;
--------------- ---------------
...@@ -324,22 +477,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -324,22 +477,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
Subset_Node : Node_Access := Subset.First; BL : Natural renames Subset'Unrestricted_Access.Busy;
Set_Node : Node_Access := Of_Set.First; LL : Natural renames Subset'Unrestricted_Access.Lock;
BR : Natural renames Of_Set'Unrestricted_Access.Busy;
LR : Natural renames Of_Set'Unrestricted_Access.Lock;
Subset_Node : Node_Access;
Set_Node : Node_Access;
Result : Boolean;
begin begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Subset_Node := Subset.First;
Set_Node := Of_Set.First;
loop loop
if Set_Node = null then if Set_Node = null then
return Subset_Node = null; Result := Subset_Node = null;
exit;
end if; end if;
if Subset_Node = null then if Subset_Node = null then
return True; Result := True;
exit;
end if; end if;
if Is_Less (Subset_Node, Set_Node) then if Is_Less (Subset_Node, Set_Node) then
return False; Result := False;
exit;
end if; end if;
if Is_Less (Set_Node, Subset_Node) then if Is_Less (Set_Node, Subset_Node) then
...@@ -349,6 +524,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -349,6 +524,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
Subset_Node := Tree_Operations.Next (Subset_Node); Subset_Node := Tree_Operations.Next (Subset_Node);
end if; end if;
end loop; end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end; end;
end Is_Subset; end Is_Subset;
...@@ -357,31 +549,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -357,31 +549,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
------------- -------------
function Overlap (Left, Right : Tree_Type) return Boolean is function Overlap (Left, Right : Tree_Type) return Boolean is
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Left.Length /= 0; return Left.Length /= 0;
end if; end if;
loop -- Per AI05-0022, the container implementation is required to detect
if L_Node = null -- element tampering by a generic actual subprogram.
or else R_Node = null
then
return False;
end if;
if Is_Less (L_Node, R_Node) then declare
L_Node := Tree_Operations.Next (L_Node); BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
elsif Is_Less (R_Node, L_Node) then BR : Natural renames Right'Unrestricted_Access.Busy;
R_Node := Tree_Operations.Next (R_Node); LR : Natural renames Right'Unrestricted_Access.Lock;
else L_Node : Node_Access;
return True; R_Node : Node_Access;
end if;
end loop; Result : Boolean;
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = null
or else R_Node = null
then
Result := False;
exit;
end if;
if Is_Less (L_Node, R_Node) then
L_Node := Tree_Operations.Next (L_Node);
elsif Is_Less (R_Node, L_Node) then
R_Node := Tree_Operations.Next (R_Node);
else
Result := True;
exit;
end if;
end loop;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end;
end Overlap; end Overlap;
-------------------------- --------------------------
...@@ -392,23 +625,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -392,23 +625,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
(Target : in out Tree_Type; (Target : in out Tree_Type;
Source : Tree_Type) Source : Tree_Type)
is is
Tgt : Node_Access := Target.First; BT : Natural renames Target.Busy;
Src : Node_Access := Source.First; LT : Natural renames Target.Lock;
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
Tgt : Node_Access;
Src : Node_Access;
New_Tgt_Node : Node_Access; New_Tgt_Node : Node_Access;
pragma Warnings (Off, New_Tgt_Node); pragma Warnings (Off, New_Tgt_Node);
begin Compare : Integer;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
Clear (Target); Clear (Target);
return; return;
end if; end if;
Tgt := Target.First;
Src := Source.First;
loop loop
if Tgt = null then if Tgt = null then
while Src /= null loop while Src /= null loop
...@@ -428,10 +666,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -428,10 +666,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return; return;
end if; end if;
if Is_Less (Tgt, Src) then -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
begin
BT := BT + 1;
LT := LT + 1;
BS := BS + 1;
LS := LS + 1;
if Is_Less (Tgt, Src) then
Compare := -1;
elsif Is_Less (Src, Tgt) then
Compare := 1;
else
Compare := 0;
end if;
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
exception
when others =>
BT := BT - 1;
LT := LT - 1;
BS := BS - 1;
LS := LS - 1;
raise;
end;
if Compare < 0 then
Tgt := Tree_Operations.Next (Tgt); Tgt := Tree_Operations.Next (Tgt);
elsif Is_Less (Src, Tgt) then elsif Compare > 0 then
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Target, (Dst_Tree => Target,
Dst_Hint => Tgt, Dst_Hint => Tgt,
...@@ -455,17 +727,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -455,17 +727,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end Symmetric_Difference; end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
pragma Warnings (Off, Dst_Node);
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return Tree; -- Empty set return Tree_Type'(others => <>); -- Empty set
end if; end if;
if Right.Length = 0 then if Right.Length = 0 then
...@@ -476,70 +740,110 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -476,70 +740,110 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return Copy (Right); return Copy (Right);
end if; end if;
loop -- Per AI05-0022, the container implementation is required to detect
if L_Node = null then -- element tampering by a generic actual subprogram.
while R_Node /= null loop
declare
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Tree : Tree_Type;
L_Node : Node_Access;
R_Node : Node_Access;
Dst_Node : Node_Access;
pragma Warnings (Off, Dst_Node);
begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
L_Node := Left.First;
R_Node := Right.First;
loop
if L_Node = null then
while R_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => R_Node,
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (R_Node);
end loop;
exit;
end if;
if R_Node = null then
while L_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node);
end loop;
exit;
end if;
if Is_Less (L_Node, R_Node) then
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Tree, (Dst_Tree => Tree,
Dst_Hint => null, Dst_Hint => null,
Src_Node => R_Node, Src_Node => L_Node,
Dst_Node => Dst_Node); Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (R_Node);
end loop;
return Tree; L_Node := Tree_Operations.Next (L_Node);
end if;
if R_Node = null then elsif Is_Less (R_Node, L_Node) then
while L_Node /= null loop
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Tree, (Dst_Tree => Tree,
Dst_Hint => null, Dst_Hint => null,
Src_Node => L_Node, Src_Node => R_Node,
Dst_Node => Dst_Node); Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node); R_Node := Tree_Operations.Next (R_Node);
end loop;
return Tree; else
end if; L_Node := Tree_Operations.Next (L_Node);
R_Node := Tree_Operations.Next (R_Node);
end if;
end loop;
if Is_Less (L_Node, R_Node) then BL := BL - 1;
Insert_With_Hint LL := LL - 1;
(Dst_Tree => Tree,
Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (L_Node); BR := BR - 1;
LR := LR - 1;
elsif Is_Less (R_Node, L_Node) then return Tree;
Insert_With_Hint exception
(Dst_Tree => Tree, when others =>
Dst_Hint => null, BL := BL - 1;
Src_Node => R_Node, LL := LL - 1;
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (R_Node); BR := BR - 1;
LR := LR - 1;
else Delete_Tree (Tree.Root);
L_Node := Tree_Operations.Next (L_Node); raise;
R_Node := Tree_Operations.Next (R_Node); end;
end if;
end loop;
exception
when others =>
Delete_Tree (Tree.Root);
raise;
end Symmetric_Difference; end Symmetric_Difference;
----------- -----------
-- Union -- -- Union --
----------- -----------
procedure Union (Target : in out Tree_Type; Source : Tree_Type) procedure Union (Target : in out Tree_Type; Source : Tree_Type) is
is
Hint : Node_Access; Hint : Node_Access;
procedure Process (Node : Node_Access); procedure Process (Node : Node_Access);
...@@ -555,7 +859,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -555,7 +859,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin begin
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Target, (Dst_Tree => Target,
Dst_Hint => Hint, Dst_Hint => Hint, -- use node most recently inserted as hint
Src_Node => Node, Src_Node => Node,
Dst_Node => Hint); Dst_Node => Hint);
end Process; end Process;
...@@ -567,12 +871,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -567,12 +871,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
return; return;
end if; end if;
if Target.Busy > 0 then -- Per AI05-0022, the container implementation is required to detect
raise Program_Error with -- element tampering by a generic actual subprogram.
"attempt to tamper with cursors (container is busy)";
end if; declare
BS : Natural renames Source'Unrestricted_Access.Busy;
LS : Natural renames Source'Unrestricted_Access.Lock;
begin
BS := BS + 1;
LS := LS + 1;
Iterate (Source);
Iterate (Source); BS := BS - 1;
LS := LS - 1;
exception
when others =>
BS := BS - 1;
LS := LS - 1;
raise;
end;
end Union; end Union;
function Union (Left, Right : Tree_Type) return Tree_Type is function Union (Left, Right : Tree_Type) return Tree_Type is
...@@ -590,6 +910,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -590,6 +910,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if; end if;
declare declare
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Tree : Tree_Type := Copy (Left); Tree : Tree_Type := Copy (Left);
Hint : Node_Access; Hint : Node_Access;
...@@ -608,7 +934,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -608,7 +934,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin begin
Insert_With_Hint Insert_With_Hint
(Dst_Tree => Tree, (Dst_Tree => Tree,
Dst_Hint => Hint, Dst_Hint => Hint, -- use node most recently inserted as hint
Src_Node => Node, Src_Node => Node,
Dst_Node => Hint); Dst_Node => Hint);
end Process; end Process;
...@@ -616,15 +942,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ...@@ -616,15 +942,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
-- Start of processing for Union -- Start of processing for Union
begin begin
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Iterate (Right); Iterate (Right);
return Tree;
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Tree;
exception exception
when others => when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
Delete_Tree (Tree.Root); Delete_Tree (Tree.Root);
raise; raise;
end; end;
end Union; end Union;
end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
gcc/ada/cio.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * C Implementation File *
* * * *
* Copyright (C) 1992-2012, Free Software Foundation, Inc. * * Copyright (C) 1992-2013, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -40,6 +40,9 @@ ...@@ -40,6 +40,9 @@
#include "adaint.h" #include "adaint.h"
/* We need L_tmpnam definition */
#include <stdio.h>
#ifdef __cplusplus #ifdef __cplusplus
extern "C" { extern "C" {
#endif #endif
...@@ -135,7 +138,18 @@ put_char_stderr (int c) ...@@ -135,7 +138,18 @@ put_char_stderr (int c)
char * char *
mktemp (char *template) mktemp (char *template)
{ {
#if !(defined (__RTP__) || defined (VTHREADS))
static char buf[L_tmpnam]; /* Internal buffer for name */
/* If parameter is NULL use internal buffer */
if (template == NULL)
template = buf;
__gnat_tmp_name (template);
return template;
#else
return tmpnam (NULL); return tmpnam (NULL);
#endif
} }
#endif #endif
......
gcc/ada/debug.adb
...@@ -134,7 +134,7 @@ package body Debug is ...@@ -134,7 +134,7 @@ package body Debug is
-- d.N Add node to all entities -- d.N Add node to all entities
-- d.O Dump internal SCO tables -- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons -- d.P Previous (non-optimized) handling of length comparisons
-- d.Q -- d.Q Flow Analysis mode for gnat2why
-- d.R Restrictions in ali files in positional form -- d.R Restrictions in ali files in positional form
-- d.S Force Optimize_Alignment (Space) -- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time) -- d.T Force Optimize_Alignment (Time)
...@@ -648,6 +648,9 @@ package body Debug is ...@@ -648,6 +648,9 @@ package body Debug is
-- This is there in case we find a situation where the optimization -- This is there in case we find a situation where the optimization
-- malfunctions, to provide a work around. -- malfunctions, to provide a work around.
-- d.Q Flow Analysis mode for gnat2why. When this flag is given,
-- gnat2why will do flow analysis, and no translation to Why is done.
-- d.R As documented in lib-writ.ads, restrictions in the ali file can -- d.R As documented in lib-writ.ads, restrictions in the ali file can
-- have two forms, positional and named. The named notation is the -- have two forms, positional and named. The named notation is the
-- current preferred form, but the use of this debug switch will force -- current preferred form, but the use of this debug switch will force
......
gcc/ada/exp_ch3.adb
...@@ -4825,10 +4825,146 @@ package body Exp_Ch3 is ...@@ -4825,10 +4825,146 @@ package body Exp_Ch3 is
-- which case the init proc call must be inserted only after the bodies -- which case the init proc call must be inserted only after the bodies
-- of the shared variable procedures have been seen. -- of the shared variable procedures have been seen.
function Build_Equivalent_Aggregate return Boolean;
-- If the object has a constrained discriminated type and no initial
-- value, it may be possible to build an equivalent aggregate instead,
-- and prevent an actual call to the initialization procedure.
function Rewrite_As_Renaming return Boolean; function Rewrite_As_Renaming return Boolean;
-- Indicate whether to rewrite a declaration with initialization into an -- Indicate whether to rewrite a declaration with initialization into an
-- object renaming declaration (see below). -- object renaming declaration (see below).
--------------------------------
-- Build_Equivalent_Aggregate --
--------------------------------
function Build_Equivalent_Aggregate return Boolean is
Aggr : Node_Id;
Comp : Entity_Id;
Discr : Elmt_Id;
Full_Type : Entity_Id;
begin
Full_Type := Typ;
if Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
Full_Type := Full_View (Typ);
end if;
-- Only perform this transformation if Elaboration_Code is forbidden
-- or undesirable, and if this is a global entity of a constrained
-- record type.
-- If Initialize_Scalars might be active this transformation cannot
-- be performed either, because it will lead to different semantics
-- or because elaboration code will in fact be created.
if Ekind (Full_Type) /= E_Record_Subtype
or else not Has_Discriminants (Full_Type)
or else not Is_Constrained (Full_Type)
or else Is_Controlled (Full_Type)
or else Is_Limited_Type (Full_Type)
or else not Restriction_Active (No_Initialize_Scalars)
then
return False;
end if;
if Ekind (Current_Scope) = E_Package
and then
(Restriction_Active (No_Elaboration_Code)
or else Is_Preelaborated (Current_Scope))
then
-- Building a static aggregate is possible if the discriminants
-- have static values and the other components have static
-- defaults or none.
Discr := First_Elmt (Discriminant_Constraint (Full_Type));
while Present (Discr) loop
if not Is_OK_Static_Expression (Node (Discr)) then
return False;
end if;
Next_Elmt (Discr);
end loop;
-- Check that initialized components are OK, and that non-
-- initialized components do not require a call to their own
-- initialization procedure.
Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Present (Expression (Parent (Comp)))
and then
not Is_OK_Static_Expression (Expression (Parent (Comp)))
then
return False;
elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
return False;
end if;
Next_Component (Comp);
end loop;
-- Everything is static, assemble the aggregate, discriminant
-- values first.
Aggr :=
Make_Aggregate (Loc,
Expressions => New_List,
Component_Associations => New_List);
Discr := First_Elmt (Discriminant_Constraint (Full_Type));
while Present (Discr) loop
Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
Next_Elmt (Discr);
end loop;
-- Now collect values of initialized components.
Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Present (Expression (Parent (Comp)))
then
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (New_Occurrence_Of (Comp, Loc)),
Expression => New_Copy_Tree
(Expression (Parent (Comp)))));
end if;
Next_Component (Comp);
end loop;
-- Finally, box-initialize remaining components.
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (Make_Others_Choice (Loc)),
Expression => Empty));
Set_Box_Present (Last (Component_Associations (Aggr)));
Set_Expression (N, Aggr);
if Typ /= Full_Type then
Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
Analyze_And_Resolve (Aggr, Typ);
else
Analyze_And_Resolve (Aggr, Full_Type);
end if;
return True;
else
return False;
end if;
end Build_Equivalent_Aggregate;
------------------------- -------------------------
-- Rewrite_As_Renaming -- -- Rewrite_As_Renaming --
------------------------- -------------------------
...@@ -5033,6 +5169,14 @@ package body Exp_Ch3 is ...@@ -5033,6 +5169,14 @@ package body Exp_Ch3 is
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
return; return;
-- If type has discriminants, try to build equivalent
-- aggregate using discriminant values from the declaration.
-- This is a useful optimization, in particular if restriction
-- No_Elaboration_Code is active.
elsif Build_Equivalent_Aggregate then
return;
else else
Initialization_Warning (Id_Ref); Initialization_Warning (Id_Ref);
......
gcc/ada/prj-attr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -365,7 +365,6 @@ package body Prj.Attr is ...@@ -365,7 +365,6 @@ package body Prj.Attr is
-- package Remote -- package Remote
"Premote#" & "Premote#" &
"LVbuild_slaves#" &
"SVroot_dir#" & "SVroot_dir#" &
-- package Stack -- package Stack
......
gcc/ada/prj-makr.adb
...@@ -1271,6 +1271,15 @@ package body Prj.Makr is ...@@ -1271,6 +1271,15 @@ package body Prj.Makr is
new String'(Get_Name_String (Tmp_File)); new String'(Get_Name_String (Tmp_File));
end if; end if;
-- On VMS, a file created with Create_Temp_File cannot
-- be used to redirect output.
if Hostparm.OpenVMS then
Close (FD);
Delete_File (Temp_File_Name.all, Success);
FD := Create_Output_Text_File (Temp_File_Name.all);
end if;
Args (Args'Last) := new String' Args (Args'Last) := new String'
(Dir_Name & (Dir_Name &
Directory_Separator & Directory_Separator &
......
gcc/ada/projects.texi
...@@ -1101,31 +1101,6 @@ The following attributes can be defined in package @code{Remote}: ...@@ -1101,31 +1101,6 @@ The following attributes can be defined in package @code{Remote}:
@table @asis @table @asis
@item @b{Build_Slaves}
@cindex @code{Build_Slaves}
A list of string referencing the remote build slaves to use for the
compilation phase. The format is:
@code{[protocol://]name.domain[:port]}.
Where @code{protocol} is one of:
@table @asis
@item rsync
@cindex @code{rsync}
The sources are copied using the external @code{rsync} tool.
@item file
The sources are accessed via a shared directory or mount point.
@end table
The default port used to communicate with @command{gprslave} is
@code{8484}.
@item @b{Root_Dir}: @item @b{Root_Dir}:
@cindex @code{Root_Dir} @cindex @code{Root_Dir}
......
gcc/ada/snames.ads-tmpl
...@@ -1205,7 +1205,6 @@ package Snames is ...@@ -1205,7 +1205,6 @@ package Snames is
Name_Archive_Suffix : constant Name_Id := N + $; Name_Archive_Suffix : constant Name_Id := N + $;
Name_Binder : constant Name_Id := N + $; Name_Binder : constant Name_Id := N + $;
Name_Body_Suffix : constant Name_Id := N + $; Name_Body_Suffix : constant Name_Id := N + $;
Name_Build_Slaves : constant Name_Id := N + $;
Name_Builder : constant Name_Id := N + $; Name_Builder : constant Name_Id := N + $;
Name_Clean : constant Name_Id := N + $; Name_Clean : constant Name_Id := N + $;
Name_Compiler : constant Name_Id := N + $; Name_Compiler : constant Name_Id := N + $;
......
gcc/ada/urealp.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -46,7 +46,7 @@ package Urealp is ...@@ -46,7 +46,7 @@ package Urealp is
-- use the UR_Eq function). -- use the UR_Eq function).
-- A Ureal value represents an arbitrary precision universal real value, -- A Ureal value represents an arbitrary precision universal real value,
-- stored internally using four components -- stored internally using four components:
-- the numerator (Uint, always non-negative) -- the numerator (Uint, always non-negative)
-- the denominator (Uint, always non-zero, always positive if base = 0) -- the denominator (Uint, always non-zero, always positive if base = 0)
...@@ -125,7 +125,7 @@ package Urealp is ...@@ -125,7 +125,7 @@ package Urealp is
-- Returns value 10.0 ** 36 -- Returns value 10.0 ** 36
function Ureal_M_10_36 return Ureal; function Ureal_M_10_36 return Ureal;
-- Returns value -(10.0 -- Returns value -10.0 ** 36
----------------- -----------------
-- Subprograms -- -- Subprograms --
......
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