===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -38,10 +38,19 @@
-- 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
@@ -52,18 +61,37 @@
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
@@ -75,25 +103,44 @@
end loop;
if Y = null then
- return null;
- end if;
+ Result := null;
- if Is_Less_Key_Node (Key, Y) then
- return null;
+ elsif Is_Less_Key_Node (Key, Y) then
+ Result := 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
@@ -104,7 +151,15 @@
end if;
end loop;
+ B := B - 1;
+ L := L - 1;
+
return Y;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
end Floor;
--------------------------------
@@ -117,9 +172,17 @@
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
-- can "fail" in the sense that no new node is created. If the Key is
@@ -136,13 +199,28 @@
-- 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
-- Either Tree is empty, or Key is less than Y. If Y is the first
@@ -172,8 +250,23 @@
-- 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
-- insert a new node into the tree.
@@ -201,6 +294,15 @@
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
@@ -215,9 +317,23 @@
-- 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
@@ -246,29 +362,59 @@
-- 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;
+
+ if Compare then
+ Test := Ops.Previous (Position); -- "before"
+
+ if Test = null then -- new first node
+ Insert_Post (Tree, Tree.First, True, Node);
+
+ Inserted := True;
+ return;
+ end if;
+
begin
- if Before = null then
- Insert_Post (Tree, Tree.First, True, Node);
- Inserted := True;
+ B := B + 1;
+ L := L + 1;
- 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;
+ Compare := Is_Greater_Key_Node (Key, Test);
- Inserted := True;
+ 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;
@@ -278,29 +424,59 @@
-- 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;
+
+ if Compare then
+ Test := Ops.Next (Position); -- "after"
+
+ if Test = null then -- new last node
+ Insert_Post (Tree, Tree.Last, False, Node);
+
+ Inserted := True;
+ return;
+ end if;
+
begin
- if After = null then
- Insert_Post (Tree, Tree.Last, False, Node);
- Inserted := True;
+ B := B + 1;
+ L := L + 1;
- 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;
+ Compare := Is_Less_Key_Node (Key, Test);
- Inserted := True;
+ 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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -1088,12 +1088,15 @@
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;
@@ -1104,7 +1107,7 @@
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
@@ -1884,16 +1887,54 @@
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.
- else
+ -- 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.
+
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (set is locked)";
@@ -1914,12 +1955,62 @@
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;
- elsif Item < Hint.Element.all then
+ 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.
+
if Hint = Node then
if Tree.Lock > 0 then
raise Program_Error with
@@ -1940,12 +2031,15 @@
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -626,9 +626,17 @@
-------------------
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;
@@ -638,18 +646,44 @@
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;
-----------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -987,12 +987,15 @@
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;
@@ -1003,7 +1006,7 @@
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
@@ -1716,17 +1719,55 @@
return Node;
end New_Node;
- Hint : Node_Access;
- Result : Node_Access;
- Inserted : Boolean;
+ Hint : Node_Access;
+ Result : Node_Access;
+ Inserted : Boolean;
+ Compare : Boolean;
- -- 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 or else Node.Element < Item then
- null;
+ -- Replace_Element assigns value Item to the element designated by Node,
+ -- per certain semantic constraints.
- else
+ -- 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.
+
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (set is locked)";
@@ -1736,12 +1777,62 @@
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;
- elsif Item < Hint.Element then
+ 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.
+
if Hint = Node then
if Tree.Lock > 0 then
raise Program_Error with
@@ -1751,15 +1842,18 @@
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,
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -606,9 +606,17 @@
-------------------
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;
@@ -618,18 +626,43 @@
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;
-----------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -979,6 +979,9 @@
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;
@@ -987,12 +990,15 @@
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;
@@ -1003,7 +1009,7 @@
L := L - 1;
B := B - 1;
- if Equivalent_Keys (K, Key (E)) then
+ if Eq then
return;
end if;
end;
@@ -1727,16 +1733,52 @@
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.
- else
+ -- 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.
+
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (set is locked)";
@@ -1746,12 +1788,63 @@
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;
- elsif Item < Nodes (Hint).Element then
+ 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.
+
if Hint = Index then
if Container.Lock > 0 then
raise Program_Error with
@@ -1761,12 +1854,14 @@
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -84,9 +84,17 @@
----------------
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
if Target.Busy > 0 then
@@ -107,19 +115,55 @@
"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
@@ -137,34 +181,66 @@
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.
- if R_Node = null then
- while L_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
+ 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,
@@ -173,33 +249,33 @@
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;
------------------
@@ -210,9 +286,17 @@
(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;
@@ -228,10 +312,46 @@
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
@@ -240,7 +360,7 @@
Free (X);
end;
- elsif Is_Less (Src, Tgt) then
+ elsif Compare > 0 then
Src := Tree_Operations.Next (Src);
else
@@ -261,50 +381,83 @@
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);
- exception
- when others =>
- Delete_Tree (Tree.Root);
- raise;
+ 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);
+
+ 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;
---------------
@@ -324,22 +477,44 @@
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
@@ -349,6 +524,23 @@
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;
@@ -357,31 +549,72 @@
-------------
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;
--------------------------
@@ -392,23 +625,28 @@
(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);
+ Compare : Integer;
+
begin
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
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
@@ -428,10 +666,44 @@
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,
@@ -455,17 +727,9 @@
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
@@ -476,70 +740,110 @@
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);
+ R_Node := Tree_Operations.Next (R_Node);
+
+ else
L_Node := Tree_Operations.Next (L_Node);
- end loop;
+ R_Node := Tree_Operations.Next (R_Node);
+ end if;
+ end loop;
- return Tree;
- end if;
+ BL := BL - 1;
+ LL := LL - 1;
- 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);
+ BR := BR - 1;
+ LR := LR - 1;
- L_Node := Tree_Operations.Next (L_Node);
+ return Tree;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 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);
+ BR := BR - 1;
+ LR := LR - 1;
- R_Node := Tree_Operations.Next (R_Node);
-
- 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);
@@ -555,7 +859,7 @@
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;
@@ -567,12 +871,28 @@
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.
- Iterate (Source);
+ declare
+ BS : Natural renames Source'Unrestricted_Access.Busy;
+ LS : Natural renames Source'Unrestricted_Access.Lock;
+
+ begin
+ BS := BS + 1;
+ LS := LS + 1;
+
+ 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
@@ -590,6 +910,12 @@
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;
@@ -608,7 +934,7 @@
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;
@@ -616,15 +942,32 @@
-- Start of processing for Union
begin
+ BL := BL + 1;
+ LL := LL + 1;
+
+ BR := BR + 1;
+ LR := LR + 1;
+
Iterate (Right);
+
+ 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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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- --
@@ -53,11 +53,19 @@
----------------
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
@@ -82,17 +90,51 @@
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
@@ -111,12 +153,6 @@
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
@@ -131,15 +167,51 @@
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,
@@ -147,28 +219,31 @@
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;
@@ -180,9 +255,17 @@
(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;
@@ -203,7 +286,41 @@
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
@@ -213,7 +330,7 @@
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
@@ -235,46 +352,80 @@
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;
@@ -286,9 +437,6 @@
(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;
@@ -298,28 +446,75 @@
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;
-------------
@@ -327,33 +522,72 @@
-------------
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;
--------------------------
@@ -364,18 +598,21 @@
(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);
+ Compare : Integer;
+
begin
- if Target.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
if Target'Address = Source'Address then
Tree_Operations.Clear_Tree (Target);
return;
@@ -402,10 +639,44 @@
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,
@@ -432,12 +703,6 @@
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
@@ -452,60 +717,100 @@
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
+
+ -- 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;
+
+ 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,
- Src_Node => Right.Nodes (R_Node),
+ Src_Node => Left.Nodes (L_Node),
Dst_Node => Dst_Node);
- R_Node := Tree_Operations.Next (Right, R_Node);
- end loop;
+ L_Node := Tree_Operations.Next (Left, L_Node);
- return;
- end if;
-
- if R_Node = 0 then
- while L_Node /= 0 loop
+ elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
Insert_With_Hint
(Dst_Set => Result,
Dst_Hint => 0,
- Src_Node => Left.Nodes (L_Node),
+ Src_Node => Right.Nodes (R_Node),
Dst_Node => Dst_Node);
+ R_Node := Tree_Operations.Next (Right, R_Node);
+
+ else
L_Node := Tree_Operations.Next (Left, L_Node);
- end loop;
+ R_Node := Tree_Operations.Next (Right, R_Node);
+ end if;
+ end loop;
- return;
- end if;
+ BL := BL - 1;
+ LL := LL - 1;
- 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);
+ BR := BR - 1;
+ LR := LR - 1;
+ exception
+ when others =>
+ BL := BL - 1;
+ LL := LL - 1;
- L_Node := Tree_Operations.Next (Left, L_Node);
+ BR := BR - 1;
+ LR := LR - 1;
- 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);
-
- R_Node := Tree_Operations.Next (Right, R_Node);
-
- else
- L_Node := Tree_Operations.Next (Left, L_Node);
- R_Node := Tree_Operations.Next (Right, R_Node);
- end if;
- end loop;
+ raise;
+ end;
end return;
end Set_Symmetric_Difference;
@@ -541,17 +846,34 @@
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
@@ -569,35 +891,65 @@
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;
- Insert_Right : declare
- Hint : Count_Type := 0;
+ BR : Natural renames Right'Unrestricted_Access.Busy;
+ LR : Natural renames Right'Unrestricted_Access.Lock;
- procedure Process (Node : Count_Type);
- pragma Inline (Process);
+ begin
+ BL := BL + 1;
+ LL := LL + 1;
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
+ BR := BR + 1;
+ LR := LR + 1;
- -------------
- -- Process --
- -------------
+ Assign (Target => Result, Source => Left);
- procedure Process (Node : Count_Type) is
+ Insert_Right : declare
+ Hint : Count_Type := 0;
+
+ 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
+
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;