+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>
* make.adb (Compile): Clarify the error message reported
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
----------------
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;
TN : Nodes_Type renames Target.Nodes;
SN : Nodes_Type renames Source.Nodes;
+ Compare : Integer;
+
begin
if Target'Address = Source'Address then
if Target.Busy > 0 then
Src := Source.First;
loop
if Tgt = 0 then
- return;
+ exit;
end if;
if Src = 0 then
- return;
+ exit;
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);
- elsif Is_Less (SN (Src), TN (Tgt)) then
+ elsif Compare > 0 then
Src := Tree_Operations.Next (Source, Src);
else
end Set_Difference;
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
if Left'Address = Right'Address then
return S : Set_Type (0); -- Empty set
end if;
return Result : Set_Type (Left.Length) do
- L_Node := Left.First;
- R_Node := Right.First;
- loop
- if L_Node = 0 then
- return;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if R_Node = 0 then
- while L_Node /= 0 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;
+
+ 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
(Dst_Set => Result,
Dst_Hint => 0,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node);
- end loop;
- return;
- end if;
+ elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
+ R_Node := Tree_Operations.Next (Right, R_Node);
- if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
- Insert_With_Hint
- (Dst_Set => Result,
- Dst_Hint => 0,
- Src_Node => Left.Nodes (L_Node),
- Dst_Node => Dst_Node);
+ else
+ L_Node := Tree_Operations.Next (Left, L_Node);
+ R_Node := Tree_Operations.Next (Right, R_Node);
+ end if;
+ end loop;
- 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
- R_Node := Tree_Operations.Next (Right, R_Node);
+ BR := BR - 1;
+ LR := LR - 1;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 1;
- else
- L_Node := Tree_Operations.Next (Left, L_Node);
- R_Node := Tree_Operations.Next (Right, R_Node);
- end if;
- end loop;
+ BR := BR - 1;
+ LR := LR - 1;
+
+ raise;
+ end;
end return;
end 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 : Count_Type;
Src : Count_Type;
+ Compare : Integer;
+
begin
if Target'Address = Source'Address then
return;
while Tgt /= 0
and then Src /= 0
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
X : constant Count_Type := Tgt;
begin
Tree_Operations.Free (Target, X);
end;
- elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
+ elsif Compare > 0 then
Src := Tree_Operations.Next (Source, Src);
else
end Set_Intersection;
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
if Left'Address = Right'Address then
return Copy (Left);
end if;
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
- return;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
- L_Node := Tree_Operations.Next (Left, L_Node);
+ declare
+ 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
- R_Node := Tree_Operations.Next (Right, R_Node);
+ BR : Natural renames Right'Unrestricted_Access.Busy;
+ LR : Natural renames Right'Unrestricted_Access.Lock;
- else
- Insert_With_Hint
- (Dst_Set => Result,
- Dst_Hint => 0,
- Src_Node => Left.Nodes (L_Node),
- Dst_Node => Dst_Node);
+ L_Node : Count_Type;
+ R_Node : Count_Type;
- L_Node := Tree_Operations.Next (Left, L_Node);
- R_Node := Tree_Operations.Next (Right, R_Node);
- end if;
- end loop;
+ 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
+ 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 Set_Intersection;
(Subset : Set_Type;
Of_Set : Set_Type) return Boolean
is
- Subset_Node : Count_Type;
- Set_Node : Count_Type;
-
begin
if Subset'Address = Of_Set'Address then
return True;
return False;
end if;
- Subset_Node := Subset.First;
- Set_Node := Of_Set.First;
- loop
- if Set_Node = 0 then
- return Subset_Node = 0;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if Subset_Node = 0 then
- return True;
- end if;
+ declare
+ BL : Natural renames Subset'Unrestricted_Access.Busy;
+ LL : Natural renames Subset'Unrestricted_Access.Lock;
- if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then
- return False;
- end if;
+ BR : Natural renames Of_Set'Unrestricted_Access.Busy;
+ LR : Natural renames Of_Set'Unrestricted_Access.Lock;
- 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;
+ Subset_Node : Count_Type;
+ Set_Node : Count_Type;
+
+ Result : Boolean;
+
+ begin
+ 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;
-------------
-------------
function Set_Overlap (Left, Right : Set_Type) return Boolean is
- L_Node : Count_Type;
- R_Node : Count_Type;
-
begin
if Left'Address = Right'Address then
return Left.Length /= 0;
end if;
- L_Node := Left.First;
- R_Node := Right.First;
- loop
- if L_Node = 0
- or else R_Node = 0
- then
- return False;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
- L_Node := Tree_Operations.Next (Left, L_Node);
+ declare
+ 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
- R_Node := Tree_Operations.Next (Right, R_Node);
+ BR : Natural renames Right'Unrestricted_Access.Busy;
+ LR : Natural renames Right'Unrestricted_Access.Lock;
- else
- return True;
- end if;
- end loop;
+ L_Node : Count_Type;
+ R_Node : Count_Type;
+
+ 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;
--------------------------
(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 : Count_Type;
Src : Count_Type;
New_Tgt_Node : Count_Type;
pragma Warnings (Off, New_Tgt_Node);
- begin
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ Compare : Integer;
+ begin
if Target'Address = Source'Address then
Tree_Operations.Clear_Tree (Target);
return;
return;
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);
- elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
+ elsif Compare > 0 then
Insert_With_Hint
(Dst_Set => Target,
Dst_Hint => Tgt,
function Set_Symmetric_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
if Left'Address = Right'Address then
return S : Set_Type (0); -- Empty set
end if;
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);
- end loop;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- return;
- end if;
+ declare
+ BL : Natural renames Left'Unrestricted_Access.Busy;
+ LL : Natural renames Left'Unrestricted_Access.Lock;
- if R_Node = 0 then
- while L_Node /= 0 loop
+ 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
+ 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
(Dst_Set => Result,
Dst_Hint => 0,
Dst_Node => Dst_Node);
L_Node := Tree_Operations.Next (Left, L_Node);
- end loop;
- return;
- end if;
+ elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
+ 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
- Insert_With_Hint
- (Dst_Set => Result,
- Dst_Hint => 0,
- Src_Node => Left.Nodes (L_Node),
- Dst_Node => Dst_Node);
+ R_Node := Tree_Operations.Next (Right, R_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
- Insert_With_Hint
- (Dst_Set => Result,
- Dst_Hint => 0,
- Src_Node => Right.Nodes (R_Node),
- Dst_Node => Dst_Node);
+ BL := BL - 1;
+ LL := LL - 1;
- R_Node := Tree_Operations.Next (Right, R_Node);
+ BR := BR - 1;
+ LR := LR - 1;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 1;
- else
- L_Node := Tree_Operations.Next (Left, L_Node);
- R_Node := Tree_Operations.Next (Right, R_Node);
- end if;
- end loop;
+ BR := BR - 1;
+ LR := LR - 1;
+
+ raise;
+ end;
end return;
end Set_Symmetric_Difference;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- -- 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.
+ declare
+ BS : Natural renames Source'Unrestricted_Access.Busy;
+ LS : Natural renames Source'Unrestricted_Access.Lock;
- 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;
function Set_Union (Left, Right : Set_Type) return Set_Type is
end if;
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
- Hint : Count_Type := 0;
+ BR := BR + 1;
+ LR := LR + 1;
- procedure Process (Node : Count_Type);
- pragma Inline (Process);
+ Assign (Target => Result, Source => Left);
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
+ Insert_Right : declare
+ Hint : Count_Type := 0;
- -------------
- -- Process --
- -------------
+ procedure Process (Node : Count_Type);
+ 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
- Insert_With_Hint
- (Dst_Set => Result,
- Dst_Hint => Hint,
- Src_Node => Right.Nodes (Node),
- Dst_Node => Hint);
- end Process;
+ Iterate (Right);
+ end Insert_Right;
- -- Start of processing for Insert_Right
+ BL := BL - 1;
+ LL := LL - 1;
- begin
- Iterate (Right);
- end Insert_Right;
+ 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 Set_Union;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
pragma Assert (Vet (Container, Position.Node),
"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
N : Node_Type renames Container.Nodes (Position.Node);
E : Element_Type renames N.Element;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
+ Eq : Boolean;
+
begin
B := B + 1;
L := L + 1;
begin
Process (E);
+ Eq := Equivalent_Keys (K, Key (E));
exception
when others =>
L := L - 1;
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
Hint : Count_Type;
Result : Count_Type;
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
begin
- if Item < Node.Element
- or else Node.Element < Item
- then
- null;
+ -- Replace_Element assigns value Item to the element designated by Node,
+ -- 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 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
raise Program_Error with
"attempt to tamper with elements (set is locked)";
return;
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);
- if Hint = 0 then
- null;
+ if Hint /= 0 then -- Item <= Nodes (Hint).Element
+ 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 Container.Lock > 0 then
raise Program_Error with
Node.Element := Item;
return;
end if;
-
- else
- pragma Assert (not (Nodes (Hint).Element < Item));
- raise Program_Error with "attempt to replace existing element";
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);
Local_Insert_With_Hint
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
+ Eq : Boolean;
+
begin
B := B + 1;
L := L + 1;
begin
Process (E);
+ Eq := Equivalent_Keys (K, Key (E));
exception
when others =>
L := L - 1;
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
Hint : Node_Access;
Result : Node_Access;
Inserted : Boolean;
+ Compare : Boolean;
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
- if Item < Node.Element.all or else Node.Element.all < Item then
- null;
+ -- Replace_Element assigns value Item to the element designated by Node,
+ -- 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
raise Program_Error with
"attempt to tamper with elements (set is locked)";
return;
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);
- if Hint = null then
- null;
+ if Hint /= null then
+ 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 Tree.Lock > 0 then
raise Program_Error with
return;
end if;
-
- else
- pragma Assert (not (Hint.Element.all < Item));
- raise Program_Error with "attempt to replace existing element";
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
Local_Insert_With_Hint
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
+ Eq : Boolean;
+
begin
B := B + 1;
L := L + 1;
begin
Process (E);
+ Eq := Equivalent_Keys (K, Key (E));
exception
when others =>
L := L - 1;
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
return Node;
end New_Node;
- Hint : Node_Access;
- Result : Node_Access;
- Inserted : Boolean;
+ Hint : Node_Access;
+ Result : Node_Access;
+ 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
- if Item < Node.Element or else Node.Element < Item then
- null;
+ -- Replace_Element assigns value Item to the element designated by Node,
+ -- 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
raise Program_Error with
"attempt to tamper with elements (set is locked)";
return;
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);
- if Hint = null then
- null;
+ if Hint /= null then
+ 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 Tree.Lock > 0 then
raise Program_Error with
Node.Element := Item;
return;
end if;
-
- else
- pragma Assert (not (Hint.Element < Item));
- raise Program_Error with "attempt to replace existing element";
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
- Local_Insert_With_Hint
+ Local_Insert_With_Hint -- use unconditional insert here instead???
(Tree => Tree,
Position => Hint,
Key => Item,
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- AKA Lower_Bound
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;
X : Node_Access;
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;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
end if;
end loop;
+ B := B - 1;
+ L := L - 1;
+
return Y;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
end Ceiling;
----------
-- 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;
X : Node_Access;
+ Result : Node_Access;
+
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;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
end loop;
if Y = null then
- return null;
- end if;
+ Result := null;
+
+ elsif Is_Less_Key_Node (Key, Y) then
+ Result := null;
- if Is_Less_Key_Node (Key, Y) then
- return null;
+ else
+ Result := Y;
end if;
- return Y;
+ B := B - 1;
+ L := L - 1;
+
+ return Result;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
end Find;
-----------
-- 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;
X : Node_Access;
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;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
end if;
end loop;
+ B := B - 1;
+ L := L - 1;
+
return Y;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
end Floor;
--------------------------------
Node : out Node_Access;
Inserted : out Boolean)
is
- Y : Node_Access := null;
- X : Node_Access := Tree.Root;
+ X : Node_Access;
+ 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
-- This is a "conditional" insertion, meaning that the insertion request
-- either the smallest node greater than Key (Inserted is True), or the
-- largest node less or equivalent to Key (Inserted is False).
- 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;
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ X := Tree.Root;
+ 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
-- Key is equivalent to or greater than Node. We must resolve which is
-- 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
-- equivalent to Node. In this case, the insertion succeeds, and we
Node : out Node_Access;
Inserted : out Boolean)
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
-- 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
-- done; otherwise the hint was "wrong" and we must search.
if Position = null then -- largest
- if Tree.Last = null
- or else Is_Greater_Key_Node (Key, Tree.Last)
- then
+ begin
+ B := B + 1;
+ 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);
Inserted := True;
else
-- then its neighbor must be anterior and so we insert before the
-- hint.
- if Is_Less_Key_Node (Key, Position) then
- declare
- Before : constant Node_Access := Ops.Previous (Position);
+ begin
+ B := B + 1;
+ 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 Before = null then
- Insert_Post (Tree, Tree.First, True, Node);
- Inserted := True;
+ if Compare then
+ Test := Ops.Previous (Position); -- "before"
- elsif Is_Greater_Key_Node (Key, Before) then
- if Ops.Right (Before) = null then
- Insert_Post (Tree, Before, False, Node);
- else
- Insert_Post (Tree, Position, True, Node);
- end if;
+ if Test = null then -- new first node
+ Insert_Post (Tree, Tree.First, True, Node);
- 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
- Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ Insert_Post (Tree, Position, True, Node);
end if;
- end;
+
+ Inserted := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ end if;
return;
end if;
-- greater than the hint and less than the hint's next neighbor,
-- then we're done; otherwise we must search.
- if Is_Greater_Key_Node (Key, Position) then
- declare
- After : constant Node_Access := Ops.Next (Position);
+ begin
+ B := B + 1;
+ 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 After = null then
- Insert_Post (Tree, Tree.Last, False, Node);
- Inserted := True;
+ if Compare then
+ Test := Ops.Next (Position); -- "after"
- elsif Is_Less_Key_Node (Key, After) then
- if Ops.Right (Position) = null then
- Insert_Post (Tree, Position, False, Node);
- else
- Insert_Post (Tree, After, True, Node);
- end if;
+ if Test = null then -- new last node
+ Insert_Post (Tree, Tree.Last, False, Node);
- 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
- Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ Insert_Post (Tree, Test, True, Node);
end if;
- end;
+
+ Inserted := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ end if;
return;
end if;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-------------------
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;
R_Node : Node_Access;
+ Result : Boolean;
+
begin
if Left'Address = Right'Address then
return True;
return False;
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;
R_Node := Right.First;
+ Result := True;
while L_Node /= null loop
if not Is_Equal (L_Node, R_Node) then
- return False;
+ Result := False;
+ exit;
end if;
L_Node := Next (L_Node);
R_Node := Next (R_Node);
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;
-----------------------
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-------------------
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;
R_Node : Count_Type;
+ Result : Boolean;
+
begin
if Left'Address = Right'Address then
return True;
return False;
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;
R_Node := Right.First;
while L_Node /= 0 loop
if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
- return False;
+ Result := False;
+ exit;
end if;
L_Node := Next (Left, L_Node);
R_Node := Next (Right, R_Node);
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;
-----------------------
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
----------------
procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
- Tgt : Node_Access := Target.First;
- Src : Node_Access := Source.First;
+ 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 : Node_Access;
+ Src : Node_Access;
+
+ Compare : Integer;
begin
if Target'Address = Source'Address then
"attempt to tamper with cursors (container is busy)";
end if;
+ Tgt := Target.First;
+ Src := Source.First;
loop
if Tgt = null then
- return;
+ exit;
end if;
if Src = null then
- return;
+ exit;
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);
- elsif Is_Less (Src, Tgt) then
+ elsif Compare > 0 then
Src := Tree_Operations.Next (Src);
else
end Difference;
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
if Left'Address = Right'Address then
- return Tree; -- Empty set
+ return Tree_Type'(others => <>); -- Empty set
end if;
if Left.Length = 0 then
- return Tree; -- Empty set
+ return Tree_Type'(others => <>); -- Empty set
end if;
if Right.Length = 0 then
return Copy (Left);
end if;
- loop
- if L_Node = null then
- return Tree;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ 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
- while L_Node /= null loop
+ if Is_Less (L_Node, R_Node) then
Insert_With_Hint
(Dst_Tree => Tree,
Dst_Hint => null,
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;
- end if;
+ else
+ 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
- Insert_With_Hint
- (Dst_Tree => Tree,
- Dst_Hint => null,
- Src_Node => L_Node,
- Dst_Node => Dst_Node);
+ BL := BL - 1;
+ LL := LL - 1;
- L_Node := Tree_Operations.Next (L_Node);
+ BR := BR - 1;
+ LR := LR - 1;
- elsif Is_Less (R_Node, L_Node) then
- R_Node := Tree_Operations.Next (R_Node);
+ return Tree;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 1;
- else
- L_Node := Tree_Operations.Next (L_Node);
- R_Node := Tree_Operations.Next (R_Node);
- end if;
- end loop;
+ BR := BR - 1;
+ LR := LR - 1;
- exception
- when others =>
- Delete_Tree (Tree.Root);
- raise;
+ Delete_Tree (Tree.Root);
+ raise;
+ end;
end Difference;
------------------
(Target : in out Tree_Type;
Source : Tree_Type)
is
- Tgt : Node_Access := Target.First;
- Src : Node_Access := Source.First;
+ 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 : Node_Access;
+ Src : Node_Access;
+
+ Compare : Integer;
begin
if Target'Address = Source'Address then
return;
end if;
+ Tgt := Target.First;
+ Src := Source.First;
while Tgt /= null
and then Src /= null
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
X : Node_Access := Tgt;
begin
Free (X);
end;
- elsif Is_Less (Src, Tgt) then
+ elsif Compare > 0 then
Src := Tree_Operations.Next (Src);
else
end Intersection;
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
if Left'Address = Right'Address then
return Copy (Left);
end if;
- loop
- if L_Node = null then
- return Tree;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if R_Node = null then
- return Tree;
- end if;
+ declare
+ BL : Natural renames Left'Unrestricted_Access.Busy;
+ LL : Natural renames Left'Unrestricted_Access.Lock;
- if Is_Less (L_Node, R_Node) then
- L_Node := Tree_Operations.Next (L_Node);
+ BR : Natural renames Right'Unrestricted_Access.Busy;
+ LR : Natural renames Right'Unrestricted_Access.Lock;
- elsif Is_Less (R_Node, L_Node) then
- R_Node := Tree_Operations.Next (R_Node);
+ Tree : Tree_Type;
- else
- Insert_With_Hint
- (Dst_Tree => Tree,
- Dst_Hint => null,
- Src_Node => L_Node,
- Dst_Node => Dst_Node);
+ L_Node : Node_Access;
+ R_Node : Node_Access;
- L_Node := Tree_Operations.Next (L_Node);
- R_Node := Tree_Operations.Next (R_Node);
- end if;
- end loop;
+ 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
+ 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
- when others =>
- Delete_Tree (Tree.Root);
- raise;
+ else
+ Insert_With_Hint
+ (Dst_Tree => Tree,
+ 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;
---------------
return False;
end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
declare
- Subset_Node : Node_Access := Subset.First;
- Set_Node : Node_Access := Of_Set.First;
+ BL : Natural renames Subset'Unrestricted_Access.Busy;
+ 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
+ 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 = null then
- return Subset_Node = null;
+ Result := Subset_Node = null;
+ exit;
end if;
if Subset_Node = null then
- return True;
+ Result := True;
+ exit;
end if;
if Is_Less (Subset_Node, Set_Node) then
- return False;
+ Result := False;
+ exit;
end if;
if Is_Less (Set_Node, Subset_Node) then
Subset_Node := Tree_Operations.Next (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 Is_Subset;
-------------
function Overlap (Left, Right : Tree_Type) return Boolean is
- L_Node : Node_Access := Left.First;
- R_Node : Node_Access := Right.First;
-
begin
if Left'Address = Right'Address then
return Left.Length /= 0;
end if;
- loop
- if L_Node = null
- or else R_Node = null
- then
- return False;
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- if Is_Less (L_Node, R_Node) then
- L_Node := Tree_Operations.Next (L_Node);
+ declare
+ BL : Natural renames Left'Unrestricted_Access.Busy;
+ LL : Natural renames Left'Unrestricted_Access.Lock;
- elsif Is_Less (R_Node, L_Node) then
- R_Node := Tree_Operations.Next (R_Node);
+ BR : Natural renames Right'Unrestricted_Access.Busy;
+ LR : Natural renames Right'Unrestricted_Access.Lock;
- else
- return True;
- end if;
- end loop;
+ L_Node : Node_Access;
+ R_Node : Node_Access;
+
+ 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;
--------------------------
(Target : in out Tree_Type;
Source : Tree_Type)
is
- Tgt : Node_Access := Target.First;
- Src : Node_Access := Source.First;
+ 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 : Node_Access;
+ Src : Node_Access;
New_Tgt_Node : Node_Access;
pragma Warnings (Off, New_Tgt_Node);
- begin
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ Compare : Integer;
+ begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
+ Tgt := Target.First;
+ Src := Source.First;
loop
if Tgt = null then
while Src /= null loop
return;
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);
- elsif Is_Less (Src, Tgt) then
+ elsif Compare > 0 then
Insert_With_Hint
(Dst_Tree => Target,
Dst_Hint => Tgt,
end Symmetric_Difference;
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
if Left'Address = Right'Address then
- return Tree; -- Empty set
+ return Tree_Type'(others => <>); -- Empty set
end if;
if Right.Length = 0 then
return Copy (Right);
end if;
- loop
- if L_Node = null then
- while R_Node /= null loop
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ 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
(Dst_Tree => Tree,
Dst_Hint => null,
- Src_Node => R_Node,
+ Src_Node => L_Node,
Dst_Node => Dst_Node);
- R_Node := Tree_Operations.Next (R_Node);
- end loop;
- return Tree;
- end if;
+ L_Node := Tree_Operations.Next (L_Node);
- if R_Node = null then
- while L_Node /= null loop
+ elsif Is_Less (R_Node, L_Node) then
Insert_With_Hint
(Dst_Tree => Tree,
Dst_Hint => null,
- Src_Node => L_Node,
+ Src_Node => R_Node,
Dst_Node => Dst_Node);
- L_Node := Tree_Operations.Next (L_Node);
- end loop;
+ R_Node := Tree_Operations.Next (R_Node);
- return Tree;
- end if;
+ else
+ 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
- Insert_With_Hint
- (Dst_Tree => Tree,
- Dst_Hint => null,
- Src_Node => L_Node,
- Dst_Node => Dst_Node);
+ BL := BL - 1;
+ LL := LL - 1;
- L_Node := Tree_Operations.Next (L_Node);
+ BR := BR - 1;
+ LR := LR - 1;
- elsif Is_Less (R_Node, L_Node) then
- Insert_With_Hint
- (Dst_Tree => Tree,
- Dst_Hint => null,
- Src_Node => R_Node,
- Dst_Node => Dst_Node);
+ return Tree;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 1;
- R_Node := Tree_Operations.Next (R_Node);
+ BR := BR - 1;
+ LR := LR - 1;
- else
- L_Node := Tree_Operations.Next (L_Node);
- R_Node := Tree_Operations.Next (R_Node);
- end if;
- end loop;
-
- exception
- when others =>
- Delete_Tree (Tree.Root);
- raise;
+ Delete_Tree (Tree.Root);
+ raise;
+ end;
end Symmetric_Difference;
-----------
-- Union --
-----------
- procedure Union (Target : in out Tree_Type; Source : Tree_Type)
- is
+ procedure Union (Target : in out Tree_Type; Source : Tree_Type) is
Hint : Node_Access;
procedure Process (Node : Node_Access);
begin
Insert_With_Hint
(Dst_Tree => Target,
- Dst_Hint => Hint,
+ Dst_Hint => Hint, -- use node most recently inserted as hint
Src_Node => Node,
Dst_Node => Hint);
end Process;
return;
end if;
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ 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;
function Union (Left, Right : Tree_Type) return Tree_Type is
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 := Copy (Left);
Hint : Node_Access;
begin
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Hint,
+ Dst_Hint => Hint, -- use node most recently inserted as hint
Src_Node => Node,
Dst_Node => Hint);
end Process;
-- Start of processing for Union
begin
+ BL := BL + 1;
+ LL := LL + 1;
+
+ BR := BR + 1;
+ LR := LR + 1;
+
Iterate (Right);
- return Tree;
+ 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 Union;
end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
* *
* 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 *
* terms of the GNU General Public License as published by the Free Soft- *
#include "adaint.h"
+/* We need L_tmpnam definition */
+#include <stdio.h>
+
#ifdef __cplusplus
extern "C" {
#endif
char *
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);
+#endif
}
#endif
-- d.N Add node to all entities
-- d.O Dump internal SCO tables
-- 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.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time)
-- This is there in case we find a situation where the optimization
-- 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
-- have two forms, positional and named. The named notation is the
-- current preferred form, but the use of this debug switch will force
-- which case the init proc call must be inserted only after the bodies
-- 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;
-- Indicate whether to rewrite a declaration with initialization into an
-- 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 --
-------------------------
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
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
Initialization_Warning (Id_Ref);
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- package Remote
"Premote#" &
- "LVbuild_slaves#" &
"SVroot_dir#" &
-- package Stack
new String'(Get_Name_String (Tmp_File));
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'
(Dir_Name &
Directory_Separator &
@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}:
@cindex @code{Root_Dir}
Name_Archive_Suffix : constant Name_Id := N + $;
Name_Binder : 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_Clean : constant Name_Id := N + $;
Name_Compiler : constant Name_Id := N + $;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- use the UR_Eq function).
-- 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 denominator (Uint, always non-zero, always positive if base = 0)
-- Returns value 10.0 ** 36
function Ureal_M_10_36 return Ureal;
- -- Returns value -(10.0
+ -- Returns value -10.0 ** 36
-----------------
-- Subprograms --
projects / thirdparty / gcc.git / commitdiff
