2005-11-14 Matthew Heaney <heaney@adacore.com>

	* a-crbtgo.ads, a-crbtgo.adb, a-coorse.ads, a-coorse.adb, a-convec.ads, 
	a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohama.ads, a-cohama.adb, 
	a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-cidlli.ads, 
	a-cidlli.adb, a-cdlili.ads, a-cdlili.adb, a-coormu.adb, a-ciormu.adb, 
	a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, 
	a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorma.adb, a-coorma.adb: 
	Compiles against the spec for ordered maps described in sections
	A.18.6 of the most recent (August 2005) AI-302 draft.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106962 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 260 insertions, 40 deletions

diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb
index 2de8cda37e3..bb441a3201c 100644
--- a/gcc/ada/a-ciorse.adb
+++ b/gcc/ada/a-ciorse.adb
@@ -7,7 +7,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 2004-2005, 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 --
@@ -59,6 +59,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    procedure Free (X : in out Node_Access);
 
+   procedure Insert_Sans_Hint
+     (Tree     : in out Tree_Type;
+      New_Item : Element_Type;
+      Node     : out Node_Access;
+      Inserted : out Boolean);
+
    procedure Insert_With_Hint
      (Dst_Tree : in out Tree_Type;
       Dst_Hint : Node_Access;
@@ -144,16 +150,56 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function "<" (Left, Right : Cursor) return Boolean is
    begin
+      if Left.Node = null
+        or else Right.Node = null
+      then
+         raise Constraint_Error;
+      end if;
+
+      if Left.Node.Element = null
+        or else Right.Node.Element = null
+      then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Left.Container.Tree, Left.Node),
+                     "bad Left cursor in ""<""");
+
+      pragma Assert (Vet (Right.Container.Tree, Right.Node),
+                     "bad Right cursor in ""<""");
+
       return Left.Node.Element.all < Right.Node.Element.all;
    end "<";
 
    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
    begin
+      if Left.Node = null then
+         raise Constraint_Error;
+      end if;
+
+      if Left.Node.Element = null then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Left.Container.Tree, Left.Node),
+                     "bad Left cursor in ""<""");
+
       return Left.Node.Element.all < Right;
    end "<";
 
    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
    begin
+      if Right.Node = null then
+         raise Constraint_Error;
+      end if;
+
+      if Right.Node.Element = null then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Right.Container.Tree, Right.Node),
+                     "bad Right cursor in ""<""");
+
       return Left < Right.Node.Element.all;
    end "<";
 
@@ -190,6 +236,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function ">" (Left, Right : Cursor) return Boolean is
    begin
+      if Left.Node = null
+        or else Right.Node = null
+      then
+         raise Constraint_Error;
+      end if;
+
+      if Left.Node.Element = null
+        or else Right.Node.Element = null
+      then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Left.Container.Tree, Left.Node),
+                     "bad Left cursor in "">""");
+
+      pragma Assert (Vet (Right.Container.Tree, Right.Node),
+                     "bad Right cursor in "">""");
+
       --  L > R same as R < L
 
       return Right.Node.Element.all < Left.Node.Element.all;
@@ -197,11 +261,33 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
    begin
+      if Left.Node = null then
+         raise Constraint_Error;
+      end if;
+
+      if Left.Node.Element = null then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Left.Container.Tree, Left.Node),
+                     "bad Left cursor in "">""");
+
       return Right < Left.Node.Element.all;
    end ">";
 
    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
    begin
+      if Right.Node = null then
+         raise Constraint_Error;
+      end if;
+
+      if Right.Node.Element = null then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Right.Container.Tree, Right.Node),
+                     "bad Right cursor in "">""");
+
       return Right.Node.Element.all < Left;
    end ">";
 
@@ -296,6 +382,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          raise Program_Error;
       end if;
 
+      pragma Assert (Vet (Container.Tree, Position.Node),
+                     "bad cursor in Delete");
+
       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
       Free (Position.Node);
       Position.Container := null;
@@ -310,7 +399,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          raise Constraint_Error;
       end if;
 
-      Delete_Node_Sans_Free (Container.Tree, X);
+      Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
       Free (X);
    end Delete;
 
@@ -366,6 +455,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function Element (Position : Cursor) return Element_Type is
    begin
+      if Position.Node = null then
+         raise Constraint_Error;
+      end if;
+
+      if Position.Node.Element = null then
+         raise Program_Error;
+      end if;
+
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Element");
+
       return Position.Node.Element.all;
    end Element;
 
@@ -467,6 +567,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function First_Element (Container : Set) return Element_Type is
    begin
+      if Container.Tree.First = null then
+         raise Constraint_Error;
+      end if;
+
       return Container.Tree.First.Element.all;
    end First_Element;
 
@@ -491,7 +595,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
    ----------
 
    procedure Free (X : in out Node_Access) is
-
       procedure Deallocate is
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 
@@ -500,6 +603,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          return;
       end if;
 
+      X.Parent := X;
+      X.Left := X;
+      X.Right := X;
+
       begin
          Free_Element (X.Element);
       exception
@@ -593,6 +700,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
                   Key_Keys.Find (Container.Tree, Key);
 
       begin
+         if Node = null then
+            raise Constraint_Error;
+         end if;
+
          return Node.Element.all;
       end Element;
 
@@ -685,6 +796,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
       function Key (Position : Cursor) return Key_Type is
       begin
+         if Position.Node = null then
+            raise Constraint_Error;
+         end if;
+
+         if Position.Node.Element = null then
+            raise Program_Error;
+         end if;
+
+         pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                        "bad cursor in Key");
+
          return Key (Position.Node.Element.all);
       end Key;
 
@@ -724,10 +846,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
             raise Constraint_Error;
          end if;
 
+         if Position.Node.Element = null then
+            raise Program_Error;
+         end if;
+
          if Position.Container /= Container'Unrestricted_Access then
             raise Program_Error;
          end if;
 
+         pragma Assert (Vet (Container.Tree, Position.Node),
+                        "bad cursor in Update_Element_Preserving_Key");
+
          declare
             E : Element_Type renames Position.Node.Element.all;
             K : constant Key_Type := Key (E);
@@ -811,13 +940,44 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       Position  : out Cursor;
       Inserted  : out Boolean)
    is
+   begin
+      Insert_Sans_Hint
+        (Container.Tree,
+         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;
+      Inserted : Boolean;
+   begin
+      Insert (Container, New_Item, Position, Inserted);
+
+      if not Inserted then
+         raise Constraint_Error;
+      end if;
+   end Insert;
+
+   ----------------------
+   -- Insert_Sans_Hint --
+   ----------------------
+
+   procedure Insert_Sans_Hint
+     (Tree     : in out Tree_Type;
+      New_Item : Element_Type;
+      Node     : out Node_Access;
+      Inserted : out Boolean)
+   is
       function New_Node return Node_Access;
       pragma Inline (New_Node);
 
       procedure Insert_Post is
         new Element_Keys.Generic_Insert_Post (New_Node);
 
-      procedure Insert_Sans_Hint is
+      procedure Conditional_Insert_Sans_Hint is
         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 
       --------------
@@ -826,11 +986,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
       function New_Node return Node_Access is
          Element : Element_Access := new Element_Type'(New_Item);
+
       begin
          return new Node_Type'(Parent  => null,
                                Left    => null,
                                Right   => null,
-                               Color   => Red,
+                               Color   => Red_Black_Trees.Red,
                                Element => Element);
       exception
          when others =>
@@ -838,28 +999,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
             raise;
       end New_Node;
 
-   --  Start of processing for Insert
+   --  Start of processing for Insert_Sans_Hint
 
    begin
-      Insert_Sans_Hint
-        (Container.Tree,
+      Conditional_Insert_Sans_Hint
+        (Tree,
          New_Item,
-         Position.Node,
+         Node,
          Inserted);
-
-      Position.Container := Container'Unrestricted_Access;
-   end Insert;
-
-   procedure Insert (Container : in out Set; New_Item  : Element_Type) is
-      Position : Cursor;
-      Inserted : Boolean;
-   begin
-      Insert (Container, New_Item, Position, Inserted);
-
-      if not Inserted then
-         raise Constraint_Error;
-      end if;
-   end Insert;
+   end Insert_Sans_Hint;
 
    ----------------------
    -- Insert_With_Hint --
@@ -1047,6 +1195,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
    function Last_Element (Container : Set) return Element_Type is
    begin
+      if Container.Tree.Last = null then
+         raise Constraint_Error;
+      end if;
+
       return Container.Tree.Last.Element.all;
    end Last_Element;
 
@@ -1095,6 +1247,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          return No_Element;
       end if;
 
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Next");
+
       declare
          Node : constant Node_Access :=
                   Tree_Operations.Next (Position.Node);
@@ -1141,6 +1296,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          return No_Element;
       end if;
 
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Previous");
+
       declare
          Node : constant Node_Access :=
                   Tree_Operations.Previous (Position.Node);
@@ -1162,29 +1320,40 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
      (Position  : Cursor;
       Process   : not null access procedure (Element : Element_Type))
    is
-      E : Element_Type renames Position.Node.Element.all;
+   begin
+      if Position.Node = null then
+         raise Constraint_Error;
+      end if;
 
-      S : Set renames Position.Container.all;
-      T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+      if Position.Node.Element = null then
+         raise Program_Error;
+      end if;
 
-      B : Natural renames T.Busy;
-      L : Natural renames T.Lock;
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Query_Element");
 
-   begin
-      B := B + 1;
-      L := L + 1;
+      declare
+         T : Tree_Type renames Position.Container.Tree;
+
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
 
       begin
-         Process (E);
-      exception
-         when others =>
-            L := L - 1;
-            B := B - 1;
-            raise;
-      end;
+         B := B + 1;
+         L := L + 1;
 
-      L := L - 1;
-      B := B - 1;
+         begin
+            Process (Position.Node.Element.all);
+         exception
+            when others =>
+               L := L - 1;
+               B := B - 1;
+               raise;
+         end;
+
+         L := L - 1;
+         B := B - 1;
+      end;
    end Query_Element;
 
    ----------
@@ -1227,6 +1396,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       Read (Stream, Container.Tree);
    end Read;
 
+   procedure Read
+     (Stream : access Root_Stream_Type'Class;
+      Item   : out Cursor)
+   is
+   begin
+      raise Program_Error;
+   end Read;
+
    -------------
    -- Replace --
    -------------
@@ -1242,6 +1419,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          raise Constraint_Error;
       end if;
 
+      if Container.Tree.Lock > 0 then
+         raise Program_Error;
+      end if;
+
       X := Node.Element;
       Node.Element := new Element_Type'(New_Item);
       Free_Element (X);
@@ -1295,6 +1476,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          function New_Node return Node_Access is
          begin
             Node.Element := new Element_Type'(Item);  -- OK if fails
+            Node.Color := Red;
+            Node.Parent := null;
+            Node.Right := null;
+            Node.Left := null;
+
             return Node;
          end New_Node;
 
@@ -1340,6 +1526,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
 
          function New_Node return Node_Access is
          begin
+            Node.Color := Red;
+            Node.Parent := null;
+            Node.Right := null;
+            Node.Left := null;
+
             return Node;
          end New_Node;
 
@@ -1372,10 +1563,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
          raise Constraint_Error;
       end if;
 
+      if Position.Node.Element = null then
+         raise Program_Error;
+      end if;
+
       if Position.Container /= Container'Unrestricted_Access then
          raise Program_Error;
       end if;
 
+      pragma Assert (Vet (Container.Tree, Position.Node),
+                     "bad cursor in Replace_Element");
+
       Replace_Element (Container.Tree, Position.Node, New_Item);
    end Replace_Element;
 
@@ -1482,6 +1680,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       return Set'(Controlled with Tree);
    end Symmetric_Difference;
 
+   ------------
+   -- To_Set --
+   ------------
+
+   function To_Set (New_Item : Element_Type) return Set is
+      Tree     : Tree_Type;
+      Node     : Node_Access;
+      Inserted : Boolean;
+
+   begin
+      Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
+      return Set'(Controlled with Tree);
+   end To_Set;
+
    -----------
    -- Union --
    -----------
@@ -1532,4 +1744,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
       Write (Stream, Container.Tree);
    end Write;
 
+   procedure Write
+     (Stream : access Root_Stream_Type'Class;
+      Item   : Cursor)
+   is
+   begin
+      raise Program_Error;
+   end Write;
+
 end Ada.Containers.Indefinite_Ordered_Sets;