+2010-10-25 Pascal Obry <obry@adacore.com>
+
+ * adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get
+ the timestamp. A bit faster than opening/closing the file.
+ (__gnat_stat_to_attr): Remove kludge for Windows.
+ (__gnat_file_exists_attr): Likewise.
+ The timestamp is now retreived using GetFileAttributesEx as faster.
+
+2010-10-25 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Derive_Interface_Subprogram): New subprogram.
+ (Derive_Subprograms): For abstract private types transfer to the full
+ view entities of uncovered interface primitives. Required because if
+ the interface primitives are left in the private part of the package
+ they will be decorated as hidden when the analysis of the enclosing
+ package completes (and hence the interface primitive is not visible
+ for dispatching calls).
+
+2010-10-25 Matthew Heaney <heaney@adacore.com>
+
+ * Makefile.rtl, impunit.adb: Added bounded set and bounded map
+ containers.
+ * a-crbltr.ads: Added declaration of generic package for bounded tree
+ types.
+ * a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads,
+ a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb:
+ New.
+
+2010-10-25 Thomas Quinot <quinot@adacore.com>
+
+ * sem_util.adb: Minor reformatting.
+ * usage.adb: Fix usage line for -gnatwh.
+
+2010-10-25 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch12.adb (Analyze_Package_Instantiation): For an
+ instantiation in an RCI spec, omit package body if instantiation comes
+ from source, even as a nested
+ package.
+ * exp_dist.adb (Add_Calling_Stubs_To_Declarations,
+ *_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of
+ nested packages, package instantiations and subprogram instantiations.
+
2010-10-25 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through
# Objects needed for non-tasking.
GNATRTL_NONTASKING_OBJS= \
a-assert$(objext) \
+ a-btgbso$(objext) \
a-calari$(objext) \
a-calcon$(objext) \
a-caldel$(objext) \
a-calend$(objext) \
a-calfor$(objext) \
a-catizo$(objext) \
+ a-cborse$(objext) \
+ a-cborma$(objext) \
a-cdlili$(objext) \
a-cgaaso$(objext) \
a-cgarso$(objext) \
a-nuflra$(objext) \
a-numaux$(objext) \
a-numeri$(objext) \
+ a-rbtgbo$(objext) \
+ a-rbtgbk$(objext) \
a-rbtgso$(objext) \
a-scteio$(objext) \
a-secain$(objext) \
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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_Bounded_Set_Operations is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Copy (Source : Set_Type) return Set_Type;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Set_Type) return Set_Type is
+ begin
+ return Target : Set_Type (Source.Length) do
+ Assign (Target => Target, Source => Source);
+ end return;
+ end Copy;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is
+ Tgt, Src : Count_Type;
+
+ TN : Nodes_Type renames Target.Nodes;
+ SN : Nodes_Type renames Source.Nodes;
+
+ 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;
+
+ Tree_Operations.Clear_Tree (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;
+
+ Tgt := Target.First;
+ Src := Source.First;
+ loop
+ if Tgt = 0 then
+ return;
+ end if;
+
+ if Src = 0 then
+ return;
+ end if;
+
+ if Is_Less (TN (Tgt), SN (Src)) then
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ elsif Is_Less (SN (Src), TN (Tgt)) then
+ Src := Tree_Operations.Next (Source, Src);
+
+ else
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Tree_Operations.Free (Target, X);
+ end;
+
+ Src := Tree_Operations.Next (Source, Src);
+ end if;
+ end loop;
+ end Set_Difference;
+
+ function Set_Difference (Left, Right : Set_Type) return Set_Type is
+ L_Node : Count_Type;
+ R_Node : Count_Type;
+
+ Dst_Node : Count_Type;
+ pragma Warnings (Off, Dst_Node);
+
+ begin
+ if Left'Address = Right'Address then
+ return S : Set_Type (0); -- Empty set
+ end if;
+
+ if Left.Length = 0 then
+ return S : Set_Type (0); -- Empty set
+ end if;
+
+ if Right.Length = 0 then
+ return Copy (Left);
+ 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;
+
+ 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;
+
+ return;
+ 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 => Left.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ 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
+ L_Node := Tree_Operations.Next (Left, L_Node);
+ R_Node := Tree_Operations.Next (Right, R_Node);
+ end if;
+ end loop;
+ end return;
+ end Set_Difference;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Set_Intersection
+ (Target : in out Set_Type;
+ Source : Set_Type)
+ is
+ Tgt : Count_Type;
+ Src : Count_Type;
+
+ 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
+ Tree_Operations.Clear_Tree (Target);
+ return;
+ end if;
+
+ Tgt := Target.First;
+ Src := Source.First;
+ while Tgt /= 0
+ and then Src /= 0
+ loop
+ if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Tree_Operations.Free (Target, X);
+ end;
+
+ elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
+ Src := Tree_Operations.Next (Source, Src);
+
+ else
+ Tgt := Tree_Operations.Next (Target, Tgt);
+ Src := Tree_Operations.Next (Source, Src);
+ end if;
+ end loop;
+
+ while Tgt /= 0 loop
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Tree_Operations.Free (Target, X);
+ end;
+ end loop;
+ 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;
+
+ 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;
+ end return;
+ end Set_Intersection;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Set_Subset
+ (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;
+ end if;
+
+ if Subset.Length > Of_Set.Length then
+ 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;
+
+ if Subset_Node = 0 then
+ return True;
+ end if;
+
+ if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then
+ return False;
+ 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;
+ end Set_Subset;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ 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;
+
+ 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
+ return True;
+ end if;
+ end loop;
+ end Set_Overlap;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Set_Symmetric_Difference
+ (Target : in out Set_Type;
+ Source : Set_Type)
+ is
+ Tgt : Count_Type;
+ Src : Count_Type;
+
+ New_Tgt_Node : Count_Type;
+ pragma Warnings (Off, New_Tgt_Node);
+
+ begin
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ if Target'Address = Source'Address then
+ Tree_Operations.Clear_Tree (Target);
+ return;
+ end if;
+
+ Tgt := Target.First;
+ Src := Source.First;
+ loop
+ if Tgt = 0 then
+ while Src /= 0 loop
+ Insert_With_Hint
+ (Dst_Set => Target,
+ Dst_Hint => 0,
+ Src_Node => Source.Nodes (Src),
+ Dst_Node => New_Tgt_Node);
+
+ Src := Tree_Operations.Next (Source, Src);
+ end loop;
+
+ return;
+ end if;
+
+ if Src = 0 then
+ return;
+ end if;
+
+ if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
+ Insert_With_Hint
+ (Dst_Set => Target,
+ Dst_Hint => Tgt,
+ Src_Node => Source.Nodes (Src),
+ Dst_Node => New_Tgt_Node);
+
+ Src := Tree_Operations.Next (Source, Src);
+
+ else
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Target, Tgt);
+
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Tree_Operations.Free (Target, X);
+ end;
+
+ Src := Tree_Operations.Next (Source, Src);
+ end if;
+ end loop;
+ end Set_Symmetric_Difference;
+
+ function Set_Symmetric_Difference
+ (Left, Right : Set_Type) return Set_Type
+ is
+ L_Node : Count_Type;
+ R_Node : Count_Type;
+
+ Dst_Node : Count_Type;
+ pragma Warnings (Off, Dst_Node);
+
+ begin
+ if Left'Address = Right'Address then
+ return S : Set_Type (0); -- Empty set
+ end if;
+
+ if Right.Length = 0 then
+ return Copy (Left);
+ end if;
+
+ if Left.Length = 0 then
+ return Copy (Right);
+ end if;
+
+ return Result : Set_Type (Left.Length + Right.Length) do
+ L_Node := Left.First;
+ R_Node := Right.First;
+ loop
+ if L_Node = 0 then
+ while R_Node /= 0 loop
+ Insert_With_Hint
+ (Dst_Set => Result,
+ Dst_Hint => 0,
+ Src_Node => Right.Nodes (R_Node),
+ Dst_Node => Dst_Node);
+
+ R_Node := Tree_Operations.Next (Right, R_Node);
+ end loop;
+
+ return;
+ 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;
+
+ return;
+ 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 => Left.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Tree_Operations.Next (Left, L_Node);
+
+ 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;
+ end return;
+ end Set_Symmetric_Difference;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is
+ 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 => Target,
+ Dst_Hint => Hint,
+ Src_Node => Source.Nodes (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;
+
+ -- Note that there's no way to decide apriori 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);
+ end Set_Union;
+
+ function Set_Union (Left, Right : Set_Type) return Set_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;
+
+ return Result : Set_Type (Left.Length + Right.Length) do
+ Assign (Target => Result, Source => Left);
+
+ 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
+ Iterate (Right);
+ end Insert_Right;
+ end return;
+ end Set_Union;
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+------------------------------------------------------------------------------
+
+-- Tree_Type is used to implement ordered containers. This package declares
+-- set-based tree operations.
+
+with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
+
+generic
+ with package Tree_Operations is new Generic_Bounded_Operations (<>);
+
+ type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private;
+
+ use Tree_Operations.Tree_Types;
+
+ with procedure Assign (Target : in out Set_Type; Source : Set_Type);
+
+ with procedure Insert_With_Hint
+ (Dst_Set : in out Set_Type;
+ Dst_Hint : Count_Type;
+ Src_Node : Node_Type;
+ Dst_Node : out Count_Type);
+
+ with function Is_Less (Left, Right : Node_Type) return Boolean;
+
+package Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
+ pragma Pure;
+
+ procedure Set_Union (Target : in out Set_Type; Source : Set_Type);
+ -- Attempts to insert each element of Source in Target. If Target is
+ -- busy then Program_Error is raised. We say "attempts" here because
+ -- if these are unique-element sets, then the insertion should fail
+ -- (not insert a new item) when the insertion item from Source is
+ -- equivalent to an item already in Target. If these are multisets
+ -- then of course the attempt should always succeed.
+
+ function Set_Union (Left, Right : Set_Type) return Set_Type;
+ -- Makes a copy of Left, and attempts to insert each element of
+ -- Right into the copy, then returns the copy.
+
+ procedure Set_Intersection (Target : in out Set_Type; Source : Set_Type);
+ -- Removes elements from Target that are not equivalent to items in
+ -- Source. If Target is busy then Program_Error is raised.
+
+ function Set_Intersection (Left, Right : Set_Type) return Set_Type;
+ -- Returns a set comprising all the items in Left equivalent to items in
+ -- Right.
+
+ procedure Set_Difference (Target : in out Set_Type; Source : Set_Type);
+ -- Removes elements from Target that are equivalent to items in Source. If
+ -- Target is busy then Program_Error is raised.
+
+ function Set_Difference (Left, Right : Set_Type) return Set_Type;
+ -- Returns a set comprising all the items in Left not equivalent to items
+ -- in Right.
+
+ procedure Set_Symmetric_Difference
+ (Target : in out Set_Type;
+ Source : Set_Type);
+ -- Removes from Target elements that are equivalent to items in Source,
+ -- and inserts into Target items from Source not equivalent elements in
+ -- Target. If Target is busy then Program_Error is raised.
+
+ function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type;
+ -- Returns a set comprising the union of the elements in Left not
+ -- equivalent to items in Right, and the elements in Right not equivalent
+ -- to items in Left.
+
+ function Set_Subset (Subset : Set_Type; Of_Set : Set_Type) return Boolean;
+ -- Returns False if Subset contains at least one element not equivalent to
+ -- any item in Of_Set; returns True otherwise.
+
+ function Set_Overlap (Left, Right : Set_Type) return Boolean;
+ -- Returns True if at least one element of Left is equivalent to an item in
+ -- Right; returns False otherwise.
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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 Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
+pragma Elaborate_All
+ (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
+pragma Elaborate_All
+ (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Bounded_Ordered_Maps is
+
+ -----------------------------
+ -- Node Access Subprograms --
+ -----------------------------
+
+ -- These subprograms provide a functional interface to access fields
+ -- of a node, and a procedural interface for modifying these values.
+
+ function Color (Node : Node_Type) return Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Type) return Count_Type;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Type) return Count_Type;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Type) return Count_Type;
+ pragma Inline (Right);
+
+ procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
+ pragma Inline (Set_Right);
+
+ procedure Set_Color (Node : in out Node_Type; Color : Color_Type);
+ pragma Inline (Set_Color);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
+
+ use Tree_Operations;
+
+ package Key_Ops is
+ new Red_Black_Trees.Generic_Bounded_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "Left cursor of ""<"" is bad");
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "Right cursor of ""<"" is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return LN.Key < RN.Key;
+ end;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "Left cursor of ""<"" is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+
+ begin
+ return LN.Key < Right;
+ end;
+ end "<";
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "Right cursor of ""<"" is bad");
+
+ declare
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return Left < RN.Key;
+ end;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Map) return Boolean is
+ function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node
+ (L, R : Node_Type) return Boolean is
+ begin
+ if L.Key < R.Key then
+ return False;
+
+ elsif R.Key < L.Key then
+ return False;
+
+ else
+ return L.Element = R.Element;
+ end if;
+ end Is_Equal_Node_Node;
+
+ -- Start of processing for "="
+
+ begin
+ return Is_Equal (Left, Right);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor of "">"" equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor of "">"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "Left cursor of "">"" is bad");
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "Right cursor of "">"" is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return RN.Key < LN.Key;
+ end;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor of "">"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "Left cursor of "">"" is bad");
+
+ declare
+ LN : Node_Type renames Left.Container.Nodes (Left.Node);
+
+ begin
+ return Right < LN.Key;
+ end;
+ end ">";
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor of "">"" equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "Right cursor of "">"" is bad");
+
+ declare
+ RN : Node_Type renames Right.Container.Nodes (Right.Node);
+
+ begin
+ return RN.Key < Left;
+ end;
+ end ">";
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Map; Source : Map) is
+ procedure Append_Element (Source_Node : Count_Type);
+
+ procedure Append_Elements is
+ new Tree_Operations.Generic_Iteration (Append_Element);
+
+ --------------------
+ -- Append_Element --
+ --------------------
+
+ procedure Append_Element (Source_Node : Count_Type) is
+ SN : Node_Type renames Source.Nodes (Source_Node);
+
+ procedure Set_Element (Node : in out Node_Type);
+ pragma Inline (Set_Element);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert_Sans_Hint is
+ new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
+
+ procedure Unconditional_Insert_Avec_Hint is
+ new Key_Ops.Generic_Unconditional_Insert_With_Hint
+ (Insert_Post,
+ Unconditional_Insert_Sans_Hint);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Set_Element);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Target, Result);
+ return Result;
+ end New_Node;
+
+ -----------------
+ -- Set_Element --
+ -----------------
+
+ procedure Set_Element (Node : in out Node_Type) is
+ begin
+ Node.Key := SN.Key;
+ Node.Element := SN.Element;
+ end Set_Element;
+
+ Target_Node : Count_Type;
+
+ -- Start of processing for Append_Element
+
+ begin
+ Unconditional_Insert_Avec_Hint
+ (Tree => Target,
+ Hint => 0,
+ Key => SN.Key,
+ Node => Target_Node);
+ end Append_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error
+ with "Target capacity is less than Source length";
+ end if;
+
+ Tree_Operations.Clear_Tree (Target);
+ Append_Elements (Source);
+ end Assign;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ begin
+ Tree_Operations.Clear_Tree (Container);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Type) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
+ C : Count_Type;
+
+ begin
+ if Capacity = 0 then
+ C := Source.Length;
+
+ elsif Capacity >= Source.Length then
+ C := Capacity;
+
+ else
+ raise Capacity_Error with "Capacity value too small";
+ end if;
+
+ return Target : Map (Capacity => C) do
+ Assign (Target => Target, Source => Source);
+ end return;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Delete equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Delete designates wrong map";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "Position cursor of Delete is bad");
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
+ Tree_Operations.Free (Container, Position.Node);
+
+ Position := No_Element;
+ end Delete;
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ X : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if X = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Map) is
+ X : constant Count_Type := Container.First;
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Map) is
+ X : constant Count_Type := Container.Last;
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Delete_Last;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of function Element equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "Position cursor of function Element is bad");
+
+ return Position.Container.Nodes (Position.Node).Element;
+ end Element;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ return Container.Nodes (Node).Element;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
+ begin
+ if Left < Right
+ or else Right < Left
+ then
+ return False;
+ else
+ return True;
+ end if;
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ begin
+ if Container.First = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Container.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Map) return Element_Type is
+ begin
+ if Container.First = 0 then
+ raise Constraint_Error with "map is empty";
+ end if;
+
+ return Container.Nodes (Container.First).Element;
+ end First_Element;
+
+ ---------------
+ -- First_Key --
+ ---------------
+
+ function First_Key (Container : Map) return Key_Type is
+ begin
+ if Container.First = 0 then
+ raise Constraint_Error with "map is empty";
+ end if;
+
+ return Container.Nodes (Container.First).Key;
+ end First_Key;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Ops.Floor (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Floor;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+
+ begin
+ N.Key := Key;
+ N.Element := New_Item;
+ end;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ procedure Assign (Node : in out Node_Type);
+ pragma Inline (Assign);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Assign);
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Assign;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container,
+ Key,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unrestricted_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error with "key already in map";
+ end if;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ procedure Assign (Node : in out Node_Type);
+ pragma Inline (Assign);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Assign);
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ -- Node.Element := New_Item;
+ end Assign;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container,
+ Key,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unrestricted_Access;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Map) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ -- k > node same as node < k
+
+ return Right.Key < Left;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ return Left < Right.Key;
+ end Is_Less_Key_Node;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of function Key equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "Position cursor of function Key is bad");
+
+ return Position.Container.Nodes (Position.Node).Key;
+ end Key;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Map) return Cursor is
+ begin
+ if Container.Last = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Map) return Element_Type is
+ begin
+ if Container.Last = 0 then
+ raise Constraint_Error with "map is empty";
+ end if;
+
+ return Container.Nodes (Container.Last).Element;
+ end Last_Element;
+
+ --------------
+ -- Last_Key --
+ --------------
+
+ function Last_Key (Container : Map) return Key_Type is
+ begin
+ if Container.Last = 0 then
+ raise Constraint_Error with "map is empty";
+ end if;
+
+ return Container.Nodes (Container.Last).Key;
+ end Last_Key;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Map; Source : in out Map) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Assign (Target => Target, Source => Source);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "Position cursor of Next is bad");
+
+ declare
+ M : Map renames Position.Container.all;
+
+ Node : constant Count_Type :=
+ Tree_Operations.Next (M, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "Position cursor of Previous is bad");
+
+ declare
+ M : Map renames Position.Container.all;
+
+ Node : constant Count_Type :=
+ Tree_Operations.Previous (M, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "Position cursor of Query_Element is bad");
+
+ declare
+ M : Map renames Position.Container.all;
+ N : Node_Type renames M.Nodes (Position.Node);
+
+ B : Natural renames M.Busy;
+ L : Natural renames M.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (N.Key, N.Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Read_Element);
+
+ procedure Read_Elements is
+ new Tree_Operations.Generic_Read (Allocate);
+
+ ------------------
+ -- Read_Element --
+ ------------------
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ -- Start of processing for Read
+
+ begin
+ Read_Elements (Stream, Container);
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Nodes (Node);
+
+ begin
+ N.Key := Key;
+ N.Element := New_Item;
+ end;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Replace_Element equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Replace_Element designates wrong map";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (map is locked)";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "Position cursor of Replace_Element is bad");
+
+ Container.Nodes (Position.Node).Element := New_Item;
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (Container);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color
+ (Node : in out Node_Type;
+ Color : Color_Type)
+ is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor of Update_Element equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor of Update_Element designates wrong map";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "Position cursor of Update_Element is bad");
+
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (N.Key, N.Element);
+
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is
+ new Tree_Operations.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Write;
+
+end Ada.Containers.Bounded_Ordered_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Red_Black_Trees;
+private with Ada.Streams;
+
+generic
+ type Key_Type is private;
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Key_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Bounded_Ordered_Maps is
+ pragma Pure;
+ pragma Remote_Types;
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ type Map (Capacity : Count_Type) is tagged private;
+ pragma Preelaborable_Initialization (Map);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+
+ procedure Assign (Target : in out Map; Source : Map);
+
+ function Copy (Source : Map; Capacity : Count_Type := 0) return Map;
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Map);
+
+ procedure Delete_Last (Container : in out Map);
+
+ function First (Container : Map) return Cursor;
+
+ function First_Element (Container : Map) return Element_Type;
+
+ function First_Key (Container : Map) return Key_Type;
+
+ function Last (Container : Map) return Cursor;
+
+ function Last_Element (Container : Map) return Element_Type;
+
+ function Last_Key (Container : Map) return Key_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Previous (Position : in out Cursor);
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+
+ function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Key_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process : not null access procedure (Position : Cursor));
+
+private
+
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
+ type Node_Type is record
+ Parent : Count_Type;
+ Left : Count_Type;
+ Right : Count_Type;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Key : Key_Type;
+ Element : Element_Type;
+ end record;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
+
+ type Map (Capacity : Count_Type) is
+ new Tree_Types.Tree_Type (Capacity) with null record;
+
+ type Map_Access is access all Map;
+ for Map_Access'Storage_Size use 0;
+
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Streams;
+
+ type Cursor is record
+ Container : Map_Access;
+ Node : Count_Type;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := Cursor'(null, 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0);
+
+end Ada.Containers.Bounded_Ordered_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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 Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
+pragma Elaborate_All
+ (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
+
+with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
+pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
+
+with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
+pragma Elaborate_All
+ (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
+
+with System; use type System.Address;
+
+package body Ada.Containers.Bounded_Ordered_Sets is
+
+ ------------------------------
+ -- Access to Fields of Node --
+ ------------------------------
+
+ -- These subprograms provide functional notation for access to fields
+ -- of a node, and procedural notation for modifying these fields.
+
+ function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
+ pragma Inline (Color);
+
+ function Left (Node : Node_Type) return Count_Type;
+ pragma Inline (Left);
+
+ function Parent (Node : Node_Type) return Count_Type;
+ pragma Inline (Parent);
+
+ function Right (Node : Node_Type) return Count_Type;
+ pragma Inline (Right);
+
+ procedure Set_Color
+ (Node : in out Node_Type;
+ Color : Red_Black_Trees.Color_Type);
+ pragma Inline (Set_Color);
+
+ procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
+ pragma Inline (Set_Left);
+
+ procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
+ pragma Inline (Set_Right);
+
+ procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
+ pragma Inline (Set_Parent);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Insert_Sans_Hint
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+
+ procedure Insert_With_Hint
+ (Dst_Set : in out Set;
+ Dst_Hint : Count_Type;
+ Src_Node : Node_Type;
+ Dst_Node : out Count_Type);
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Greater_Element_Node);
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Less_Element_Node);
+
+ function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
+ pragma Inline (Is_Less_Node_Node);
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Index : Count_Type;
+ Item : Element_Type);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Tree_Operations is
+ new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
+
+ use Tree_Operations;
+
+ package Element_Keys is
+ new Red_Black_Trees.Generic_Bounded_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Element_Type,
+ Is_Less_Key_Node => Is_Less_Element_Node,
+ Is_Greater_Key_Node => Is_Greater_Element_Node);
+
+ package Set_Ops is
+ new Red_Black_Trees.Generic_Bounded_Set_Operations
+ (Tree_Operations => Tree_Operations,
+ Set_Type => Set,
+ Assign => Assign,
+ Insert_With_Hint => Insert_With_Hint,
+ Is_Less => Is_Less_Node_Node);
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Cursor) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "bad Left cursor in ""<""");
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "bad Right cursor in ""<""");
+
+ declare
+ LN : Nodes_Type renames Left.Container.Nodes;
+ RN : Nodes_Type renames Right.Container.Nodes;
+ begin
+ return LN (Left.Node).Element < RN (Right.Node).Element;
+ end;
+ end "<";
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "bad Left cursor in ""<""");
+
+ return Left.Container.Nodes (Left.Node).Element < Right;
+ end "<";
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "bad Right cursor in ""<""");
+
+ return Left < Right.Container.Nodes (Right.Node).Element;
+ end "<";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Set) return Boolean is
+ function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
+ pragma Inline (Is_Equal_Node_Node);
+
+ function Is_Equal is
+ new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
+
+ ------------------------
+ -- Is_Equal_Node_Node --
+ ------------------------
+
+ function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is
+ begin
+ return L.Element = R.Element;
+ end Is_Equal_Node_Node;
+
+ -- Start of processing for Is_Equal
+
+ begin
+ return Is_Equal (Left, Right);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Cursor) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "bad Left cursor in "">""");
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "bad Right cursor in "">""");
+
+ -- L > R same as R < L
+
+ declare
+ LN : Nodes_Type renames Left.Container.Nodes;
+ RN : Nodes_Type renames Right.Container.Nodes;
+ begin
+ return RN (Right.Node).Element < LN (Left.Node).Element;
+ end;
+ end ">";
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean is
+ begin
+ if Right.Node = 0 then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Right.Container.all, Right.Node),
+ "bad Right cursor in "">""");
+
+ return Right.Container.Nodes (Right.Node).Element < Left;
+ end ">";
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean is
+ begin
+ if Left.Node = 0 then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Left.Container.all, Left.Node),
+ "bad Left cursor in "">""");
+
+ return Right < Left.Container.Nodes (Left.Node).Element;
+ end ">";
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Set; Source : Set) is
+ procedure Append_Element (Source_Node : Count_Type);
+
+ procedure Append_Elements is
+ new Tree_Operations.Generic_Iteration (Append_Element);
+
+ --------------------
+ -- Append_Element --
+ --------------------
+
+ procedure Append_Element (Source_Node : Count_Type) is
+ SN : Node_Type renames Source.Nodes (Source_Node);
+
+ procedure Set_Element (Node : in out Node_Type);
+ pragma Inline (Set_Element);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert_Sans_Hint is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ procedure Unconditional_Insert_Avec_Hint is
+ new Element_Keys.Generic_Unconditional_Insert_With_Hint
+ (Insert_Post,
+ Unconditional_Insert_Sans_Hint);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Set_Element);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Target, Result);
+ return Result;
+ end New_Node;
+
+ -----------------
+ -- Set_Element --
+ -----------------
+
+ procedure Set_Element (Node : in out Node_Type) is
+ begin
+ Node.Element := SN.Element;
+ end Set_Element;
+
+ Target_Node : Count_Type;
+
+ -- Start of processing for Append_Element
+
+ begin
+ Unconditional_Insert_Avec_Hint
+ (Tree => Target,
+ Hint => 0,
+ Key => SN.Element,
+ Node => Target_Node);
+ end Append_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error
+ with "Target capacity is less than Source length";
+ end if;
+
+ Target.Clear;
+ Append_Elements (Source);
+ end Assign;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Count_Type :=
+ Element_Keys.Ceiling (Container, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ begin
+ Tree_Operations.Clear_Tree (Container);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : Set;
+ Item : Element_Type) return Boolean
+ is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
+ C : Count_Type;
+
+ begin
+ if Capacity = 0 then
+ C := Source.Length;
+
+ elsif Capacity >= Source.Length then
+ C := Capacity;
+
+ else
+ raise Capacity_Error with "Capacity value too small";
+ end if;
+
+ return Target : Set (Capacity => C) do
+ Assign (Target => Target, Source => Source);
+ end return;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor designates wrong set";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "bad cursor in Delete");
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
+ Tree_Operations.Free (Container, Position.Node);
+
+ Position := No_Element;
+ end Delete;
+
+ procedure Delete (Container : in out Set; Item : Element_Type) is
+ X : constant Count_Type := Element_Keys.Find (Container, Item);
+
+ begin
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete element not in set";
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ X : constant Count_Type := Container.First;
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ X : constant Count_Type := Container.Last;
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Delete_Last;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set)
+ renames Set_Ops.Set_Difference;
+
+ function Difference (Left, Right : Set) return Set
+ renames Set_Ops.Set_Difference;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "bad cursor in Element");
+
+ return Position.Container.Nodes (Position.Node).Element;
+ end Element;
+
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
+
+ function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
+ begin
+ if Left < Right
+ or else Right < Left
+ then
+ return False;
+ else
+ return True;
+ end if;
+ end Equivalent_Elements;
+
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+ function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
+ pragma Inline (Is_Equivalent_Node_Node);
+
+ function Is_Equivalent is
+ new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+ -----------------------------
+ -- Is_Equivalent_Node_Node --
+ -----------------------------
+
+ function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
+ begin
+ if L.Element < R.Element then
+ return False;
+ elsif R.Element < L.Element then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Equivalent_Node_Node;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left, Right);
+ end Equivalent_Sets;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ X : constant Count_Type := Element_Keys.Find (Container, Item);
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Count_Type := Element_Keys.Find (Container, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Container.First = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Container.First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Set) return Element_Type is
+ begin
+ if Container.First = 0 then
+ raise Constraint_Error with "set is empty";
+ end if;
+
+ return Container.Nodes (Container.First).Element;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ Node : constant Count_Type := Element_Keys.Floor (Container, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Floor;
+
+ ------------------
+ -- Generic_Keys --
+ ------------------
+
+ package body Generic_Keys is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Greater_Key_Node);
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean;
+ pragma Inline (Is_Less_Key_Node);
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package Key_Keys is
+ new Red_Black_Trees.Generic_Bounded_Keys
+ (Tree_Operations => Tree_Operations,
+ Key_Type => Key_Type,
+ Is_Less_Key_Node => Is_Less_Key_Node,
+ Is_Greater_Key_Node => Is_Greater_Key_Node);
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Count_Type :=
+ Key_Keys.Ceiling (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Ceiling;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Key : Key_Type) is
+ X : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in set";
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type is
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in set";
+ end if;
+
+ return Container.Nodes (Node).Element;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
+ begin
+ if Left < Right
+ or else Right < Left
+ then
+ return False;
+ else
+ return True;
+ end if;
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Key : Key_Type) is
+ X : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Tree_Operations.Free (Container, X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ Node : constant Count_Type := Key_Keys.Floor (Container, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Floor;
+
+ -------------------------
+ -- Is_Greater_Key_Node --
+ -------------------------
+
+ function Is_Greater_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ return Key (Right.Element) < Left;
+ end Is_Greater_Key_Node;
+
+ ----------------------
+ -- Is_Less_Key_Node --
+ ----------------------
+
+ function Is_Less_Key_Node
+ (Left : Key_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ return Left < Key (Right.Element);
+ end Is_Less_Key_Node;
+
+ ---------
+ -- Key --
+ ---------
+
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "bad cursor in Key");
+
+ return Key (Position.Container.Nodes (Position.Node).Element);
+ end Key;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
+ end if;
+
+ Replace_Element (Container, Node, New_Item);
+ end Replace;
+
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong set";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "bad cursor in Update_Element_Preserving_Key");
+
+ declare
+ N : Node_Type renames Container.Nodes (Position.Node);
+ E : Element_Type renames N.Element;
+ K : constant Key_Type := Key (E);
+
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if Equivalent_Keys (K, Key (E)) then
+ return;
+ end if;
+ end;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
+ Tree_Operations.Free (Container, Position.Node);
+
+ raise Program_Error with "key was modified";
+ end Update_Element_Preserving_Key;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position /= No_Element;
+ end Has_Element;
+
+ -------------
+ -- Include --
+ -------------
+
+ procedure Include (Container : in out Set; New_Item : Element_Type) is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ Container.Nodes (Position.Node).Element := New_Item;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+ Insert_Sans_Hint
+ (Container,
+ New_Item,
+ Position.Node,
+ Inserted);
+
+ Position.Container := Container'Unrestricted_Access;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ raise Constraint_Error with
+ "attempt to insert element already in set";
+ end if;
+ end Insert;
+
+ ----------------------
+ -- Insert_Sans_Hint --
+ ----------------------
+
+ procedure Insert_Sans_Hint
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean)
+ is
+ procedure Set_Element (Node : in out Node_Type);
+ pragma Inline (Set_Element);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Conditional_Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Set_Element);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -----------------
+ -- Set_Element --
+ -----------------
+
+ procedure Set_Element (Node : in out Node_Type) is
+ begin
+ Node.Element := New_Item;
+ end Set_Element;
+
+ -- Start of processing for Insert_Sans_Hint
+
+ begin
+ Conditional_Insert_Sans_Hint
+ (Container,
+ New_Item,
+ Node,
+ Inserted);
+ end Insert_Sans_Hint;
+
+ ----------------------
+ -- Insert_With_Hint --
+ ----------------------
+
+ procedure Insert_With_Hint
+ (Dst_Set : in out Set;
+ Dst_Hint : Count_Type;
+ Src_Node : Node_Type;
+ Dst_Node : out Count_Type)
+ is
+ Success : Boolean;
+ pragma Unreferenced (Success);
+
+ procedure Set_Element (Node : in out Node_Type);
+ pragma Inline (Set_Element);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Insert_Post,
+ Insert_Sans_Hint);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Set_Element);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+
+ begin
+ Allocate (Dst_Set, Result);
+ return Result;
+ end New_Node;
+
+ -----------------
+ -- Set_Element --
+ -----------------
+
+ procedure Set_Element (Node : in out Node_Type) is
+ begin
+ Node.Element := Src_Node.Element;
+ end Set_Element;
+
+ -- Start of processing for Insert_With_Hint
+
+ begin
+ Local_Insert_With_Hint
+ (Dst_Set,
+ Dst_Hint,
+ Src_Node.Element,
+ Dst_Node,
+ Success);
+ end Insert_With_Hint;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection (Target : in out Set; Source : Set)
+ renames Set_Ops.Set_Intersection;
+
+ function Intersection (Left, Right : Set) return Set
+ renames Set_Ops.Set_Intersection;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
+
+ -----------------------------
+ -- Is_Greater_Element_Node --
+ -----------------------------
+
+ function Is_Greater_Element_Node
+ (Left : Element_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ -- Compute e > node same as node < e
+
+ return Right.Element < Left;
+ end Is_Greater_Element_Node;
+
+ --------------------------
+ -- Is_Less_Element_Node --
+ --------------------------
+
+ function Is_Less_Element_Node
+ (Left : Element_Type;
+ Right : Node_Type) return Boolean
+ is
+ begin
+ return Left < Right.Element;
+ end Is_Less_Element_Node;
+
+ -----------------------
+ -- Is_Less_Node_Node --
+ -----------------------
+
+ function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
+ begin
+ return L.Element < R.Element;
+ end Is_Less_Node_Node;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean
+ renames Set_Ops.Set_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ S : Set renames Container'Unrestricted_Access.all;
+ B : Natural renames S.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Local_Iterate (S);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Container.Last = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Set) return Element_Type is
+ begin
+ if Container.Last = 0 then
+ raise Constraint_Error with "set is empty";
+ end if;
+
+ return Container.Nodes (Container.Last).Element;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Left;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.Length;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Assign (Target => Target, Source => Source);
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "bad cursor in Next");
+
+ declare
+ Node : constant Count_Type :=
+ Tree_Operations.Next (Position.Container.all, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean
+ renames Set_Ops.Set_Overlap;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Parent;
+ end Parent;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous (Position : Cursor) return Cursor is
+ begin
+ if Position = No_Element then
+ return No_Element;
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "bad cursor in Previous");
+
+ declare
+ Node : constant Count_Type :=
+ Tree_Operations.Previous
+ (Position.Container.all,
+ Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
+ end;
+ end Previous;
+
+ procedure Previous (Position : in out Cursor) is
+ begin
+ Position := Previous (Position);
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert (Vet (Position.Container.all, Position.Node),
+ "bad cursor in Query_Element");
+
+ declare
+ S : Set renames Position.Container.all;
+
+ B : Natural renames S.Busy;
+ L : Natural renames S.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (S.Nodes (Position.Node).Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Tree_Operations.Generic_Allocate (Read_Element);
+
+ procedure Read_Elements is
+ new Tree_Operations.Generic_Read (Allocate);
+
+ ------------------
+ -- Read_Element --
+ ------------------
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ -- Start of processing for Read
+
+ begin
+ Read_Elements (Stream, Container);
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type) is
+ Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ Container.Nodes (Node).Element := New_Item;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Index : Count_Type;
+ Item : Element_Type)
+ is
+ pragma Assert (Index /= 0);
+
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Local_Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Local_Insert_Post,
+ Local_Insert_Sans_Hint);
+
+ Nodes : Nodes_Type renames Container.Nodes;
+ Node : Node_Type renames Nodes (Index);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Count_Type is
+ begin
+ Node.Element := Item;
+ Node.Color := Red_Black_Trees.Red;
+ Node.Parent := 0;
+ Node.Right := 0;
+ Node.Left := 0;
+
+ return Index;
+ end New_Node;
+
+ Hint : Count_Type;
+ Result : Count_Type;
+ Inserted : Boolean;
+
+ -- Start of processing for Replace_Element
+
+ begin
+ if Item < Node.Element
+ or else Node.Element < Item
+ then
+ null;
+
+ else
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ Node.Element := Item;
+ return;
+ end if;
+
+ Hint := Element_Keys.Ceiling (Container, Item);
+
+ if Hint = 0 then
+ null;
+
+ elsif Item < Nodes (Hint).Element then
+ if Hint = Index then
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is locked)";
+ end if;
+
+ 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;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container, Index);
+
+ Local_Insert_With_Hint
+ (Tree => Container,
+ Position => Hint,
+ Key => Item,
+ Node => Result,
+ Inserted => Inserted);
+
+ pragma Assert (Inserted);
+ pragma Assert (Result = Index);
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong set";
+ end if;
+
+ pragma Assert (Vet (Container, Position.Node),
+ "bad cursor in Replace_Element");
+
+ Replace_Element (Container, Position.Node, New_Item);
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
+
+ S : Set renames Container'Unrestricted_Access.all;
+ B : Natural renames S.Busy;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (S);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Node : Node_Type) return Count_Type is
+ begin
+ return Node.Right;
+ end Right;
+
+ ---------------
+ -- Set_Color --
+ ---------------
+
+ procedure Set_Color
+ (Node : in out Node_Type;
+ Color : Red_Black_Trees.Color_Type)
+ is
+ begin
+ Node.Color := Color;
+ end Set_Color;
+
+ --------------
+ -- Set_Left --
+ --------------
+
+ procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
+ begin
+ Node.Left := Left;
+ end Set_Left;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
+ begin
+ Node.Parent := Parent;
+ end Set_Parent;
+
+ ---------------
+ -- Set_Right --
+ ---------------
+
+ procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
+ begin
+ Node.Right := Right;
+ end Set_Right;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set)
+ renames Set_Ops.Set_Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set
+ renames Set_Ops.Set_Symmetric_Difference;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ function To_Set (New_Item : Element_Type) return Set is
+ Node : Count_Type;
+ Inserted : Boolean;
+ begin
+ return S : Set (1) do
+ Insert_Sans_Hint (S, New_Item, Node, Inserted);
+ pragma Assert (Inserted);
+ end return;
+ end To_Set;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set)
+ renames Set_Ops.Set_Union;
+
+ function Union (Left, Right : Set) return Set
+ renames Set_Ops.Set_Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Write_Element
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Element);
+
+ procedure Write_Elements is
+ new Tree_Operations.Generic_Write (Write_Element);
+
+ -------------------
+ -- Write_Element --
+ -------------------
+
+ procedure Write_Element
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Element;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Elements (Stream, Container);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Write;
+
+end Ada.Containers.Bounded_Ordered_Sets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Red_Black_Trees;
+private with Ada.Streams;
+
+generic
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Bounded_Ordered_Sets is
+ pragma Pure;
+ pragma Remote_Types;
+
+ function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
+
+ type Set (Capacity : Count_Type) is tagged private;
+ pragma Preelaborable_Initialization (Set);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
+ function To_Set (New_Item : Element_Type) return Set;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ function Element (Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Assign (Target : in out Set; Source : Set);
+
+ function Copy (Source : Set; Capacity : Count_Type := 0) return Set;
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Previous (Position : Cursor) return Cursor;
+
+ procedure Previous (Position : in out Cursor);
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function "<" (Left, Right : Cursor) return Boolean;
+
+ function ">" (Left, Right : Cursor) return Boolean;
+
+ function "<" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function ">" (Left : Cursor; Right : Element_Type) return Boolean;
+
+ function "<" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ function ">" (Left : Element_Type; Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
+
+ generic
+ type Key_Type (<>) is private;
+
+ with function Key (Element : Element_Type) return Key_Type;
+
+ with function "<" (Left, Right : Key_Type) return Boolean is <>;
+
+ package Generic_Keys is
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ end Generic_Keys;
+
+private
+
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
+ type Node_Type is record
+ Parent : Count_Type;
+ Left : Count_Type;
+ Right : Count_Type;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Element : Element_Type;
+ end record;
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
+
+ type Set (Capacity : Count_Type) is
+ new Tree_Types.Tree_Type (Capacity) with null record;
+
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Set_Access;
+ Node : Count_Type;
+ end record;
+
+ use Tree_Types;
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := Cursor'(null, 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0);
+
+end Ada.Containers.Bounded_Ordered_Sets;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2010, 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- --
end record;
end Generic_Tree_Types;
+ generic
+ type Node_Type is private;
+ package Generic_Bounded_Tree_Types is
+ type Nodes_Type is array (Count_Type range <>) of Node_Type;
+
+ type Tree_Type (Capacity : Count_Type) is tagged record
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ Root : Count_Type := 0;
+ Length : Count_Type := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
+ Free : Count_Type'Base := -1;
+ Nodes : Nodes_Type (1 .. Capacity);
+ end record;
+ end Generic_Bounded_Tree_Types;
+
end Ada.Containers.Red_Black_Trees;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+------------------------------------------------------------------------------
+
+package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
+
+ package Ops renames Tree_Operations;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ -- AKA Lower_Bound
+
+ function Ceiling
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Y := 0;
+
+ X := Tree.Root;
+ while X /= 0 loop
+ if Is_Greater_Key_Node (Key, N (X)) then
+ X := Ops.Right (N (X));
+ else
+ Y := X;
+ X := Ops.Left (N (X));
+ end if;
+ end loop;
+
+ return Y;
+ end Ceiling;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Y := 0;
+
+ X := Tree.Root;
+ while X /= 0 loop
+ if Is_Greater_Key_Node (Key, N (X)) then
+ X := Ops.Right (N (X));
+ else
+ Y := X;
+ X := Ops.Left (N (X));
+ end if;
+ end loop;
+
+ if Y = 0 then
+ return 0;
+ end if;
+
+ if Is_Less_Key_Node (Key, N (Y)) then
+ return 0;
+ end if;
+
+ return Y;
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Y := 0;
+
+ X := Tree.Root;
+ while X /= 0 loop
+ if Is_Less_Key_Node (Key, N (X)) then
+ X := Ops.Left (N (X));
+ else
+ Y := X;
+ X := Ops.Right (N (X));
+ end if;
+ end loop;
+
+ return Y;
+ end Floor;
+
+ --------------------------------
+ -- Generic_Conditional_Insert --
+ --------------------------------
+
+ procedure Generic_Conditional_Insert
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean)
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Y := 0;
+
+ X := Tree.Root;
+ Inserted := True;
+ while X /= 0 loop
+ Y := X;
+ Inserted := Is_Less_Key_Node (Key, N (X));
+ X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X)));
+ end loop;
+
+ -- If Inserted is True, then this means either that Tree is
+ -- empty, or there was a least one node (strictly) greater than
+ -- Key. Otherwise, it means that Key is equal to or greater than
+ -- every node.
+
+ if Inserted then
+ if Y = Tree.First then
+ Insert_Post (Tree, Y, True, Node);
+ return;
+ end if;
+
+ Node := Ops.Previous (Tree, Y);
+
+ else
+ Node := Y;
+ end if;
+
+ -- Here Node has a value that is less than or equal to Key. We
+ -- now have to resolve whether Key is equal to or greater than
+ -- Node, which determines whether the insertion succeeds.
+
+ if Is_Greater_Key_Node (Key, N (Node)) then
+ Insert_Post (Tree, Y, Inserted, Node);
+ Inserted := True;
+ return;
+ end if;
+
+ Inserted := False;
+ end Generic_Conditional_Insert;
+
+ ------------------------------------------
+ -- Generic_Conditional_Insert_With_Hint --
+ ------------------------------------------
+
+ procedure Generic_Conditional_Insert_With_Hint
+ (Tree : in out Tree_Type'Class;
+ Position : Count_Type;
+ Key : Key_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean)
+ is
+ N : Nodes_Type renames Tree.Nodes;
+
+ 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
+ -- subtree rooted at the hint to find the nearest neighbor. Note
+ -- that finding the neighbor means merely walking the tree; this
+ -- is not a search and the only comparisons that occur are with
+ -- the hint and its neighbor.
+
+ -- If Position is 0, this is interpreted to mean that Key is
+ -- large relative to the nodes in the tree. If the tree is empty,
+ -- or Key is greater than the last node in the tree, then we're
+ -- done; otherwise the hint was "wrong" and we must search.
+
+ if Position = 0 then -- largest
+ if Tree.Last = 0
+ or else Is_Greater_Key_Node (Key, N (Tree.Last))
+ then
+ Insert_Post (Tree, Tree.Last, False, Node);
+ Inserted := True;
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ end if;
+
+ return;
+ end if;
+
+ pragma Assert (Tree.Length > 0);
+
+ -- A hint can either name the node that immediately follows Key,
+ -- or immediately precedes Key. We first test whether Key is
+ -- less than the hint, and if so we compare Key to the node that
+ -- precedes the hint. If Key is both less than the hint and
+ -- greater than the hint's preceding neighbor, then we're done;
+ -- otherwise we must search.
+
+ -- Note also that a hint can either be an anterior node or a leaf
+ -- node. A new node is always inserted at the bottom of the tree
+ -- (at least prior to rebalancing), becoming the new left or
+ -- right child of leaf node (which prior to the insertion must
+ -- necessarily be null, since this is a leaf). If the hint names
+ -- an anterior node then its neighbor must be a leaf, and so
+ -- (here) we insert after the neighbor. If the hint names a leaf
+ -- then its neighbor must be anterior and so we insert before the
+ -- hint.
+
+ if Is_Less_Key_Node (Key, N (Position)) then
+ declare
+ Before : constant Count_Type := Ops.Previous (Tree, Position);
+
+ begin
+ if Before = 0 then
+ Insert_Post (Tree, Tree.First, True, Node);
+ Inserted := True;
+
+ elsif Is_Greater_Key_Node (Key, N (Before)) then
+ if Ops.Right (N (Before)) = 0 then
+ Insert_Post (Tree, Before, False, Node);
+ else
+ Insert_Post (Tree, Position, True, Node);
+ end if;
+
+ Inserted := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ -- We know that Key isn't less than the hint so we try again,
+ -- this time to see if it's greater than the hint. If so we
+ -- compare Key to the node that follows the hint. If Key is both
+ -- 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, N (Position)) then
+ declare
+ After : constant Count_Type := Ops.Next (Tree, Position);
+
+ begin
+ if After = 0 then
+ Insert_Post (Tree, Tree.Last, False, Node);
+ Inserted := True;
+
+ elsif Is_Less_Key_Node (Key, N (After)) then
+ if Ops.Right (N (Position)) = 0 then
+ Insert_Post (Tree, Position, False, Node);
+ else
+ Insert_Post (Tree, After, True, Node);
+ end if;
+
+ Inserted := True;
+
+ else
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ -- We know that Key is neither less than the hint nor greater
+ -- than the hint, and that's the definition of equivalence.
+ -- There's nothing else we need to do, since a search would just
+ -- reach the same conclusion.
+
+ Node := Position;
+ Inserted := False;
+ end Generic_Conditional_Insert_With_Hint;
+
+ -------------------------
+ -- Generic_Insert_Post --
+ -------------------------
+
+ procedure Generic_Insert_Post
+ (Tree : in out Tree_Type'Class;
+ Y : Count_Type;
+ Before : Boolean;
+ Z : out Count_Type)
+ is
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ if Tree.Length >= Tree.Capacity then
+ raise Capacity_Error with "not enough capacity to insert new item";
+ end if;
+
+ if Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Z := New_Node;
+ pragma Assert (Z /= 0);
+
+ if Y = 0 then
+ pragma Assert (Tree.Length = 0);
+ pragma Assert (Tree.Root = 0);
+ pragma Assert (Tree.First = 0);
+ pragma Assert (Tree.Last = 0);
+
+ Tree.Root := Z;
+ Tree.First := Z;
+ Tree.Last := Z;
+
+ elsif Before then
+ pragma Assert (Ops.Left (N (Y)) = 0);
+
+ Ops.Set_Left (N (Y), Z);
+
+ if Y = Tree.First then
+ Tree.First := Z;
+ end if;
+
+ else
+ pragma Assert (Ops.Right (N (Y)) = 0);
+
+ Ops.Set_Right (N (Y), Z);
+
+ if Y = Tree.Last then
+ Tree.Last := Z;
+ end if;
+ end if;
+
+ Ops.Set_Color (N (Z), Red);
+ Ops.Set_Parent (N (Z), Y);
+ Ops.Rebalance_For_Insert (Tree, Z);
+ Tree.Length := Tree.Length + 1;
+ end Generic_Insert_Post;
+
+ -----------------------
+ -- Generic_Iteration --
+ -----------------------
+
+ procedure Generic_Iteration
+ (Tree : Tree_Type'Class;
+ Key : Key_Type)
+ is
+ procedure Iterate (Index : Count_Type);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (Index : Count_Type) is
+ J : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ J := Index;
+ while J /= 0 loop
+ if Is_Less_Key_Node (Key, N (J)) then
+ J := Ops.Left (N (J));
+ elsif Is_Greater_Key_Node (Key, N (J)) then
+ J := Ops.Right (N (J));
+ else
+ Iterate (Ops.Left (N (J)));
+ Process (J);
+ J := Ops.Right (N (J));
+ end if;
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Iteration;
+
+ -------------------------------
+ -- Generic_Reverse_Iteration --
+ -------------------------------
+
+ procedure Generic_Reverse_Iteration
+ (Tree : Tree_Type'Class;
+ Key : Key_Type)
+ is
+ procedure Iterate (Index : Count_Type);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (Index : Count_Type) is
+ J : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ J := Index;
+ while J /= 0 loop
+ if Is_Less_Key_Node (Key, N (J)) then
+ J := Ops.Left (N (J));
+ elsif Is_Greater_Key_Node (Key, N (J)) then
+ J := Ops.Right (N (J));
+ else
+ Iterate (Ops.Right (N (J)));
+ Process (J);
+ J := Ops.Left (N (J));
+ end if;
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Reverse_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Reverse_Iteration;
+
+ ----------------------------------
+ -- Generic_Unconditional_Insert --
+ ----------------------------------
+
+ procedure Generic_Unconditional_Insert
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type)
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ Before : Boolean;
+
+ begin
+ Y := 0;
+ Before := False;
+
+ X := Tree.Root;
+ while X /= 0 loop
+ Y := X;
+ Before := Is_Less_Key_Node (Key, N (X));
+ X := (if Before then Ops.Left (N (X)) else Ops.Right (N (X)));
+ end loop;
+
+ Insert_Post (Tree, Y, Before, Node);
+ end Generic_Unconditional_Insert;
+
+ --------------------------------------------
+ -- Generic_Unconditional_Insert_With_Hint --
+ --------------------------------------------
+
+ procedure Generic_Unconditional_Insert_With_Hint
+ (Tree : in out Tree_Type'Class;
+ Hint : Count_Type;
+ Key : Key_Type;
+ Node : out Count_Type)
+ is
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ -- There are fewer constraints for an unconditional insertion
+ -- than for a conditional insertion, since we allow duplicate
+ -- keys. So instead of having to check (say) whether Key is
+ -- (strictly) greater than the hint's previous neighbor, here we
+ -- allow Key to be equal to or greater than the previous node.
+
+ -- There is the issue of what to do if Key is equivalent to the
+ -- hint. Does the new node get inserted before or after the hint?
+ -- We decide that it gets inserted after the hint, reasoning that
+ -- this is consistent with behavior for non-hint insertion, which
+ -- inserts a new node after existing nodes with equivalent keys.
+
+ -- First we check whether the hint is null, which is interpreted
+ -- to mean that Key is large relative to existing nodes.
+ -- Following our rule above, if Key is equal to or greater than
+ -- the last node, then we insert the new node immediately after
+ -- last. (We don't have an operation for testing whether a key is
+ -- "equal to or greater than" a node, so we must say instead "not
+ -- less than", which is equivalent.)
+
+ if Hint = 0 then -- largest
+ if Tree.Last = 0 then
+ Insert_Post (Tree, 0, False, Node);
+ elsif Is_Less_Key_Node (Key, N (Tree.Last)) then
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ else
+ Insert_Post (Tree, Tree.Last, False, Node);
+ end if;
+
+ return;
+ end if;
+
+ pragma Assert (Tree.Length > 0);
+
+ -- We decide here whether to insert the new node prior to the
+ -- hint. Key could be equivalent to the hint, so in theory we
+ -- could write the following test as "not greater than" (same as
+ -- "less than or equal to"). If Key were equivalent to the hint,
+ -- that would mean that the new node gets inserted before an
+ -- equivalent node. That wouldn't break any container invariants,
+ -- but our rule above says that new nodes always get inserted
+ -- after equivalent nodes. So here we test whether Key is both
+ -- less than the hint and equal to or greater than the hint's
+ -- previous neighbor, and if so insert it before the hint.
+
+ if Is_Less_Key_Node (Key, N (Hint)) then
+ declare
+ Before : constant Count_Type := Ops.Previous (Tree, Hint);
+ begin
+ if Before = 0 then
+ Insert_Post (Tree, Hint, True, Node);
+ elsif Is_Less_Key_Node (Key, N (Before)) then
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ elsif Ops.Right (N (Before)) = 0 then
+ Insert_Post (Tree, Before, False, Node);
+ else
+ Insert_Post (Tree, Hint, True, Node);
+ end if;
+ end;
+
+ return;
+ end if;
+
+ -- We know that Key isn't less than the hint, so it must be equal
+ -- or greater. So we just test whether Key is less than or equal
+ -- to (same as "not greater than") the hint's next neighbor, and
+ -- if so insert it after the hint.
+
+ declare
+ After : constant Count_Type := Ops.Next (Tree, Hint);
+ begin
+ if After = 0 then
+ Insert_Post (Tree, Hint, False, Node);
+ elsif Is_Greater_Key_Node (Key, N (After)) then
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ elsif Ops.Right (N (Hint)) = 0 then
+ Insert_Post (Tree, Hint, False, Node);
+ else
+ Insert_Post (Tree, After, True, Node);
+ end if;
+ end;
+ end Generic_Unconditional_Insert_With_Hint;
+
+ -----------------
+ -- Upper_Bound --
+ -----------------
+
+ function Upper_Bound
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type
+ is
+ Y : Count_Type;
+ X : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Y := 0;
+
+ X := Tree.Root;
+ while X /= 0 loop
+ if Is_Less_Key_Node (Key, N (X)) then
+ Y := X;
+ X := Ops.Left (N (X));
+ else
+ X := Ops.Right (N (X));
+ end if;
+ end loop;
+
+ return Y;
+ end Upper_Bound;
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+------------------------------------------------------------------------------
+
+-- Tree_Type is used to implement ordered containers. This package declares
+-- the tree operations that depend on keys.
+
+with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
+
+generic
+ with package Tree_Operations is new Generic_Bounded_Operations (<>);
+
+ use Tree_Operations.Tree_Types;
+
+ type Key_Type (<>) is limited private;
+
+ with function Is_Less_Key_Node
+ (L : Key_Type;
+ R : Node_Type) return Boolean;
+
+ with function Is_Greater_Key_Node
+ (L : Key_Type;
+ R : Node_Type) return Boolean;
+
+package Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
+ pragma Pure;
+
+ generic
+ with function New_Node return Count_Type;
+
+ procedure Generic_Insert_Post
+ (Tree : in out Tree_Type'Class;
+ Y : Count_Type;
+ Before : Boolean;
+ Z : out Count_Type);
+ -- Completes an insertion after the insertion position has been
+ -- determined. On output Z contains the index of the newly inserted
+ -- node, allocated using Allocate. If Tree is busy then
+ -- Program_Error is raised. If Y is 0, then Tree must be empty.
+ -- Otherwise Y denotes the insertion position, and Before specifies
+ -- whether the new node is Y's left (True) or right (False) child.
+
+ generic
+ with procedure Insert_Post
+ (T : in out Tree_Type'Class;
+ Y : Count_Type;
+ B : Boolean;
+ Z : out Count_Type);
+
+ procedure Generic_Conditional_Insert
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+ -- Inserts a new node in Tree, but only if the tree does not already
+ -- contain Key. Generic_Conditional_Insert first searches for a key
+ -- equivalent to Key in Tree. If an equivalent key is found, then on
+ -- output Node designates the node with that key and Inserted is
+ -- False; there is no allocation and Tree is not modified. Otherwise
+ -- Node designates a new node allocated using Insert_Post, and
+ -- Inserted is True.
+
+ generic
+ with procedure Insert_Post
+ (T : in out Tree_Type'Class;
+ Y : Count_Type;
+ B : Boolean;
+ Z : out Count_Type);
+
+ procedure Generic_Unconditional_Insert
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type);
+ -- Inserts a new node in Tree. On output Node designates the new
+ -- node, which is allocated using Insert_Post. The node is inserted
+ -- immediately after already-existing equivalent keys.
+
+ generic
+ with procedure Insert_Post
+ (T : in out Tree_Type'Class;
+ Y : Count_Type;
+ B : Boolean;
+ Z : out Count_Type);
+
+ with procedure Unconditional_Insert_Sans_Hint
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type);
+
+ procedure Generic_Unconditional_Insert_With_Hint
+ (Tree : in out Tree_Type'Class;
+ Hint : Count_Type;
+ Key : Key_Type;
+ Node : out Count_Type);
+ -- Inserts a new node in Tree near position Hint, to avoid having to
+ -- search from the root for the insertion position. If Hint is 0
+ -- then Generic_Unconditional_Insert_With_Hint attempts to insert
+ -- the new node after Tree.Last. If Hint is non-zero then if Key is
+ -- less than Hint, it attempts to insert the new node immediately
+ -- prior to Hint. Otherwise it attempts to insert the node
+ -- immediately following Hint. We say "attempts" above to emphasize
+ -- that insertions always preserve invariants with respect to key
+ -- order, even when there's a hint. So if Key can't be inserted
+ -- immediately near Hint, then the new node is inserted in the
+ -- normal way, by searching for the correct position starting from
+ -- the root.
+
+ generic
+ with procedure Insert_Post
+ (T : in out Tree_Type'Class;
+ Y : Count_Type;
+ B : Boolean;
+ Z : out Count_Type);
+
+ with procedure Conditional_Insert_Sans_Hint
+ (Tree : in out Tree_Type'Class;
+ Key : Key_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+
+ procedure Generic_Conditional_Insert_With_Hint
+ (Tree : in out Tree_Type'Class;
+ Position : Count_Type; -- the hint
+ Key : Key_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+ -- Inserts a new node in Tree if the tree does not already contain
+ -- Key, using Position as a hint about where to insert the new node.
+ -- See Generic_Unconditional_Insert_With_Hint for more details about
+ -- hint semantics.
+
+ function Find
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type;
+ -- Searches Tree for the smallest node equivalent to Key
+
+ function Ceiling
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type;
+ -- Searches Tree for the smallest node equal to or greater than Key
+
+ function Floor
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type;
+ -- Searches Tree for the largest node less than or equal to Key
+
+ function Upper_Bound
+ (Tree : Tree_Type'Class;
+ Key : Key_Type) return Count_Type;
+ -- Searches Tree for the smallest node greater than Key
+
+ generic
+ with procedure Process (Index : Count_Type);
+ procedure Generic_Iteration
+ (Tree : Tree_Type'Class;
+ Key : Key_Type);
+ -- Calls Process for each node in Tree equivalent to Key, in order
+ -- from earliest in range to latest.
+
+ generic
+ with procedure Process (Index : Count_Type);
+ procedure Generic_Reverse_Iteration
+ (Tree : Tree_Type'Class;
+ Key : Key_Type);
+ -- Calls Process for each node in Tree equivalent to Key, but in
+ -- order from largest in range to earliest.
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+------------------------------------------------------------------------------
+
+-- The references below to "CLR" refer to the following book, from which
+-- several of the algorithms here were adapted:
+-- Introduction to Algorithms
+-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
+-- Publisher: The MIT Press (June 18, 1990)
+-- ISBN: 0262031418
+
+with System; use type System.Address;
+
+package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
+ procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
+
+ procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type);
+ procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
+
+ ----------------
+ -- Clear_Tree --
+ ----------------
+
+ procedure Clear_Tree (Tree : in out Tree_Type'Class) is
+ begin
+ if Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Tree.First := 0;
+ Tree.Last := 0;
+ Tree.Root := 0;
+ Tree.Length := 0;
+ -- Tree.Busy
+ -- Tree.Lock
+ Tree.Free := -1;
+ end Clear_Tree;
+
+ ------------------
+ -- Delete_Fixup --
+ ------------------
+
+ procedure Delete_Fixup
+ (Tree : in out Tree_Type'Class;
+ Node : Count_Type)
+ is
+
+ -- CLR p274
+
+ X : Count_Type;
+ W : Count_Type;
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ X := Node;
+ while X /= Tree.Root
+ and then Color (N (X)) = Black
+ loop
+ if X = Left (N (Parent (N (X)))) then
+ W := Right (N (Parent (N (X))));
+
+ if Color (N (W)) = Red then
+ Set_Color (N (W), Black);
+ Set_Color (N (Parent (N (X))), Red);
+ Left_Rotate (Tree, Parent (N (X)));
+ W := Right (N (Parent (N (X))));
+ end if;
+
+ if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
+ and then
+ (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
+ then
+ Set_Color (N (W), Red);
+ X := Parent (N (X));
+
+ else
+ if Right (N (W)) = 0
+ or else Color (N (Right (N (W)))) = Black
+ then
+ -- As a condition for setting the color of the left child to
+ -- black, the left child access value must be non-null. A
+ -- truth table analysis shows that if we arrive here, that
+ -- condition holds, so there's no need for an explicit test.
+ -- The assertion is here to document what we know is true.
+
+ pragma Assert (Left (N (W)) /= 0);
+ Set_Color (N (Left (N (W))), Black);
+
+ Set_Color (N (W), Red);
+ Right_Rotate (Tree, W);
+ W := Right (N (Parent (N (X))));
+ end if;
+
+ Set_Color (N (W), Color (N (Parent (N (X)))));
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Right (N (W))), Black);
+ Left_Rotate (Tree, Parent (N (X)));
+ X := Tree.Root;
+ end if;
+
+ else
+ pragma Assert (X = Right (N (Parent (N (X)))));
+
+ W := Left (N (Parent (N (X))));
+
+ if Color (N (W)) = Red then
+ Set_Color (N (W), Black);
+ Set_Color (N (Parent (N (X))), Red);
+ Right_Rotate (Tree, Parent (N (X)));
+ W := Left (N (Parent (N (X))));
+ end if;
+
+ if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
+ and then
+ (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
+ then
+ Set_Color (N (W), Red);
+ X := Parent (N (X));
+
+ else
+ if Left (N (W)) = 0
+ or else Color (N (Left (N (W)))) = Black
+ then
+ -- As a condition for setting the color of the right child
+ -- to black, the right child access value must be non-null.
+ -- A truth table analysis shows that if we arrive here, that
+ -- condition holds, so there's no need for an explicit test.
+ -- The assertion is here to document what we know is true.
+
+ pragma Assert (Right (N (W)) /= 0);
+ Set_Color (N (Right (N (W))), Black);
+
+ Set_Color (N (W), Red);
+ Left_Rotate (Tree, W);
+ W := Left (N (Parent (N (X))));
+ end if;
+
+ Set_Color (N (W), Color (N (Parent (N (X)))));
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Left (N (W))), Black);
+ Right_Rotate (Tree, Parent (N (X)));
+ X := Tree.Root;
+ end if;
+ end if;
+ end loop;
+
+ Set_Color (N (X), Black);
+ end Delete_Fixup;
+
+ ---------------------------
+ -- Delete_Node_Sans_Free --
+ ---------------------------
+
+ procedure Delete_Node_Sans_Free
+ (Tree : in out Tree_Type'Class;
+ Node : Count_Type)
+ is
+ -- CLR p273
+
+ X, Y : Count_Type;
+
+ Z : constant Count_Type := Node;
+ pragma Assert (Z /= 0);
+
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ if Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ pragma Assert (Tree.Length > 0);
+ pragma Assert (Tree.Root /= 0);
+ pragma Assert (Tree.First /= 0);
+ pragma Assert (Tree.Last /= 0);
+ pragma Assert (Parent (N (Tree.Root)) = 0);
+
+ pragma Assert ((Tree.Length > 1)
+ or else (Tree.First = Tree.Last
+ and then Tree.First = Tree.Root));
+
+ pragma Assert ((Left (N (Node)) = 0)
+ or else (Parent (N (Left (N (Node)))) = Node));
+
+ pragma Assert ((Right (N (Node)) = 0)
+ or else (Parent (N (Right (N (Node)))) = Node));
+
+ pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
+ or else ((Parent (N (Node)) /= 0) and then
+ ((Left (N (Parent (N (Node)))) = Node)
+ or else
+ (Right (N (Parent (N (Node)))) = Node))));
+
+ if Left (N (Z)) = 0 then
+ if Right (N (Z)) = 0 then
+ if Z = Tree.First then
+ Tree.First := Parent (N (Z));
+ end if;
+
+ if Z = Tree.Last then
+ Tree.Last := Parent (N (Z));
+ end if;
+
+ if Color (N (Z)) = Black then
+ Delete_Fixup (Tree, Z);
+ end if;
+
+ pragma Assert (Left (N (Z)) = 0);
+ pragma Assert (Right (N (Z)) = 0);
+
+ if Z = Tree.Root then
+ pragma Assert (Tree.Length = 1);
+ pragma Assert (Parent (N (Z)) = 0);
+ Tree.Root := 0;
+ elsif Z = Left (N (Parent (N (Z)))) then
+ Set_Left (N (Parent (N (Z))), 0);
+ else
+ pragma Assert (Z = Right (N (Parent (N (Z)))));
+ Set_Right (N (Parent (N (Z))), 0);
+ end if;
+
+ else
+ pragma Assert (Z /= Tree.Last);
+
+ X := Right (N (Z));
+
+ if Z = Tree.First then
+ Tree.First := Min (Tree, X);
+ end if;
+
+ if Z = Tree.Root then
+ Tree.Root := X;
+ elsif Z = Left (N (Parent (N (Z)))) then
+ Set_Left (N (Parent (N (Z))), X);
+ else
+ pragma Assert (Z = Right (N (Parent (N (Z)))));
+ Set_Right (N (Parent (N (Z))), X);
+ end if;
+
+ Set_Parent (N (X), Parent (N (Z)));
+
+ if Color (N (Z)) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+ end if;
+
+ elsif Right (N (Z)) = 0 then
+ pragma Assert (Z /= Tree.First);
+
+ X := Left (N (Z));
+
+ if Z = Tree.Last then
+ Tree.Last := Max (Tree, X);
+ end if;
+
+ if Z = Tree.Root then
+ Tree.Root := X;
+ elsif Z = Left (N (Parent (N (Z)))) then
+ Set_Left (N (Parent (N (Z))), X);
+ else
+ pragma Assert (Z = Right (N (Parent (N (Z)))));
+ Set_Right (N (Parent (N (Z))), X);
+ end if;
+
+ Set_Parent (N (X), Parent (N (Z)));
+
+ if Color (N (Z)) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+
+ else
+ pragma Assert (Z /= Tree.First);
+ pragma Assert (Z /= Tree.Last);
+
+ Y := Next (Tree, Z);
+ pragma Assert (Left (N (Y)) = 0);
+
+ X := Right (N (Y));
+
+ if X = 0 then
+ if Y = Left (N (Parent (N (Y)))) then
+ pragma Assert (Parent (N (Y)) /= Z);
+ Delete_Swap (Tree, Z, Y);
+ Set_Left (N (Parent (N (Z))), Z);
+
+ else
+ pragma Assert (Y = Right (N (Parent (N (Y)))));
+ pragma Assert (Parent (N (Y)) = Z);
+ Set_Parent (N (Y), Parent (N (Z)));
+
+ if Z = Tree.Root then
+ Tree.Root := Y;
+ elsif Z = Left (N (Parent (N (Z)))) then
+ Set_Left (N (Parent (N (Z))), Y);
+ else
+ pragma Assert (Z = Right (N (Parent (N (Z)))));
+ Set_Right (N (Parent (N (Z))), Y);
+ end if;
+
+ Set_Left (N (Y), Z);
+ Set_Parent (N (Left (N (Y))), Y);
+ Set_Right (N (Y), Z);
+ Set_Parent (N (Z), Y);
+ Set_Left (N (Z), 0);
+ Set_Right (N (Z), 0);
+
+ declare
+ Y_Color : constant Color_Type := Color (N (Y));
+ begin
+ Set_Color (N (Y), Color (N (Z)));
+ Set_Color (N (Z), Y_Color);
+ end;
+ end if;
+
+ if Color (N (Z)) = Black then
+ Delete_Fixup (Tree, Z);
+ end if;
+
+ pragma Assert (Left (N (Z)) = 0);
+ pragma Assert (Right (N (Z)) = 0);
+
+ if Z = Right (N (Parent (N (Z)))) then
+ Set_Right (N (Parent (N (Z))), 0);
+ else
+ pragma Assert (Z = Left (N (Parent (N (Z)))));
+ Set_Left (N (Parent (N (Z))), 0);
+ end if;
+
+ else
+ if Y = Left (N (Parent (N (Y)))) then
+ pragma Assert (Parent (N (Y)) /= Z);
+
+ Delete_Swap (Tree, Z, Y);
+
+ Set_Left (N (Parent (N (Z))), X);
+ Set_Parent (N (X), Parent (N (Z)));
+
+ else
+ pragma Assert (Y = Right (N (Parent (N (Y)))));
+ pragma Assert (Parent (N (Y)) = Z);
+
+ Set_Parent (N (Y), Parent (N (Z)));
+
+ if Z = Tree.Root then
+ Tree.Root := Y;
+ elsif Z = Left (N (Parent (N (Z)))) then
+ Set_Left (N (Parent (N (Z))), Y);
+ else
+ pragma Assert (Z = Right (N (Parent (N (Z)))));
+ Set_Right (N (Parent (N (Z))), Y);
+ end if;
+
+ Set_Left (N (Y), Left (N (Z)));
+ Set_Parent (N (Left (N (Y))), Y);
+
+ declare
+ Y_Color : constant Color_Type := Color (N (Y));
+ begin
+ Set_Color (N (Y), Color (N (Z)));
+ Set_Color (N (Z), Y_Color);
+ end;
+ end if;
+
+ if Color (N (Z)) = Black then
+ Delete_Fixup (Tree, X);
+ end if;
+ end if;
+ end if;
+
+ Tree.Length := Tree.Length - 1;
+ end Delete_Node_Sans_Free;
+
+ -----------------
+ -- Delete_Swap --
+ -----------------
+
+ procedure Delete_Swap
+ (Tree : in out Tree_Type'Class;
+ Z, Y : Count_Type)
+ is
+ N : Nodes_Type renames Tree.Nodes;
+
+ pragma Assert (Z /= Y);
+ pragma Assert (Parent (N (Y)) /= Z);
+
+ Y_Parent : constant Count_Type := Parent (N (Y));
+ Y_Color : constant Color_Type := Color (N (Y));
+
+ begin
+ Set_Parent (N (Y), Parent (N (Z)));
+ Set_Left (N (Y), Left (N (Z)));
+ Set_Right (N (Y), Right (N (Z)));
+ Set_Color (N (Y), Color (N (Z)));
+
+ if Tree.Root = Z then
+ Tree.Root := Y;
+ elsif Right (N (Parent (N (Y)))) = Z then
+ Set_Right (N (Parent (N (Y))), Y);
+ else
+ pragma Assert (Left (N (Parent (N (Y)))) = Z);
+ Set_Left (N (Parent (N (Y))), Y);
+ end if;
+
+ if Right (N (Y)) /= 0 then
+ Set_Parent (N (Right (N (Y))), Y);
+ end if;
+
+ if Left (N (Y)) /= 0 then
+ Set_Parent (N (Left (N (Y))), Y);
+ end if;
+
+ Set_Parent (N (Z), Y_Parent);
+ Set_Color (N (Z), Y_Color);
+ Set_Left (N (Z), 0);
+ Set_Right (N (Z), 0);
+ end Delete_Swap;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
+ pragma Assert (X > 0);
+ pragma Assert (X <= Tree.Capacity);
+
+ N : Nodes_Type renames Tree.Nodes;
+ -- pragma Assert (N (X).Prev >= 0); -- node is active
+ -- Find a way to mark a node as active vs. inactive; we could
+ -- use a special value in Color_Type for this. ???
+
+ begin
+ -- The set container actually contains two data structures: a list for
+ -- the "active" nodes that contain elements that have been inserted
+ -- onto the tree, and another for the "inactive" nodes of the free
+ -- store.
+ --
+ -- We desire that merely declaring an object should have only minimal
+ -- cost; specially, we want to avoid having to initialize the free
+ -- store (to fill in the links), especially if the capacity is large.
+ --
+ -- The head of the free list is indicated by Container.Free. If its
+ -- value is non-negative, then the free store has been initialized
+ -- in the "normal" way: Container.Free points to the head of the list
+ -- of free (inactive) nodes, and the value 0 means the free list is
+ -- empty. Each node on the free list has been initialized to point
+ -- to the next free node (via its Parent component), and the value 0
+ -- means that this is the last free node.
+ --
+ -- If Container.Free is negative, then the links on the free store
+ -- have not been initialized. In this case the link values are
+ -- implied: the free store comprises the components of the node array
+ -- started with the absolute value of Container.Free, and continuing
+ -- until the end of the array (Nodes'Last).
+ --
+ -- ???
+ -- It might be possible to perform an optimization here. Suppose that
+ -- the free store can be represented as having two parts: one
+ -- comprising the non-contiguous inactive nodes linked together
+ -- in the normal way, and the other comprising the contiguous
+ -- inactive nodes (that are not linked together, at the end of the
+ -- nodes array). This would allow us to never have to initialize
+ -- the free store, except in a lazy way as nodes become inactive.
+
+ -- When an element is deleted from the list container, its node
+ -- becomes inactive, and so we set its Prev component to a negative
+ -- value, to indicate that it is now inactive. This provides a useful
+ -- way to detect a dangling cursor reference.
+
+ -- The comment above is incorrect; we need some other way to
+ -- indicate a node is inactive, for example by using a special
+ -- Color_Type value. ???
+ -- N (X).Prev := -1; -- Node is deallocated (not on active list)
+
+ if Tree.Free >= 0 then
+ -- The free store has previously been initialized. All we need to
+ -- do here is link the newly-free'd node onto the free list.
+
+ Set_Parent (N (X), Tree.Free);
+ Tree.Free := X;
+
+ elsif X + 1 = abs Tree.Free then
+ -- The free store has not been initialized, and the node becoming
+ -- inactive immediately precedes the start of the free store. All
+ -- we need to do is move the start of the free store back by one.
+
+ Tree.Free := Tree.Free + 1;
+
+ else
+ -- The free store has not been initialized, and the node becoming
+ -- inactive does not immediately precede the free store. Here we
+ -- first initialize the free store (meaning the links are given
+ -- values in the traditional way), and then link the newly-free'd
+ -- node onto the head of the free store.
+
+ -- ???
+ -- See the comments above for an optimization opportunity. If
+ -- the next link for a node on the free store is negative, then
+ -- this means the remaining nodes on the free store are
+ -- physically contiguous, starting as the absolute value of
+ -- that index value.
+
+ Tree.Free := abs Tree.Free;
+
+ if Tree.Free > Tree.Capacity then
+ Tree.Free := 0;
+
+ else
+ for I in Tree.Free .. Tree.Capacity - 1 loop
+ Set_Parent (N (I), I + 1);
+ end loop;
+
+ Set_Parent (N (Tree.Capacity), 0);
+ end if;
+
+ Set_Parent (N (X), Tree.Free);
+ Tree.Free := X;
+ end if;
+ end Free;
+
+ -----------------------
+ -- Generic_Allocate --
+ -----------------------
+
+ procedure Generic_Allocate
+ (Tree : in out Tree_Type'Class;
+ Node : out Count_Type)
+ is
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ if Tree.Free >= 0 then
+ Node := Tree.Free;
+
+ -- We always perform the assignment first, before we
+ -- change container state, in order to defend against
+ -- exceptions duration assignment.
+
+ Set_Element (N (Node));
+ Tree.Free := Parent (N (Node));
+
+ else
+ -- A negative free store value means that the links of the nodes
+ -- in the free store have not been initialized. In this case, the
+ -- nodes are physically contiguous in the array, starting at the
+ -- index that is the absolute value of the Container.Free, and
+ -- continuing until the end of the array (Nodes'Last).
+
+ Node := abs Tree.Free;
+
+ -- As above, we perform this assignment first, before modifying
+ -- any container state.
+
+ Set_Element (N (Node));
+ Tree.Free := Tree.Free - 1;
+ end if;
+ end Generic_Allocate;
+
+ -------------------
+ -- Generic_Equal --
+ -------------------
+
+ function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
+ L_Node : Count_Type;
+ R_Node : Count_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ if Left.Length /= Right.Length then
+ return False;
+ end if;
+
+ 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;
+ end if;
+
+ L_Node := Next (Left, L_Node);
+ R_Node := Next (Right, R_Node);
+ end loop;
+
+ return True;
+ end Generic_Equal;
+
+ -----------------------
+ -- Generic_Iteration --
+ -----------------------
+
+ procedure Generic_Iteration (Tree : Tree_Type'Class) is
+ procedure Iterate (P : Count_Type);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (P : Count_Type) is
+ X : Count_Type := P;
+ begin
+ while X /= 0 loop
+ Iterate (Left (Tree.Nodes (X)));
+ Process (X);
+ X := Right (Tree.Nodes (X));
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Iteration;
+
+ ------------------
+ -- Generic_Read --
+ ------------------
+
+ procedure Generic_Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Tree : in out Tree_Type'Class)
+ is
+ Len : Count_Type'Base;
+
+ Node, Last_Node : Count_Type;
+
+ N : Nodes_Type renames Tree.Nodes;
+
+ begin
+ Clear_Tree (Tree);
+ Count_Type'Base'Read (Stream, Len);
+
+ if Len < 0 then
+ raise Program_Error with "bad container length (corrupt stream)";
+ end if;
+
+ if Len = 0 then
+ return;
+ end if;
+
+ if Len > Tree.Capacity then
+ raise Constraint_Error with "length exceeds capacity";
+ end if;
+
+ -- Use Unconditional_Insert_With_Hint here instead ???
+
+ Allocate (Tree, Node);
+ pragma Assert (Node /= 0);
+
+ Set_Color (N (Node), Black);
+
+ Tree.Root := Node;
+ Tree.First := Node;
+ Tree.Last := Node;
+ Tree.Length := 1;
+
+ for J in Count_Type range 2 .. Len loop
+ Last_Node := Node;
+ pragma Assert (Last_Node = Tree.Last);
+
+ Allocate (Tree, Node);
+ pragma Assert (Node /= 0);
+
+ Set_Color (N (Node), Red);
+ Set_Right (N (Last_Node), Right => Node);
+ Tree.Last := Node;
+ Set_Parent (N (Node), Parent => Last_Node);
+
+ Rebalance_For_Insert (Tree, Node);
+ Tree.Length := Tree.Length + 1;
+ end loop;
+ end Generic_Read;
+
+ -------------------------------
+ -- Generic_Reverse_Iteration --
+ -------------------------------
+
+ procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
+ procedure Iterate (P : Count_Type);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (P : Count_Type) is
+ X : Count_Type := P;
+ begin
+ while X /= 0 loop
+ Iterate (Right (Tree.Nodes (X)));
+ Process (X);
+ X := Left (Tree.Nodes (X));
+ end loop;
+ end Iterate;
+
+ -- Start of processing for Generic_Reverse_Iteration
+
+ begin
+ Iterate (Tree.Root);
+ end Generic_Reverse_Iteration;
+
+ -------------------
+ -- Generic_Write --
+ -------------------
+
+ procedure Generic_Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Tree : Tree_Type'Class)
+ is
+ procedure Process (Node : Count_Type);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Count_Type) is
+ begin
+ Write_Node (Stream, Tree.Nodes (Node));
+ end Process;
+
+ -- Start of processing for Generic_Write
+
+ begin
+ Count_Type'Base'Write (Stream, Tree.Length);
+ Iterate (Tree);
+ end Generic_Write;
+
+ -----------------
+ -- Left_Rotate --
+ -----------------
+
+ procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
+ -- CLR p266
+
+ N : Nodes_Type renames Tree.Nodes;
+
+ Y : constant Count_Type := Right (N (X));
+ pragma Assert (Y /= 0);
+
+ begin
+ Set_Right (N (X), Left (N (Y)));
+
+ if Left (N (Y)) /= 0 then
+ Set_Parent (N (Left (N (Y))), X);
+ end if;
+
+ Set_Parent (N (Y), Parent (N (X)));
+
+ if X = Tree.Root then
+ Tree.Root := Y;
+ elsif X = Left (N (Parent (N (X)))) then
+ Set_Left (N (Parent (N (X))), Y);
+ else
+ pragma Assert (X = Right (N (Parent (N (X)))));
+ Set_Right (N (Parent (N (X))), Y);
+ end if;
+
+ Set_Left (N (Y), X);
+ Set_Parent (N (X), Y);
+ end Left_Rotate;
+
+ ---------
+ -- Max --
+ ---------
+
+ function Max
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type
+ is
+ -- CLR p248
+
+ X : Count_Type := Node;
+ Y : Count_Type;
+
+ begin
+ loop
+ Y := Right (Tree.Nodes (X));
+
+ if Y = 0 then
+ return X;
+ end if;
+
+ X := Y;
+ end loop;
+ end Max;
+
+ ---------
+ -- Min --
+ ---------
+
+ function Min
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type
+ is
+ -- CLR p248
+
+ X : Count_Type := Node;
+ Y : Count_Type;
+
+ begin
+ loop
+ Y := Left (Tree.Nodes (X));
+
+ if Y = 0 then
+ return X;
+ end if;
+
+ X := Y;
+ end loop;
+ end Min;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type
+ is
+ begin
+ -- CLR p249
+
+ if Node = 0 then
+ return 0;
+ end if;
+
+ if Right (Tree.Nodes (Node)) /= 0 then
+ return Min (Tree, Right (Tree.Nodes (Node)));
+ end if;
+
+ declare
+ X : Count_Type := Node;
+ Y : Count_Type := Parent (Tree.Nodes (Node));
+
+ begin
+ while Y /= 0
+ and then X = Right (Tree.Nodes (Y))
+ loop
+ X := Y;
+ Y := Parent (Tree.Nodes (Y));
+ end loop;
+
+ return Y;
+ end;
+ end Next;
+
+ --------------
+ -- Previous --
+ --------------
+
+ function Previous
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type
+ is
+ begin
+ if Node = 0 then
+ return 0;
+ end if;
+
+ if Left (Tree.Nodes (Node)) /= 0 then
+ return Max (Tree, Left (Tree.Nodes (Node)));
+ end if;
+
+ declare
+ X : Count_Type := Node;
+ Y : Count_Type := Parent (Tree.Nodes (Node));
+
+ begin
+ while Y /= 0
+ and then X = Left (Tree.Nodes (Y))
+ loop
+ X := Y;
+ Y := Parent (Tree.Nodes (Y));
+ end loop;
+
+ return Y;
+ end;
+ end Previous;
+
+ --------------------------
+ -- Rebalance_For_Insert --
+ --------------------------
+
+ procedure Rebalance_For_Insert
+ (Tree : in out Tree_Type'Class;
+ Node : Count_Type)
+ is
+ -- CLR p.268
+
+ N : Nodes_Type renames Tree.Nodes;
+
+ X : Count_Type := Node;
+ pragma Assert (X /= 0);
+ pragma Assert (Color (N (X)) = Red);
+
+ Y : Count_Type;
+
+ begin
+ while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
+ if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
+ Y := Right (N (Parent (N (Parent (N (X))))));
+
+ if Y /= 0 and then Color (N (Y)) = Red then
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Y), Black);
+ Set_Color (N (Parent (N (Parent (N (X))))), Red);
+ X := Parent (N (Parent (N (X))));
+
+ else
+ if X = Right (N (Parent (N (X)))) then
+ X := Parent (N (X));
+ Left_Rotate (Tree, X);
+ end if;
+
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Parent (N (Parent (N (X))))), Red);
+ Right_Rotate (Tree, Parent (N (Parent (N (X)))));
+ end if;
+
+ else
+ pragma Assert (Parent (N (X)) =
+ Right (N (Parent (N (Parent (N (X)))))));
+
+ Y := Left (N (Parent (N (Parent (N (X))))));
+
+ if Y /= 0 and then Color (N (Y)) = Red then
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Y), Black);
+ Set_Color (N (Parent (N (Parent (N (X))))), Red);
+ X := Parent (N (Parent (N (X))));
+
+ else
+ if X = Left (N (Parent (N (X)))) then
+ X := Parent (N (X));
+ Right_Rotate (Tree, X);
+ end if;
+
+ Set_Color (N (Parent (N (X))), Black);
+ Set_Color (N (Parent (N (Parent (N (X))))), Red);
+ Left_Rotate (Tree, Parent (N (Parent (N (X)))));
+ end if;
+ end if;
+ end loop;
+
+ Set_Color (N (Tree.Root), Black);
+ end Rebalance_For_Insert;
+
+ ------------------
+ -- Right_Rotate --
+ ------------------
+
+ procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
+ N : Nodes_Type renames Tree.Nodes;
+
+ X : constant Count_Type := Left (N (Y));
+ pragma Assert (X /= 0);
+
+ begin
+ Set_Left (N (Y), Right (N (X)));
+
+ if Right (N (X)) /= 0 then
+ Set_Parent (N (Right (N (X))), Y);
+ end if;
+
+ Set_Parent (N (X), Parent (N (Y)));
+
+ if Y = Tree.Root then
+ Tree.Root := X;
+ elsif Y = Left (N (Parent (N (Y)))) then
+ Set_Left (N (Parent (N (Y))), X);
+ else
+ pragma Assert (Y = Right (N (Parent (N (Y)))));
+ Set_Right (N (Parent (N (Y))), X);
+ end if;
+
+ Set_Right (N (X), Y);
+ Set_Parent (N (Y), X);
+ end Right_Rotate;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
+ Nodes : Nodes_Type renames Tree.Nodes;
+ Node : Node_Type renames Nodes (Index);
+
+ begin
+ if Parent (Node) = Index
+ or else Left (Node) = Index
+ or else Right (Node) = Index
+ then
+ return False;
+ end if;
+
+ if Tree.Length = 0
+ or else Tree.Root = 0
+ or else Tree.First = 0
+ or else Tree.Last = 0
+ then
+ return False;
+ end if;
+
+ if Parent (Nodes (Tree.Root)) /= 0 then
+ return False;
+ end if;
+
+ if Left (Nodes (Tree.First)) /= 0 then
+ return False;
+ end if;
+
+ if Right (Nodes (Tree.Last)) /= 0 then
+ return False;
+ end if;
+
+ if Tree.Length = 1 then
+ if Tree.First /= Tree.Last
+ or else Tree.First /= Tree.Root
+ then
+ return False;
+ end if;
+
+ if Index /= Tree.First then
+ return False;
+ end if;
+
+ if Parent (Node) /= 0
+ or else Left (Node) /= 0
+ or else Right (Node) /= 0
+ then
+ return False;
+ end if;
+
+ return True;
+ end if;
+
+ if Tree.First = Tree.Last then
+ return False;
+ end if;
+
+ if Tree.Length = 2 then
+ if Tree.First /= Tree.Root
+ and then Tree.Last /= Tree.Root
+ then
+ return False;
+ end if;
+
+ if Tree.First /= Index
+ and then Tree.Last /= Index
+ then
+ return False;
+ end if;
+ end if;
+
+ if Left (Node) /= 0
+ and then Parent (Nodes (Left (Node))) /= Index
+ then
+ return False;
+ end if;
+
+ if Right (Node) /= 0
+ and then Parent (Nodes (Right (Node))) /= Index
+ then
+ return False;
+ end if;
+
+ if Parent (Node) = 0 then
+ if Tree.Root /= Index then
+ return False;
+ end if;
+
+ elsif Left (Nodes (Parent (Node))) /= Index
+ and then Right (Nodes (Parent (Node))) /= Index
+ then
+ return False;
+ end if;
+
+ return True;
+ end Vet;
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2010, 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. --
+------------------------------------------------------------------------------
+
+-- Tree_Type is used to implement the ordered containers. This package
+-- declares the tree operations that do not depend on keys.
+
+with Ada.Streams; use Ada.Streams;
+
+generic
+ with package Tree_Types is new Generic_Bounded_Tree_Types (<>);
+ use Tree_Types;
+
+ with function Parent (Node : Node_Type) return Count_Type is <>;
+
+ with procedure Set_Parent
+ (Node : in out Node_Type;
+ Parent : Count_Type) is <>;
+
+ with function Left (Node : Node_Type) return Count_Type is <>;
+
+ with procedure Set_Left
+ (Node : in out Node_Type;
+ Left : Count_Type) is <>;
+
+ with function Right (Node : Node_Type) return Count_Type is <>;
+
+ with procedure Set_Right
+ (Node : in out Node_Type;
+ Right : Count_Type) is <>;
+
+ with function Color (Node : Node_Type) return Color_Type is <>;
+
+ with procedure Set_Color
+ (Node : in out Node_Type;
+ Color : Color_Type) is <>;
+
+package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
+ pragma Pure;
+
+ function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type;
+ -- Returns the smallest-valued node of the subtree rooted at Node
+
+ function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type;
+ -- Returns the largest-valued node of the subtree rooted at Node
+
+ function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean;
+ -- Inspects Node to determine (to the extent possible) whether
+ -- the node is valid; used to detect if the node is dangling.
+
+ function Next
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type;
+ -- Returns the smallest node greater than Node
+
+ function Previous
+ (Tree : Tree_Type'Class;
+ Node : Count_Type) return Count_Type;
+ -- Returns the largest node less than Node
+
+ generic
+ with function Is_Equal (L, R : Node_Type) return Boolean;
+ function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean;
+ -- Uses Is_Equal to perform a node-by-node comparison of the
+ -- Left and Right trees; processing stops as soon as the first
+ -- non-equal node is found.
+
+ procedure Delete_Node_Sans_Free
+ (Tree : in out Tree_Type'Class; Node : Count_Type);
+ -- Removes Node from Tree without deallocating the node. If Tree
+ -- is busy then Program_Error is raised.
+
+ procedure Clear_Tree (Tree : in out Tree_Type'Class);
+ -- Clears Tree by deallocating all of its nodes. If Tree is busy then
+ -- Program_Error is raised.
+
+ generic
+ with procedure Process (Node : Count_Type) is <>;
+ procedure Generic_Iteration (Tree : Tree_Type'Class);
+ -- Calls Process for each node in Tree, in order from smallest-valued
+ -- node to largest-valued node.
+
+ generic
+ with procedure Process (Node : Count_Type) is <>;
+ procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class);
+ -- Calls Process for each node in Tree, in order from largest-valued
+ -- node to smallest-valued node.
+
+ generic
+ with procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ procedure Generic_Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Tree : Tree_Type'Class);
+ -- Used to implement stream attribute T'Write. Generic_Write
+ -- first writes the number of nodes into Stream, then calls
+ -- Write_Node for each node in Tree.
+
+ generic
+ with procedure Allocate
+ (Tree : in out Tree_Type'Class;
+ Node : out Count_Type);
+ procedure Generic_Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Tree : in out Tree_Type'Class);
+ -- Used to implement stream attribute T'Read. Generic_Read
+ -- first clears Tree. It then reads the number of nodes out of
+ -- Stream, and calls Read_Node for each node in Stream.
+
+ procedure Rebalance_For_Insert
+ (Tree : in out Tree_Type'Class;
+ Node : Count_Type);
+ -- This rebalances Tree to complete the insertion of Node (which
+ -- must already be linked in at its proper insertion position).
+
+ generic
+ with procedure Set_Element (Node : in out Node_Type);
+ procedure Generic_Allocate
+ (Tree : in out Tree_Type'Class;
+ Node : out Count_Type);
+ -- Claim a node from the free store. Generic_Allocate first
+ -- calls Set_Element on the potential node, and then returns
+ -- the node's index as the value of the Node parameter.
+
+ procedure Free (Tree : in out Tree_Type'Class; X : Count_Type);
+ -- Return a node back to the free store, from where it had
+ -- been previously claimed via Generic_Allocate.
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
either case. */
attr->file_length = statbuf.st_size; /* all systems */
-#ifndef __MINGW32__
- /* on Windows requires extra system call, see comment in
- __gnat_file_exists_attr */
attr->exists = !ret;
-#endif
#if !defined (_WIN32) || defined (RTX)
/* on Windows requires extra system call, see __gnat_is_readable_file_attr */
}
/* As above but starting from a FILETIME. */
-static void f2t (const FILETIME *ft, time_t *t)
+static void
+f2t (const FILETIME *ft, time_t *t)
{
union
{
{
if (attr->timestamp == (OS_Time)-2) {
#if defined (_WIN32) && !defined (RTX)
+ BOOL res;
+ WIN32_FILE_ATTRIBUTE_DATA fad;
time_t ret = -1;
TCHAR wname[GNAT_MAX_PATH_LEN];
S2WSC (wname, name, GNAT_MAX_PATH_LEN);
- HANDLE h = CreateFile
- (wname, GENERIC_READ, FILE_SHARE_READ, 0,
- OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
-
- if (h != INVALID_HANDLE_VALUE) {
- ret = win32_filetime (h);
- CloseHandle (h);
- }
+ if (res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad))
+ f2t (&fad.ftLastWriteTime, &ret);
attr->timestamp = (OS_Time) ret;
#else
__gnat_stat_to_attr (-1, name, attr);
if (res == FALSE)
switch (GetLastError()) {
- case ERROR_ACCESS_DENIED:
- case ERROR_SHARING_VIOLATION:
- case ERROR_LOCK_VIOLATION:
- case ERROR_SHARING_BUFFER_EXCEEDED:
- return EACCES;
- case ERROR_BUFFER_OVERFLOW:
- return ENAMETOOLONG;
- case ERROR_NOT_ENOUGH_MEMORY:
- return ENOMEM;
- default:
- return ENOENT;
+ case ERROR_ACCESS_DENIED:
+ case ERROR_SHARING_VIOLATION:
+ case ERROR_LOCK_VIOLATION:
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ return EACCES;
+ case ERROR_BUFFER_OVERFLOW:
+ return ENAMETOOLONG;
+ case ERROR_NOT_ENOUGH_MEMORY:
+ return ENOMEM;
+ default:
+ return ENOENT;
}
f2t (&fad.ftCreationTime, &statbuf->st_ctime);
__gnat_file_exists_attr (char* name, struct file_attributes* attr)
{
if (attr->exists == ATTR_UNSET) {
-#ifdef __MINGW32__
- /* On Windows do not use __gnat_stat() because of a bug in Microsoft
- _stat() routine. When the system time-zone is set with a negative
- offset the _stat() routine fails on specific files like CON: */
- TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
- attr->exists = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
-#else
__gnat_stat_to_attr (-1, name, attr);
-#endif
}
return attr->exists;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
-- In either case, this means stubs cannot contain a default-initialized
-- object declaration of such type.
- procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id);
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
-- Add calling stubs to the declarative part
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- since this require separate mechanisms ('Input is a function while
-- 'Read is a procedure).
+ generic
+ with procedure Process_Subprogram_Declaration (Decl : Node_Id);
+ -- Generate calling or receiving stub for this subprogram declaration
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
+ -- Recursively visit the given RCI Package_Specification, calling
+ -- Process_Subprogram_Declaration for each remote subprogram.
+
+ -------------------------
+ -- Build_Package_Stubs --
+ -------------------------
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
+ Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
+ Decl : Node_Id;
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
+ -- Recurse for the given nested package declaration
+
+ -----------------------
+ -- Visit_Nested_Spec --
+ -----------------------
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
+ Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
+ begin
+ Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
+ Build_Package_Stubs (Nested_Pkg_Spec);
+ Pop_Scope;
+ end Visit_Nested_Pkg;
+
+ -- Start of processing for Build_Package_Stubs
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ case Nkind (Decl) is
+ when N_Subprogram_Declaration =>
+
+ -- Note: we test Comes_From_Source on Spec, not Decl, because
+ -- in the case of a subprogram instance, only the specification
+ -- (not the declaration) is marked as coming from source.
+
+ if Comes_From_Source (Specification (Decl)) then
+ Process_Subprogram_Declaration (Decl);
+ end if;
+
+ when N_Package_Declaration =>
+
+ -- Case of a nested package or package instantiation coming
+ -- from source. Note that the anonymous wrapper package for
+ -- subprogram instances is not flagged Is_Generic_Instance at
+ -- this point, so there is a distinct circuit to handle them
+ -- (see case N_Subprogram_Instantiation below).
+
+ declare
+ Pkg_Ent : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Decl));
+ begin
+ if Comes_From_Source (Decl)
+ or else
+ (Is_Generic_Instance (Pkg_Ent)
+ and then Comes_From_Source
+ (Get_Package_Instantiation_Node (Pkg_Ent)))
+ then
+ Visit_Nested_Pkg (Decl);
+ end if;
+ end;
+
+ when N_Subprogram_Instantiation =>
+
+ -- The subprogram declaration for an instance of a generic
+ -- subprogram is wrapped in a package that does not come from
+ -- source, so we need to explicitly traverse it here.
+
+ if Comes_From_Source (Decl) then
+ Visit_Nested_Pkg (Instance_Spec (Decl));
+ end if;
+
+ when others =>
+ null;
+ end case;
+ Next (Decl);
+ end loop;
+ end Build_Package_Stubs;
+
---------------------------------------
-- Add_Calling_Stubs_To_Declarations --
---------------------------------------
- procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id)
- is
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Pkg_Spec);
+
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
- Current_Declaration : Node_Id;
- Loc : constant Source_Ptr := Sloc (Pkg_Spec);
RCI_Instantiation : Node_Id;
- Subp_Stubs : Node_Id;
- Subp_Str : String_Id;
- pragma Warnings (Off, Subp_Str);
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate calling stub for one remote subprogram
+
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Stubs : Node_Id;
+ Subp_Str : String_Id;
+ pragma Warnings (Off, Subp_Str);
+
+ begin
+ Assign_Subprogram_Identifier
+ (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
+
+ Subp_Stubs :=
+ Build_Subprogram_Calling_Stubs (
+ Vis_Decl => Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Defining_Unit_Name (Spec)));
+
+ Append_To (List_Containing (Decl), Subp_Stubs);
+ Analyze (Subp_Stubs);
+
+ Current_Subprogram_Number := Current_Subprogram_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
+ -- Start of processing for Add_Calling_Stubs_To_Declarations
begin
+ Push_Scope (Scope_Of_Spec (Pkg_Spec));
+
-- The first thing added is an instantiation of the generic package
-- System.Partition_Interface.RCI_Locator with the name of this remote
-- package. This will act as an interface with the name server to
RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
- Append_To (Decls, RCI_Instantiation);
+ Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
Analyze (RCI_Instantiation);
-- For each subprogram declaration visible in the spec, we do build a
-- body. We also increment a counter to assign a different Subprogram_Id
- -- to each subprograms. The receiving stubs processing do use the same
+ -- to each subprograms. The receiving stubs processing uses the same
-- mechanism and will thus assign the same Id and do the correct
-- dispatching.
Overload_Counter_Table.Reset;
PolyORB_Support.Reserve_NamingContext_Methods;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- Assign_Subprogram_Identifier
- (Defining_Unit_Name (Specification (Current_Declaration)),
- Current_Subprogram_Number,
- Subp_Str);
-
- Subp_Stubs :=
- Build_Subprogram_Calling_Stubs (
- Vis_Decl => Current_Declaration,
- Subp_Id =>
- Build_Subprogram_Id (Loc,
- Defining_Unit_Name (Specification (Current_Declaration))),
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then
- Is_Asynchronous (Defining_Unit_Name (Specification
- (Current_Declaration))));
-
- Append_To (Decls, Subp_Stubs);
- Analyze (Subp_Stubs);
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
+ Visit_Spec (Pkg_Spec);
- -- Need to handle the case of nested packages???
-
- Next (Current_Declaration);
- end loop;
+ Pop_Scope;
end Add_Calling_Stubs_To_Declarations;
-----------------------------
procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
- Decls : constant List_Id := Visible_Declarations (Spec);
begin
- Push_Scope (Scope_Of_Spec (Spec));
- Add_Calling_Stubs_To_Declarations
- (Specification (Unit_Node), Decls);
- Pop_Scope;
+ Add_Calling_Stubs_To_Declarations (Spec);
end Expand_Calling_Stubs_Bodies;
-----------------------------------
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
+ Lookup_RAS : Node_Id;
Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
-- A remote subprogram is created to allow peers to look up RAS
-- information using subprogram ids.
Subp_Index : Entity_Id;
-- Subprogram_Id as read from the incoming stream
- Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
- Current_Stubs : Node_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
+ Current_Stubs : Node_Id;
Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
Subp_Info_List : constant List_Id := New_List;
-- associating Subprogram_Number with the subprogram declared
-- by Declaration, for which we have receiving stubs in Stubs.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
New_Occurrence_Of (Request_Parameter, Loc))))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+ pragma Warnings (Off, Subp_Val);
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Object_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. This aggregate must be kept consistent
+ -- with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+
+ -- Addr =>
+
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Stubs => Current_Stubs,
+ Subprogram_Number => Current_Subp_Number);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- Build a subprogram for RAS information lookups
- Current_Declaration :=
+ Lookup_RAS :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
Result_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
-
- Append_To (Decls, Current_Declaration);
- Analyze (Current_Declaration);
+ Append_To (Decls, Lookup_RAS);
+ Analyze (Lookup_RAS);
Current_Stubs := Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
+ (Vis_Decl => Lookup_RAS,
Asynchronous => False);
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Stubs =>
- Current_Stubs,
+ Stubs => Current_Stubs,
Subprogram_Number => 1);
-- For each subprogram, the receiving stub will be built and a
Overload_Counter_Table.Reset;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- declare
- Loc : constant Source_Ptr := Sloc (Current_Declaration);
- -- While specifically processing Current_Declaration, use
- -- its Sloc as the location of all generated nodes.
-
- Subp_Def : constant Entity_Id :=
- Defining_Unit_Name
- (Specification (Current_Declaration));
-
- Subp_Val : String_Id;
- pragma Warnings (Off, Subp_Val);
-
- begin
- -- Build receiving stub
-
- Current_Stubs :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
-
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
-
- -- Build RAS proxy
-
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl => Current_Declaration,
- All_Calls_Remote_E => All_Calls_Remote_E,
- Proxy_Object_Addr => Proxy_Object_Addr);
-
- -- Compute distribution identifier
-
- Assign_Subprogram_Identifier
- (Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
-
- pragma Assert
- (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
-
- -- Add subprogram descriptor (RCI_Subp_Info) to the
- -- subprograms table for this receiver. The aggregate
- -- below must be kept consistent with the declaration
- -- of type RCI_Subp_Info in System.Partition_Interface.
-
- Append_To (Subp_Info_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc,
- Current_Subprogram_Number)),
-
- Expression =>
- Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Identifier (Loc, Name_Addr)),
- Expression =>
- New_Occurrence_Of (
- Proxy_Object_Addr, Loc))))));
-
- Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Stubs => Current_Stubs,
- Subprogram_Number => Current_Subprogram_Number);
- end;
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
-
- -- Need to handle case of a nested package???
-
- Next (Current_Declaration);
- end loop;
+ Visit_Spec (Pkg_Spec);
-- If we receive an invalid Subprogram_Id, it is best to do nothing
-- rather than raising an exception since we do not want someone
Dispatch_On_Address : constant List_Id := New_List;
Dispatch_On_Name : constant List_Id := New_List;
- Current_Declaration : Node_Id;
- Current_Stubs : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
-
- Subp_Info_List : constant List_Id := New_List;
+ Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
-- object, used in the context of calls through remote
-- access-to-subprogram types.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
Make_Integer_Literal (Loc, Subp_Number)))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+
+ Subp_Dist_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name
+ (Related_Id => Chars (Subp_Def),
+ Suffix => 'D',
+ Suffix_Index => -1));
+
+ Current_Stubs : Node_Id;
+ Proxy_Obj_Addr : Entity_Id;
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Obj_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert
+ (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Dist_Name,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, Subp_Val)));
+ Analyze (Last (Decls));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. The aggregate below must be kept
+ -- consistent with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+
+ -- Name =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Address),
+
+ -- Name_Length =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Length),
+
+ -- Addr =>
+
+ New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration => Decl,
+ Stubs => Current_Stubs,
+ Subp_Number => Current_Subp_Number,
+ Subp_Dist_Name => Subp_Dist_Name,
+ Subp_Proxy_Addr => Proxy_Obj_Addr);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
Overload_Counter_Table.Reset;
Reserve_NamingContext_Methods;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- declare
- Loc : constant Source_Ptr := Sloc (Current_Declaration);
- -- While specifically processing Current_Declaration, use
- -- its Sloc as the location of all generated nodes.
-
- Subp_Def : constant Entity_Id :=
- Defining_Unit_Name
- (Specification (Current_Declaration));
-
- Subp_Val : String_Id;
-
- Subp_Dist_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name
- (Related_Id => Chars (Subp_Def),
- Suffix => 'D',
- Suffix_Index => -1));
-
- Proxy_Object_Addr : Entity_Id;
-
- begin
- -- Build receiving stub
-
- Current_Stubs :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
-
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
-
- -- Build RAS proxy
-
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl => Current_Declaration,
- All_Calls_Remote_E => All_Calls_Remote_E,
- Proxy_Object_Addr => Proxy_Object_Addr);
-
- -- Compute distribution identifier
-
- Assign_Subprogram_Identifier
- (Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
-
- pragma Assert
- (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Subp_Dist_Name,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc, Subp_Val)));
- Analyze (Last (Decls));
-
- -- Add subprogram descriptor (RCI_Subp_Info) to the
- -- subprograms table for this receiver. The aggregate
- -- below must be kept consistent with the declaration
- -- of type RCI_Subp_Info in System.Partition_Interface.
-
- Append_To (Subp_Info_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc, Current_Subprogram_Number)),
-
- Expression =>
- Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Dist_Name, Loc),
- Attribute_Name => Name_Address),
-
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Dist_Name, Loc),
- Attribute_Name => Name_Length),
-
- New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
-
- Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Declaration => Current_Declaration,
- Stubs => Current_Stubs,
- Subp_Number => Current_Subprogram_Number,
- Subp_Dist_Name => Subp_Dist_Name,
- Subp_Proxy_Addr => Proxy_Object_Addr);
- end;
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
-
- -- Need to handle case of a nested package???
-
- Next (Current_Declaration);
- end loop;
+ Visit_Spec (Pkg_Spec);
Append_To (Decls,
Make_Object_Declaration (Loc,
Non_Imp_File_Names_12 : constant File_List := (
"s-multip", -- System.Multiprocessors
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
- "a-cobove"); -- Ada.Containers.Bounded_Vectors
+ "a-cobove", -- Ada.Containers.Bounded_Vectors
+ "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
+ "a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps
-----------------------
-- Alternative Units --
end if;
end;
- -- If we are generating the calling stubs from the instantiation of
- -- a generic RCI package, we will not use the body of the generic
- -- package.
+ -- If we are generating calling stubs, we never need a body for an
+ -- instantiation from source. However normal processing occurs for
+ -- any generic instantiation appearing in generated code, since we
+ -- do not generate stubs in that case.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
- and then Is_Compilation_Unit (Defining_Entity (N))
+ and then Comes_From_Source (N)
then
Needs_Body := False;
end if;
Check_Formal_Packages (Pack_Id);
Set_Is_Generic_Instance (Pack_Id, False);
+ -- Why do we clear Is_Generic_Instance??? We set it 20 lines
+ -- above???
+
-- Body of the enclosing package is supplied when instantiating the
-- subprogram body, after semantic analysis is completed.
Collect_Primitive_Operations (Parent_Type);
function Check_Derived_Type return Boolean;
- -- Check that all primitive inherited from Parent_Type are found in
+ -- Check that all the entities derived from Parent_Type are found in
-- the list of primitives of Derived_Type exactly in the same order.
+ procedure Derive_Interface_Subprogram
+ (New_Subp : in out Entity_Id;
+ Subp : Entity_Id;
+ Actual_Subp : Entity_Id);
+ -- Derive New_Subp from the ultimate alias of the parent subprogram Subp
+ -- (which is an interface primitive). If Generic_Actual is present then
+ -- Actual_Subp is the actual subprogram corresponding with the generic
+ -- subprogram Subp.
+
function Check_Derived_Type return Boolean is
E : Entity_Id;
Elmt : Elmt_Id;
return True;
end Check_Derived_Type;
+ ---------------------------------
+ -- Derive_Interface_Subprogram --
+ ---------------------------------
+
+ procedure Derive_Interface_Subprogram
+ (New_Subp : in out Entity_Id;
+ Subp : Entity_Id;
+ Actual_Subp : Entity_Id)
+ is
+ Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
+ Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
+
+ begin
+ pragma Assert (Is_Interface (Iface_Type));
+
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Subp,
+ Derived_Type => Derived_Type,
+ Parent_Type => Iface_Type,
+ Actual_Subp => Actual_Subp);
+
+ -- Given that this new interface entity corresponds with a primitive
+ -- of the parent that was not overridden we must leave it associated
+ -- with its parent primitive to ensure that it will share the same
+ -- dispatch table slot when overridden.
+
+ if No (Actual_Subp) then
+ Set_Alias (New_Subp, Subp);
+
+ -- For instantiations this is not needed since the previous call to
+ -- Derive_Subprogram leaves the entity well decorated.
+
+ else
+ pragma Assert (Alias (New_Subp) = Actual_Subp);
+ null;
+ end if;
+ end Derive_Interface_Subprogram;
+
-- Local variables
Alias_Subp : Entity_Id;
Alias_Subp := Ultimate_Alias (Subp);
-- Do not derive internal entities of the parent that link
- -- interface primitives and its covering primitive. These
+ -- interface primitives with their covering primitive. These
-- entities will be added to this type when frozen.
if Present (Interface_Alias (Subp)) then
(Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
and then Null_Present (Parent (Alias_Subp)))
then
- Derive_Subprogram
- (New_Subp => New_Subp,
- Parent_Subp => Alias_Subp,
- Derived_Type => Derived_Type,
- Parent_Type => Find_Dispatching_Type (Alias_Subp),
- Actual_Subp => Act_Subp);
+ -- If this is an abstract private type then we transfer the
+ -- derivation of the interface primitive from the partial view
+ -- to the full view. This is safe because all the interfaces
+ -- must be visible in the partial view. Done to avoid adding
+ -- a new interface derivation to the private part of the
+ -- enclosing package; otherwise this new derivation would be
+ -- decorated as hidden when the analysis of the enclosing
+ -- package completes.
+
+ if Is_Abstract_Type (Derived_Type)
+ and then In_Private_Part (Current_Scope)
+ and then Has_Private_Declaration (Derived_Type)
+ then
+ declare
+ Partial_View : Entity_Id;
+ Elmt : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ Partial_View := First_Entity (Current_Scope);
+ loop
+ exit when No (Partial_View)
+ or else (Has_Private_Declaration (Partial_View)
+ and then
+ Full_View (Partial_View) = Derived_Type);
+
+ Next_Entity (Partial_View);
+ end loop;
+
+ -- If the partial view was not found then the source code
+ -- has errors and the derivation is not needed.
- if No (Generic_Actual) then
- Set_Alias (New_Subp, Subp);
+ if Present (Partial_View) then
+ Elmt :=
+ First_Elmt (Primitive_Operations (Partial_View));
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+
+ if Present (Alias (Ent))
+ and then Ultimate_Alias (Ent) = Alias (Subp)
+ then
+ Append_Elmt
+ (Ent, Primitive_Operations (Derived_Type));
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- If the interface primitive was not found in the
+ -- partial view then this interface primitive was
+ -- overridden. We add a derivation to activate in
+ -- Derive_Progenitor_Subprograms the machinery to
+ -- search for it.
+
+ if No (Elmt) then
+ Derive_Interface_Subprogram
+ (New_Subp => New_Subp,
+ Subp => Subp,
+ Actual_Subp => Act_Subp);
+ end if;
+ end if;
+ end;
+ else
+ Derive_Interface_Subprogram
+ (New_Subp => New_Subp,
+ Subp => Subp,
+ Actual_Subp => Act_Subp);
end if;
-- Case 3: Common derivation
Set_Scope (Def_Id, Current_Scope);
return;
- -- Analogous to privals, the discriminal generated for an entry
- -- index parameter acts as a weak declaration. Perform minimal
- -- decoration to avoid bogus errors.
+ -- Analogous to privals, the discriminal generated for an entry index
+ -- parameter acts as a weak declaration. Perform minimal decoration
+ -- to avoid bogus errors.
elsif Is_Discriminal (Def_Id)
and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
Set_Scope (Def_Id, Current_Scope);
return;
- -- In the body or private part of an instance, a type extension
- -- may introduce a component with the same name as that of an
- -- actual. The legality rule is not enforced, but the semantics
- -- of the full type with two components of the same name are not
- -- clear at this point ???
+ -- In the body or private part of an instance, a type extension may
+ -- introduce a component with the same name as that of an actual. The
+ -- legality rule is not enforced, but the semantics of the full type
+ -- with two components of same name are not clear at this point???
elsif In_Instance_Not_Visible then
null;
then
null;
- -- Conversely, with front-end inlining we may compile the parent
- -- body first, and a child unit subsequently. The context is now
- -- the parent spec, and body entities are not visible.
+ -- Conversely, with front-end inlining we may compile the parent body
+ -- first, and a child unit subsequently. The context is now the
+ -- parent spec, and body entities are not visible.
elsif Is_Child_Unit (Def_Id)
and then Is_Package_Body_Entity (E)
Error_Msg_Sloc := Sloc (E);
-- If the previous declaration is an incomplete type declaration
- -- this may be an attempt to complete it with a private type.
- -- The following avoids confusing cascaded errors.
+ -- this may be an attempt to complete it with a private type. The
+ -- following avoids confusing cascaded errors.
if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
Error_Msg_N ("& conflicts with declaration#", E);
return;
- -- If the name of the unit appears in its own context clause,
- -- a dummy package with the name has already been created, and
- -- the error emitted. Try to continue quietly.
+ -- If the name of the unit appears in its own context clause, a
+ -- dummy package with the name has already been created, and the
+ -- error emitted. Try to continue quietly.
elsif Error_Posted (E)
and then Sloc (E) = No_Location
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
end if;
- -- If entity is in standard, then we are in trouble, because
- -- it means that we have a library package with a duplicated
- -- name. That's hard to recover from, so abort!
+ -- If entity is in standard, then we are in trouble, because it
+ -- means that we have a library package with a duplicated name.
+ -- That's hard to recover from, so abort!
if S = Standard_Standard then
raise Unrecoverable_Error;
end if;
end if;
- -- If we fall through, declaration is OK , or OK enough to continue
+ -- If we fall through, declaration is OK, at least OK enough to continue
- -- If Def_Id is a discriminant or a record component we are in the
- -- midst of inheriting components in a derived record definition.
- -- Preserve their Ekind and Etype.
+ -- If Def_Id is a discriminant or a record component we are in the midst
+ -- of inheriting components in a derived record definition. Preserve
+ -- their Ekind and Etype.
if Ekind_In (Def_Id, E_Discriminant, E_Component) then
null;
- -- If a type is already set, leave it alone (happens whey a type
- -- declaration is reanalyzed following a call to the optimizer)
+ -- If a type is already set, leave it alone (happens when a type
+ -- declaration is reanalyzed following a call to the optimizer).
elsif Present (Etype (Def_Id)) then
null;
and then In_Extended_Main_Source_Unit (Def_Id)
- -- Finally, the hidden entity must be either immediately visible
- -- or use visible (from a used package)
+ -- Finally, the hidden entity must be either immediately visible or
+ -- use visible (i.e. from a used package).
and then
(Is_Immediately_Visible (C)
Write_Line (" F* turn off warnings for unreferenced formal");
Write_Line (" g*+ turn on warnings for unrecognized pragma");
Write_Line (" G turn off warnings for unrecognized pragma");
- Write_Line (" h turn on warnings for hiding variable");
- Write_Line (" H* turn off warnings for hiding variable");
+ Write_Line (" h turn on warnings for hiding declarations");
+ Write_Line (" H* turn off warnings for hiding declarations");
Write_Line (" .h turn on warnings for holes in records");
Write_Line (" .H* turn off warnings for holes in records");
Write_Line (" i*+ turn on warnings for implementation unit");
OSDN Git Service
