URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rbtgso.adb] - Rev 724
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ----------------------- -- Local Subprograms -- ----------------------- procedure Clear (Tree : in out Tree_Type); function Copy (Source : Tree_Type) return Tree_Type; ----------- -- Clear -- ----------- procedure Clear (Tree : in out Tree_Type) is pragma Assert (Tree.Busy = 0); pragma Assert (Tree.Lock = 0); Root : Node_Access := Tree.Root; pragma Warnings (Off, Root); begin Tree.Root := null; Tree.First := null; Tree.Last := null; Tree.Length := 0; Delete_Tree (Root); end Clear; ---------- -- Copy -- ---------- function Copy (Source : Tree_Type) return Tree_Type is Target : Tree_Type; begin if Source.Length = 0 then return Target; end if; Target.Root := Copy_Tree (Source.Root); Target.First := Tree_Operations.Min (Target.Root); Target.Last := Tree_Operations.Max (Target.Root); Target.Length := Source.Length; return Target; end Copy; ---------------- -- Difference -- ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is Tgt : Node_Access := Target.First; Src : Node_Access := Source.First; begin if Target'Address = Source'Address then if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; Clear (Target); return; end if; if Source.Length = 0 then return; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; loop if Tgt = null then return; end if; if Src = null then return; end if; if Is_Less (Tgt, Src) then Tgt := Tree_Operations.Next (Tgt); elsif Is_Less (Src, Tgt) then Src := Tree_Operations.Next (Src); else declare X : Node_Access := Tgt; begin Tgt := Tree_Operations.Next (Tgt); Tree_Operations.Delete_Node_Sans_Free (Target, X); Free (X); end; Src := Tree_Operations.Next (Src); end if; end loop; 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 end if; if Left.Length = 0 then return Tree; -- Empty set end if; if Right.Length = 0 then return Copy (Left); end if; loop if L_Node = null then return Tree; 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; return Tree; end if; 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); L_Node := Tree_Operations.Next (L_Node); elsif Is_Less (R_Node, L_Node) then 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; end Difference; ------------------ -- Intersection -- ------------------ procedure Intersection (Target : in out Tree_Type; Source : Tree_Type) is Tgt : Node_Access := Target.First; Src : Node_Access := Source.First; begin if Target'Address = Source'Address then return; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; if Source.Length = 0 then Clear (Target); return; end if; while Tgt /= null and then Src /= null loop if Is_Less (Tgt, Src) then declare X : Node_Access := Tgt; begin Tgt := Tree_Operations.Next (Tgt); Tree_Operations.Delete_Node_Sans_Free (Target, X); Free (X); end; elsif Is_Less (Src, Tgt) then Src := Tree_Operations.Next (Src); else Tgt := Tree_Operations.Next (Tgt); Src := Tree_Operations.Next (Src); end if; end loop; while Tgt /= null loop declare X : Node_Access := Tgt; begin Tgt := Tree_Operations.Next (Tgt); Tree_Operations.Delete_Node_Sans_Free (Target, X); Free (X); end; end loop; 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; if R_Node = null then return Tree; 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; exception when others => Delete_Tree (Tree.Root); raise; end Intersection; --------------- -- Is_Subset -- --------------- function Is_Subset (Subset : Tree_Type; Of_Set : Tree_Type) return Boolean is begin if Subset'Address = Of_Set'Address then return True; end if; if Subset.Length > Of_Set.Length then return False; end if; declare Subset_Node : Node_Access := Subset.First; Set_Node : Node_Access := Of_Set.First; begin loop if Set_Node = null then return Subset_Node = null; end if; if Subset_Node = null then return True; end if; if Is_Less (Subset_Node, Set_Node) then return False; end if; if Is_Less (Set_Node, Subset_Node) then Set_Node := Tree_Operations.Next (Set_Node); else Set_Node := Tree_Operations.Next (Set_Node); Subset_Node := Tree_Operations.Next (Subset_Node); end if; end loop; end; end Is_Subset; ------------- -- Overlap -- ------------- 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; 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 return True; end if; end loop; end Overlap; -------------------------- -- Symmetric_Difference -- -------------------------- procedure Symmetric_Difference (Target : in out Tree_Type; Source : Tree_Type) is Tgt : Node_Access := Target.First; Src : Node_Access := Source.First; 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; if Target'Address = Source'Address then Clear (Target); return; end if; loop if Tgt = null then while Src /= null loop Insert_With_Hint (Dst_Tree => Target, Dst_Hint => null, Src_Node => Src, Dst_Node => New_Tgt_Node); Src := Tree_Operations.Next (Src); end loop; return; end if; if Src = null then return; end if; if Is_Less (Tgt, Src) then Tgt := Tree_Operations.Next (Tgt); elsif Is_Less (Src, Tgt) then Insert_With_Hint (Dst_Tree => Target, Dst_Hint => Tgt, Src_Node => Src, Dst_Node => New_Tgt_Node); Src := Tree_Operations.Next (Src); else declare X : Node_Access := Tgt; begin Tgt := Tree_Operations.Next (Tgt); Tree_Operations.Delete_Node_Sans_Free (Target, X); Free (X); end; Src := Tree_Operations.Next (Src); end if; end loop; 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 end if; if Right.Length = 0 then return Copy (Left); end if; if Left.Length = 0 then return Copy (Right); end if; 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; return Tree; 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; return Tree; end if; 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); L_Node := Tree_Operations.Next (L_Node); 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); 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; end Symmetric_Difference; ----------- -- Union -- ----------- procedure Union (Target : in out Tree_Type; Source : Tree_Type) is Hint : Node_Access; procedure Process (Node : Node_Access); pragma Inline (Process); procedure Iterate is new Tree_Operations.Generic_Iteration (Process); ------------- -- Process -- ------------- procedure Process (Node : Node_Access) is begin Insert_With_Hint (Dst_Tree => Target, Dst_Hint => Hint, Src_Node => Node, Dst_Node => Hint); end Process; -- Start of processing for Union begin if Target'Address = Source'Address then return; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; Iterate (Source); end Union; function Union (Left, Right : Tree_Type) return Tree_Type is begin if Left'Address = Right'Address then return Copy (Left); end if; if Left.Length = 0 then return Copy (Right); end if; if Right.Length = 0 then return Copy (Left); end if; declare Tree : Tree_Type := Copy (Left); Hint : Node_Access; procedure Process (Node : Node_Access); pragma Inline (Process); procedure Iterate is new Tree_Operations.Generic_Iteration (Process); ------------- -- Process -- ------------- procedure Process (Node : Node_Access) is begin Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => Hint, Src_Node => Node, Dst_Node => Hint); end Process; -- Start of processing for Union begin Iterate (Right); return Tree; exception when others => Delete_Tree (Tree.Root); raise; end; end Union; end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
Go to most recent revision | Compare with Previous | Blame | View Log