diff options
Diffstat (limited to 'gcc/ada/a-rbtgso.adb')
| -rw-r--r-- | gcc/ada/a-rbtgso.adb | 691 |
1 files changed, 522 insertions, 169 deletions
diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 2b9b5402435..06a78e922c3 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -84,8 +84,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - 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 @@ -107,19 +115,56 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is "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 +182,66 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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; - if R_Node = null then - while L_Node /= null loop + 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 +250,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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; - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + exception + when others => + BL := BL - 1; + LL := LL - 1; - exception - when others => - Delete_Tree (Tree.Root); - raise; + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; end Difference; ------------------ @@ -210,8 +288,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (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 @@ -228,10 +314,47 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +363,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Free (X); end; - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Src := Tree_Operations.Next (Src); else @@ -261,50 +384,84 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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; - exception - when others => - Delete_Tree (Tree.Root); - raise; + 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 +481,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +528,24 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +554,73 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ------------- 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 +631,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (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 @@ -428,10 +672,45 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +734,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +747,111 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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; - R_Node := Tree_Operations.Next (R_Node); + 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 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 +867,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +879,29 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 @@ -590,6 +919,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations 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; @@ -608,7 +943,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is 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 +951,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- 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; |