Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?

I send a-ciorma.ad? as attachments.
(C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.ads,
 C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.adb)

I built gcc 4.0.1 with "--enable-languages=c,ada,c++ --prefix=/mingw".

Thanks.
YT

Matthew Heaney wrote: 
"Y.Tomino" <demoonlit@xxxxxxxxxxxxxxxxxxxxxxx> writes:


Ada.Containers.Indefinite_Ordered_Maps.Adjust seems to me having bug.
Although good if it's my misunderstanding.



I just ran your examples, and didn't get any exceptions.

It might be the case that you're using an older version of the sources.
Can you go into your adainclude directory, and send me your copies of
a-ciorma.ad?.  (That, or send me the context around line 407.)

-Matt

------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------

with Ada.Containers.Red_Black_Trees;
with Ada.Finalization;
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.Indefinite_Ordered_Maps is
pragma Preelaborate (Indefinite_Ordered_Maps);

type Map is tagged private;

type Cursor is private;

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 Query_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : Element_Type));

procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type));

procedure Replace_Element (Position : Cursor; By : Element_Type);

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;
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 Delete
(Container : in out Map;
Key : Key_Type);

procedure Exclude
(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 Contains
(Container : Map;
Key : Key_Type) return Boolean;

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 First (Container : Map) return Cursor;

function First_Key (Container : Map) return Key_Type;

function First_Element (Container : Map) return Element_Type;

function Last (Container : Map) return Cursor;

function Last_Key (Container : Map) return Key_Type;

function Last_Element (Container : Map) return Element_Type;

function Next (Position : Cursor) return Cursor;

function Previous (Position : Cursor) return Cursor;

procedure Next (Position : in out Cursor);

procedure Previous (Position : in out Cursor);

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

type Node_Type;
type Node_Access is access Node_Type;

package Tree_Types is
new Red_Black_Trees.Generic_Tree_Types (Node_Access);

use Tree_Types;
use Ada.Finalization;

type Map is new Controlled with record
Tree : Tree_Type := (Length => 0, others => null);
end record;

procedure Adjust (Container : in out Map);

procedure Finalize (Container : in out Map) renames Clear;

type Map_Access is access constant Map;
for Map_Access'Storage_Size use 0;

type Cursor is record
Container : Map_Access;
Node : Node_Access;
end record;

No_Element : constant Cursor := Cursor'(null, null);

use Ada.Streams;

procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map);

for Map'Write use Write;

procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map);

for Map'Read use Read;

Empty_Map : constant Map :=
(Controlled with Tree => (Length => 0, others => null));

end Ada.Containers.Indefinite_Ordered_Maps; 

--------------------------------------------------------------------------------                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                  ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2004 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 2,  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- This unit was originally developed by Matthew J Heaney.                  --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);

with Ada.Containers.Red_Black_Trees.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);

with System;  use type System.Address;

package body Ada.Containers.Indefinite_Ordered_Maps is

   use Red_Black_Trees;

   type Key_Access is access Key_Type;
   type Element_Access is access Element_Type;

   type Node_Type is limited record
      Parent  : Node_Access;
      Left    : Node_Access;
      Right   : Node_Access;
      Color   : Red_Black_Trees.Color_Type := Red;
      Key     : Key_Access;
      Element : Element_Access;
   end record;

   -----------------------------
   -- 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_Access) return Color_Type;
   pragma Inline (Color);

   function Left (Node : Node_Access) return Node_Access;
   pragma Inline (Left);

   function Parent (Node : Node_Access) return Node_Access;
   pragma Inline (Parent);

   function Right (Node : Node_Access) return Node_Access;
   pragma Inline (Right);

   procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
   pragma Inline (Set_Parent);

   procedure Set_Left (Node : Node_Access; Left : Node_Access);
   pragma Inline (Set_Left);

   procedure Set_Right (Node : Node_Access; Right : Node_Access);
   pragma Inline (Set_Right);

   procedure Set_Color (Node : Node_Access; Color : Color_Type);
   pragma Inline (Set_Color);

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Copy_Node (Source : Node_Access) return Node_Access;
   pragma Inline (Copy_Node);

   function Copy_Tree (Source_Root : Node_Access) return Node_Access;

   procedure Delete_Tree (X : in out Node_Access);

   procedure Free (X : in out Node_Access);

   function Is_Equal_Node_Node
     (L, R : Node_Access) return Boolean;
   pragma Inline (Is_Equal_Node_Node);

   function Is_Greater_Key_Node
     (Left  : Key_Type;
      Right : Node_Access) return Boolean;
   pragma Inline (Is_Greater_Key_Node);

   function Is_Less_Key_Node
     (Left  : Key_Type;
      Right : Node_Access) return Boolean;
   pragma Inline (Is_Less_Key_Node);

   --------------------------
   -- Local Instantiations --
   --------------------------

   package Tree_Operations is
     new Red_Black_Trees.Generic_Operations
       (Tree_Types => Tree_Types,
        Null_Node  => Node_Access'(null));

   use Tree_Operations;

   package Key_Ops is
     new Red_Black_Trees.Generic_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);

   procedure Free_Key is
     new Ada.Unchecked_Deallocation (Key_Type, Key_Access);

   procedure Free_Element is
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);

   function Is_Equal is
     new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : Cursor) return Boolean is
   begin
      return Left.Node.Key.all < Right.Node.Key.all;
   end "<";

   function "<" (Left : Cursor; Right : Key_Type) return Boolean is
   begin
      return Left.Node.Key.all < Right;
   end "<";

   function "<" (Left : Key_Type; Right : Cursor) return Boolean is
   begin
      return Left < Right.Node.Key.all;
   end "<";

   ---------
   -- "=" --
   ---------

   function "=" (Left, Right : Map) return Boolean is
   begin
      if Left'Address = Right'Address then
         return True;
      end if;

      return Is_Equal (Left.Tree, Right.Tree);
   end "=";

   ---------
   -- ">" --
   ---------

   function ">" (Left, Right : Cursor) return Boolean is
   begin
      return Right.Node.Key.all < Left.Node.Key.all;
   end ">";

   function ">" (Left : Cursor; Right : Key_Type) return Boolean is
   begin
      return Right < Left.Node.Key.all;
   end ">";

   function ">" (Left : Key_Type; Right : Cursor) return Boolean is
   begin
      return Right.Node.Key.all < Left;
   end ">";

   ------------
   -- Adjust --
   ------------

   procedure Adjust (Container : in out Map) is
      Tree : Tree_Type renames Container.Tree;

      N : constant Count_Type := Tree.Length;
      X : constant Node_Access := Tree.Root;

   begin
      if N = 0 then
         pragma Assert (X = null);
         return;
      end if;

      Tree := (Length => 0, others => null);

      Tree.Root := Copy_Tree (X);
      Tree.First := Min (Tree.Root);
      Tree.Last := Max (Tree.Root);
      Tree.Length := N;
   end Adjust;

   -------------
   -- Ceiling --
   -------------

   function Ceiling (Container : Map; Key : Key_Type) return Cursor is
      Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
   begin
      if Node = null then
         return No_Element;
      else
         return Cursor'(Container'Unchecked_Access, Node);
      end if;
   end Ceiling;

   -----------
   -- Clear --
   -----------

   procedure Clear (Container : in out Map) is
      Tree : Tree_Type renames Container.Tree;
      Root : Node_Access := Tree.Root;
   begin
      Tree := (Length => 0, others => null);
      Delete_Tree (Root);
   end Clear;

   -----------
   -- Color --
   -----------

   function Color (Node : Node_Access) 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_Node --
   ---------------

   function Copy_Node (Source : Node_Access) return Node_Access is
      Target : constant Node_Access :=
         new Node_Type'(Parent  => null,
                        Left    => null,
                        Right   => null,
                        Color   => Source.Color,
                        Key     => Source.Key,
                        Element => Source.Element);
   begin
      return Target;
   end Copy_Node;

   ---------------
   -- Copy_Tree --
   ---------------

   function Copy_Tree (Source_Root : Node_Access) return Node_Access is
      Target_Root : Node_Access := Copy_Node (Source_Root);

      P, X : Node_Access;

   begin
      if Source_Root.Right /= null then
         Target_Root.Right := Copy_Tree (Source_Root.Right);
         Target_Root.Right.Parent := Target_Root;
      end if;

      P := Target_Root;
      X := Source_Root.Left;
      while X /= null loop
         declare
            Y : Node_Access := Copy_Node (X);

         begin
            P.Left := Y;
            Y.Parent := P;

            if X.Right /= null then
               Y.Right := Copy_Tree (X.Right);
               Y.Right.Parent := Y;
            end if;

            P := Y;
            X := X.Left;
         end;
      end loop;

      return Target_Root;

   exception
      when others =>
         Delete_Tree (Target_Root);
         raise;
   end Copy_Tree;

   ------------
   -- Delete --
   ------------

   procedure Delete
     (Container : in out Map;
      Position  : in out Cursor)
   is
   begin
      if Position = No_Element then
         return;
      end if;

      if Position.Container /= Map_Access'(Container'Unchecked_Access) then
         raise Program_Error;
      end if;

      Delete_Node_Sans_Free (Container.Tree, Position.Node);
      Free (Position.Node);

      Position.Container := null;
   end Delete;

   procedure Delete (Container : in out Map; Key : Key_Type) is
      X : Node_Access := Key_Ops.Find (Container.Tree, Key);
   begin
      if X = null then
         raise Constraint_Error;
      else
         Delete_Node_Sans_Free (Container.Tree, X);
         Free (X);
      end if;
   end Delete;

   ------------------
   -- Delete_First --
   ------------------

   procedure Delete_First (Container : in out Map) is
      Position : Cursor := First (Container);
   begin
      Delete (Container, Position);
   end Delete_First;

   -----------------
   -- Delete_Last --
   -----------------

   procedure Delete_Last (Container : in out Map) is
      Position : Cursor := Last (Container);
   begin
      Delete (Container, Position);
   end Delete_Last;

   -----------------
   -- Delete_Tree --
   -----------------

   procedure Delete_Tree (X : in out Node_Access) is
      Y : Node_Access;
   begin
      while X /= null loop
         Y := X.Right;
         Delete_Tree (Y);
         Y := X.Left;
         Free (X);
         X := Y;
      end loop;
   end Delete_Tree;

   -------------
   -- Element --
   -------------

   function Element (Position : Cursor) return Element_Type is
   begin
      return Position.Node.Element.all;
   end Element;

   function Element (Container : Map; Key : Key_Type) return Element_Type is
      Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
   begin
      return Node.Element.all;
   end Element;

   -------------
   -- Exclude --
   -------------

   procedure Exclude (Container : in out Map; Key : Key_Type) is
      X : Node_Access := Key_Ops.Find (Container.Tree, Key);

   begin
      if X /= null then
         Delete_Node_Sans_Free (Container.Tree, X);
         Free (X);
      end if;
   end Exclude;

   ----------
   -- Find --
   ----------

   function Find (Container : Map; Key : Key_Type) return Cursor is
      Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
   begin
      if Node = null then
         return No_Element;
      else
         return Cursor'(Container'Unchecked_Access, Node);
      end if;
   end Find;

   -----------
   -- First --
   -----------

   function First (Container : Map) return Cursor is
   begin
      if Container.Tree.First = null then
         return No_Element;
      else
         return Cursor'(Container'Unchecked_Access, Container.Tree.First);
      end if;
   end First;

   -------------------
   -- First_Element --
   -------------------

   function First_Element (Container : Map) return Element_Type is
   begin
      return Container.Tree.First.Element.all;
   end First_Element;

   ---------------
   -- First_Key --
   ---------------

   function First_Key (Container : Map) return Key_Type is
   begin
      return Container.Tree.First.Key.all;
   end First_Key;

   -----------
   -- Floor --
   -----------

   function Floor (Container : Map; Key : Key_Type) return Cursor is
      Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
   begin
      if Node = null then
         return No_Element;
      else
         return Cursor'(Container'Unchecked_Access, Node);
      end if;
   end Floor;

   ----------
   -- Free --
   ----------

   procedure Free (X : in out Node_Access) is
      procedure Deallocate is
        new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
   begin
      if X /= null then
         Free_Key (X.Key);
         Free_Element (X.Element);
         Deallocate (X);
      end if;
   end Free;

   -----------------
   -- 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;

      K : Key_Access;
      E : Element_Access;

   begin
      Insert (Container, Key, New_Item, Position, Inserted);

      if not Inserted then
         K := Position.Node.Key;
         E := Position.Node.Element;

         Position.Node.Key := new Key_Type'(Key);
         Position.Node.Element := new Element_Type'(New_Item);

         Free_Key (K);
         Free_Element (E);
      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
      function New_Node return Node_Access;
      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);

      --------------
      -- New_Node --
      --------------

      function New_Node return Node_Access is
         Node : Node_Access := new Node_Type;

      begin
         Node.Key := new Key_Type'(Key);
         Node.Element := new Element_Type'(New_Item);
         return Node;

      exception
         when others =>

            --  On exception, deallocate key and elem

            Free (Node);
            raise;
      end New_Node;

   --  Start of processing for Insert

   begin
      Insert_Sans_Hint
        (Container.Tree,
         Key,
         Position.Node,
         Inserted);

      Position.Container := Container'Unchecked_Access;
   end Insert;

   procedure Insert
     (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
         raise Constraint_Error;
      end if;
   end Insert;

   --------------
   -- Is_Empty --
   --------------

   function Is_Empty (Container : Map) return Boolean is
   begin
      return Container.Tree.Length = 0;
   end Is_Empty;

   ------------------------
   -- Is_Equal_Node_Node --
   ------------------------

   function Is_Equal_Node_Node
     (L, R : Node_Access) return Boolean is
   begin
      return L.Element.all = R.Element.all;
   end Is_Equal_Node_Node;

   -------------------------
   -- Is_Greater_Key_Node --
   -------------------------

   function Is_Greater_Key_Node
     (Left  : Key_Type;
      Right : Node_Access) return Boolean
   is
   begin
      --  k > node same as node < k

      return Right.Key.all < Left;
   end Is_Greater_Key_Node;

   ----------------------
   -- Is_Less_Key_Node --
   ----------------------

   function Is_Less_Key_Node
     (Left  : Key_Type;
      Right : Node_Access) return Boolean is
   begin
      return Left < Right.Key.all;
   end Is_Less_Key_Node;

   -------------
   -- Iterate --
   -------------

   procedure Iterate
     (Container : Map;
      Process   : not null access procedure (Position : Cursor))
   is
      procedure Process_Node (Node : Node_Access);
      pragma Inline (Process_Node);

      procedure Local_Iterate is
        new Tree_Operations.Generic_Iteration (Process_Node);

      ------------------
      -- Process_Node --
      ------------------

      procedure Process_Node (Node : Node_Access) is
      begin
         Process (Cursor'(Container'Unchecked_Access, Node));
      end Process_Node;

   --  Start of processing for Iterate

   begin
      Local_Iterate (Container.Tree);
   end Iterate;

   ---------
   -- Key --
   ---------

   function Key (Position : Cursor) return Key_Type is
   begin
      return Position.Node.Key.all;
   end Key;

   ----------
   -- Last --
   ----------

   function Last (Container : Map) return Cursor is
   begin
      if Container.Tree.Last = null then
         return No_Element;
      else
         return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
      end if;
   end Last;

   ------------------
   -- Last_Element --
   ------------------

   function Last_Element (Container : Map) return Element_Type is
   begin
      return Container.Tree.Last.Element.all;
   end Last_Element;

   --------------
   -- Last_Key --
   --------------

   function Last_Key (Container : Map) return Key_Type is
   begin
      return Container.Tree.Last.Key.all;
   end Last_Key;

   ----------
   -- Left --
   ----------

   function Left (Node : Node_Access) return Node_Access is
   begin
      return Node.Left;
   end Left;

   ------------
   -- Length --
   ------------

   function Length (Container : Map) return Count_Type is
   begin
      return Container.Tree.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;

      Move (Target => Target.Tree, Source => Source.Tree);
   end Move;

   ----------
   -- Next --
   ----------

   function Next (Position : Cursor) return Cursor is
   begin
      if Position = No_Element then
         return No_Element;
      end if;

      declare
         Node : constant Node_Access := Tree_Operations.Next (Position.Node);
      begin
         if Node = null then
            return No_Element;
         else
            return Cursor'(Position.Container, Node);
         end if;
      end;
   end Next;

   procedure Next (Position : in out Cursor) is
   begin
      Position := Next (Position);
   end Next;

   ------------
   -- Parent --
   ------------

   function Parent (Node : Node_Access) return Node_Access 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;

      declare
         Node : constant Node_Access :=
           Tree_Operations.Previous (Position.Node);
      begin
         if Node = null 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
      Process (Position.Node.Key.all, Position.Node.Element.all);
   end Query_Element;

   ----------
   -- Read --
   ----------

   procedure Read
     (Stream    : access Root_Stream_Type'Class;
      Container : out Map)
   is
      N : Count_Type'Base;

      function New_Node return Node_Access;
      pragma Inline (New_Node);

      procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);

      --------------
      -- New_Node --
      --------------

      function New_Node return Node_Access is
         Node : Node_Access := new Node_Type;

      begin
         Node.Key := new Key_Type'(Key_Type'Input (Stream));
         Node.Element := new Element_Type'(Element_Type'Input (Stream));
         return Node;

      exception
         when others =>

            --  Deallocate key and elem too on exception

            Free (Node);
            raise;
      end New_Node;

   --  Start of processing for Read

   begin
      Clear (Container);

      Count_Type'Base'Read (Stream, N);
      pragma Assert (N >= 0);

      Local_Read (Container.Tree, N);
   end Read;

   -------------
   -- Replace --
   -------------

   procedure Replace
     (Container : in out Map;
      Key       : Key_Type;
      New_Item  : Element_Type)
   is
      Node : constant Node_Access :=
               Key_Ops.Find (Container.Tree, Key);

      K : Key_Access;
      E : Element_Access;

   begin
      if Node = null then
         raise Constraint_Error;
      end if;

      K := Node.Key;
      E := Node.Element;

      Node.Key := new Key_Type'(Key);
      Node.Element := new Element_Type'(New_Item);

      Free_Key (K);
      Free_Element (E);
   end Replace;

   ---------------------
   -- Replace_Element --
   ---------------------

   procedure Replace_Element (Position : Cursor; By : Element_Type) is
      X : Element_Access := Position.Node.Element;
   begin
      Position.Node.Element := new Element_Type'(By);
      Free_Element (X);
   end Replace_Element;

   ---------------------
   -- Reverse_Iterate --
   ---------------------

   procedure Reverse_Iterate
     (Container : Map;
      Process   : not null access procedure (Position : Cursor))
   is
      procedure Process_Node (Node : Node_Access);
      pragma Inline (Process_Node);

      procedure Local_Reverse_Iterate is
        new Tree_Operations.Generic_Reverse_Iteration (Process_Node);

      ------------------
      -- Process_Node --
      ------------------

      procedure Process_Node (Node : Node_Access) is
      begin
         Process (Cursor'(Container'Unchecked_Access, Node));
      end Process_Node;

   --  Start of processing for Reverse_Iterate

   begin
      Local_Reverse_Iterate (Container.Tree);
   end Reverse_Iterate;

   -----------
   -- Right --
   -----------

   function Right (Node : Node_Access) return Node_Access is
   begin
      return Node.Right;
   end Right;

   ---------------
   -- Set_Color --
   ---------------

   procedure Set_Color (Node : Node_Access; Color : Color_Type) is
   begin
      Node.Color := Color;
   end Set_Color;

   --------------
   -- Set_Left --
   --------------

   procedure Set_Left (Node : Node_Access; Left : Node_Access) is
   begin
      Node.Left := Left;
   end Set_Left;

   ----------------
   -- Set_Parent --
   ----------------

   procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
   begin
      Node.Parent := Parent;
   end Set_Parent;

   ---------------
   -- Set_Right --
   ---------------

   procedure Set_Right (Node : Node_Access; Right : Node_Access) is
   begin
      Node.Right := Right;
   end Set_Right;

   --------------------
   -- Update_Element --
   --------------------

   procedure Update_Element
     (Position : Cursor;
      Process  : not null access procedure (Element : in out Element_Type))
   is
   begin
      Process (Position.Node.Key.all, Position.Node.Element.all);
   end Update_Element;

   -----------
   -- Write --
   -----------

   procedure Write
     (Stream    : access Root_Stream_Type'Class;
      Container : Map)
   is
      procedure Process (Node : Node_Access);
      pragma Inline (Process);

      procedure Iterate is
        new Tree_Operations.Generic_Iteration (Process);

      -------------
      -- Process --
      -------------

      procedure Process (Node : Node_Access) is
      begin
         Key_Type'Output (Stream, Node.Key.all);
         Element_Type'Output (Stream, Node.Element.all);
      end Process;

   --  Start of processing for Write

   begin
      Count_Type'Base'Write (Stream, Container.Tree.Length);
      Iterate (Container.Tree);
   end Write;

end Ada.Containers.Indefinite_Ordered_Maps;

Relevant Pages

  • Re: How to use associative arrays in Ada 2005?
    ... container needs to contain another container. ... Call Update_Element with the cursor and the subprogram. ... You don't need the Named_Age map. ... It's probably better to use the insert that returns a cursor, and then reuse ...
    (comp.lang.ada)
  • Re: GCC 4.0 Ada.Containers Cursor danger.
    ... > (Container: in out Map; ... And if the key is already in the map, ... The reason that Iterate passes a cursor is to avoid a combinatorial ...
    (comp.lang.ada)
  • Re: S-expression I/O in Ada
    ... The limited interface long with the Container objects make me pretty ... No_Element: constant Cursor; ... function To_String(Position: in Cursor) return String; ... for i in Image'Range loop ...
    (comp.lang.ada)
  • Re: Run-time accessibility checks
    ... No I made it having same interface, ... container, *because* it is of a different type. ... The cursor is the index in the model you have here. ... to be used to achieve the goal, and secondly return by reference is marked ...
    (comp.lang.ada)
  • Re: Hierarchy Problems
    ... a cursor but it is fast enough. ... SELECT ident, parent, @lvl ... -- get all container rows into a temporary table ... >> You probably get a table scan when you look for the ancestors using the ...
    (microsoft.public.sqlserver.programming)