OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-crbtgo.ads, [...]: Compiles against the spec for ordered maps described in sections A.18.6 of the...

Browse Source 
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.

From-SVN: r106962
This commit is contained in:
Matthew Heaney 2005-11-15 14:54:02 +01:00 committed by Arnaud Charlet
parent 5e61ef090a
commit 2368f04ec1
30 changed files with 3328 additions and 1425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

301
gcc/ada/a-cdlili.adb
View File

@ -6,7 +6,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 --
@ -34,6 +34,7 @@
------------------------------------------------------------------------------
with System; use type System.Address;
with Ada.Unchecked_Deallocation;
package body Ada.Containers.Doubly_Linked_Lists is
@ -129,7 +130,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Append
(Container : in out List;
New_Item : Element_Type;
Count : Count_Type := 1) is
Count : Count_Type := 1)
is
begin
Insert (Container, No_Element, New_Item, Count);
end Append;
@ -185,7 +187,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Contains
(Container : List;
Item : Element_Type) return Boolean is
Item : Element_Type) return Boolean
is
begin
return Find (Container, Item) /= No_Element;
end Contains;
@ -202,8 +205,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
X : Node_Access;
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
@ -212,13 +213,16 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
Position := No_Element; -- Post-York behavior
return;
end if;
if Count = 0 then
Position := No_Element; -- Post-York behavior
return;
end if;
@ -247,6 +251,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
Free (X);
end loop;
Position := No_Element; -- Post-York behavior
end Delete;
------------------
@ -329,12 +335,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in Element");
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Element");
return Position.Node.Element;
end Element;
@ -354,11 +360,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
Node := Container.First;
else
pragma Assert (Vet (Position), "bad cursor in Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
end if;
while Node /= null loop
@ -604,12 +610,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
pragma Assert (Vet (Before), "bad cursor in Insert");
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
@ -656,12 +662,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
pragma Assert (Vet (Before), "bad cursor in Insert");
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
@ -937,12 +943,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
Process : not null access procedure (Element : in Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
@ -1018,97 +1024,46 @@ package body Ada.Containers.Doubly_Linked_Lists is
end loop;
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Position : Cursor;
By : Element_Type)
(Container : in out List;
Position : Cursor;
New_Item : Element_Type)
is
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Container = null then
raise Constraint_Error;
end if;
if Position.Container.Lock > 0 then
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
end if;
Position.Node.Element := By;
end Replace_Element;
------------------
-- Reverse_Find --
------------------
function Reverse_Find
(Container : List;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor
is
Node : Node_Access := Position.Node;
begin
if Node = null then
Node := Container.Last;
else
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Container.Lock > 0 then
raise Program_Error;
end if;
while Node /= null loop
if Node.Element = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Node := Node.Prev;
end loop;
Position.Node.Element := New_Item;
end Replace_Element;
return No_Element;
end Reverse_Find;
----------------------
-- Reverse_Elements --
----------------------
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : List;
Process : not null access procedure (Position : Cursor))
is
C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
Node : Node_Access := Container.Last;
begin
B := B + 1;
begin
while Node /= null loop
Process (Cursor'(Container'Unchecked_Access, Node));
Node := Node.Prev;
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
------------------
-- Reverse_List --
------------------
procedure Reverse_List (Container : in out List) is
procedure Reverse_Elements (Container : in out List) is
I : Node_Access := Container.First;
J : Node_Access := Container.Last;
@ -1152,7 +1107,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
end Swap;
-- Start of processing for Reverse_List
-- Start of processing for Reverse_Elements
begin
if Container.Length <= 1 then
@ -1188,7 +1143,72 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
end Reverse_List;
end Reverse_Elements;
------------------
-- Reverse_Find --
------------------
function Reverse_Find
(Container : List;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor
is
Node : Node_Access := Position.Node;
begin
if Node = null then
Node := Container.Last;
else
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
while Node /= null loop
if Node.Element = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
Node := Node.Prev;
end loop;
return No_Element;
end Reverse_Find;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : List;
Process : not null access procedure (Position : Cursor))
is
C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
Node : Node_Access := Container.Last;
begin
B := B + 1;
begin
while Node /= null loop
Process (Cursor'(Container'Unchecked_Access, Node));
Node := Node.Prev;
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
------------
-- Splice --
@ -1200,12 +1220,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
pragma Assert (Vet (Before), "bad cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
if Target'Address = Source'Address
@ -1274,13 +1294,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
Position : Cursor)
is
begin
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unchecked_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unchecked_Access
then
raise Program_Error;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
@ -1291,6 +1310,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
@ -1378,13 +1399,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
@ -1395,6 +1415,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
@ -1474,18 +1496,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
-- Swap --
----------
procedure Swap (I, J : Cursor) is
procedure Swap
(Container : in out List;
I, J : Cursor)
is
begin
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
end if;
if I.Container /= J.Container then
if I.Container /= Container'Unchecked_Access
or else J.Container /= Container'Unchecked_Access
then
raise Program_Error;
end if;
@ -1493,15 +1517,19 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
if I.Container.Lock > 0 then
if Container.Lock > 0 then
raise Program_Error;
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
declare
EI : Element_Type renames I.Node.Element;
EJ : Element_Type renames J.Node.Element;
EI_Copy : constant Element_Type := EI;
begin
EI := EJ;
EJ := EI_Copy;
@ -1514,11 +1542,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Swap_Links
(Container : in out List;
I, J : Cursor) is
I, J : Cursor)
is
begin
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
if I.Node = null
or else J.Node = null
then
@ -1539,6 +1565,9 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Program_Error;
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
declare
I_Next : constant Cursor := Next (I);
@ -1570,20 +1599,24 @@ package body Ada.Containers.Doubly_Linked_Lists is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
(Container : in out List;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
@ -1761,4 +1794,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end loop;
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
end Ada.Containers.Doubly_Linked_Lists;

122
gcc/ada/a-cdlili.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -63,22 +63,43 @@ package Ada.Containers.Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out List;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Replace_Element
(Position : Cursor;
By : Element_Type);
(Container : in out List;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Move
(Target : in out List;
Source : in out List);
procedure Insert
(Container : in out List;
Before : Cursor;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
New_Item : Element_Type;
Position : out Cursor;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1);
procedure Prepend
(Container : in out List;
New_Item : Element_Type;
@ -89,25 +110,6 @@ package Ada.Containers.Doubly_Linked_Lists is
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
New_Item : Element_Type;
Position : out Cursor;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1);
procedure Delete
(Container : in out List;
Position : in out Cursor;
@ -121,21 +123,11 @@ package Ada.Containers.Doubly_Linked_Lists is
(Container : in out List;
Count : Count_Type := 1);
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
procedure Reverse_Elements (Container : in out List);
function Is_Sorted (Container : List) return Boolean;
procedure Sort (Container : in out List);
procedure Merge (Target, Source : in out List);
end Generic_Sorting;
procedure Reverse_List (Container : in out List);
procedure Swap (I, J : Cursor);
procedure Swap
(Container : in out List;
I, J : Cursor);
procedure Swap_Links
(Container : in out List;
@ -149,13 +141,13 @@ package Ada.Containers.Doubly_Linked_Lists is
procedure Splice
(Target : in out List;
Before : Cursor;
Position : Cursor);
Source : in out List;
Position : in out Cursor);
procedure Splice
(Target : in out List;
Before : Cursor;
Source : in out List;
Position : in out Cursor);
Position : Cursor);
function First (Container : List) return Cursor;
@ -165,9 +157,13 @@ package Ada.Containers.Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type;
function Contains
(Container : List;
Item : Element_Type) return Boolean;
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 : List;
@ -179,13 +175,9 @@ package Ada.Containers.Doubly_Linked_Lists is
Item : Element_Type;
Position : Cursor := No_Element) return Cursor;
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 Contains
(Container : List;
Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
@ -197,6 +189,18 @@ package Ada.Containers.Doubly_Linked_Lists is
(Container : List;
Process : not null access procedure (Position : Cursor));
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Is_Sorted (Container : List) return Boolean;
procedure Sort (Container : in out List);
procedure Merge (Target, Source : in out List);
end Generic_Sorting;
private
type Node_Type;
type Node_Access is access Node_Type;
@ -248,6 +252,18 @@ private
Node : Node_Access;
end record;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
No_Element : constant Cursor := Cursor'(null, null);
end Ada.Containers.Doubly_Linked_Lists;

344
gcc/ada/a-cidlli.adb
View File

@ -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 --
@ -211,7 +211,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Contains
(Container : List;
Item : Element_Type) return Boolean is
Item : Element_Type) return Boolean
is
begin
return Find (Container, Item) /= No_Element;
end Contains;
@ -228,23 +229,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
X : Node_Access;
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
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 (Position), "bad cursor in Delete");
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
Position := No_Element; -- Post-York behavior
return;
end if;
if Count = 0 then
Position := No_Element; -- Post-York behavior
return;
end if;
@ -273,6 +279,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Free (X);
end loop;
Position := No_Element; -- Post-York behavior
end Delete;
------------------
@ -355,12 +363,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in Element");
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), "bad cursor in Element");
return Position.Node.Element.all;
end Element;
@ -380,11 +392,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Node := Container.First;
else
pragma Assert (Vet (Position), "bad cursor in Find");
if Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
end if;
while Node /= null loop
@ -635,12 +651,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Node : Node_Access;
begin
pragma Assert (Vet (Before), "bad cursor in Insert");
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
end if;
if Count = 0 then
@ -942,12 +964,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Process : not null access procedure (Element : in Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
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), "bad cursor in Query_Element");
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
@ -1024,102 +1050,56 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end loop;
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Position : Cursor;
By : Element_Type)
(Container : in out List;
Position : Cursor;
New_Item : Element_Type)
is
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Container = null then
raise Constraint_Error;
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
end if;
if Position.Container.Lock > 0 then
raise Program_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
declare
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Position.Node.Element := new Element_Type'(New_Item);
Free (X);
end;
end Replace_Element;
------------------
-- Reverse_Find --
------------------
----------------------
-- Reverse_Elements --
----------------------
function Reverse_Find
(Container : List;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor
is
Node : Node_Access := Position.Node;
begin
if Node = null then
Node := Container.Last;
else
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
end if;
while Node /= null loop
if Node.Element.all = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
Node := Node.Prev;
end loop;
return No_Element;
end Reverse_Find;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : List;
Process : not null access procedure (Position : in Cursor))
is
C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
Node : Node_Access := Container.Last;
begin
B := B + 1;
begin
while Node /= null loop
Process (Cursor'(Container'Unchecked_Access, Node));
Node := Node.Prev;
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
------------------
-- Reverse_List --
------------------
procedure Reverse_List (Container : in out List) is
procedure Reverse_Elements (Container : in out List) is
I : Node_Access := Container.First;
J : Node_Access := Container.Last;
@ -1163,7 +1143,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
end Swap;
-- Start of processing for Reverse_List
-- Start of processing for Reverse_Elements
begin
if Container.Length <= 1 then
@ -1199,7 +1179,75 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
end Reverse_List;
end Reverse_Elements;
------------------
-- Reverse_Find --
------------------
function Reverse_Find
(Container : List;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor
is
Node : Node_Access := Position.Node;
begin
if Node = null then
Node := Container.Last;
else
if Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
end if;
while Node /= null loop
if Node.Element.all = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
Node := Node.Prev;
end loop;
return No_Element;
end Reverse_Find;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : List;
Process : not null access procedure (Position : in Cursor))
is
C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
Node : Node_Access := Container.Last;
begin
B := B + 1;
begin
while Node /= null loop
Process (Cursor'(Container'Unchecked_Access, Node));
Node := Node.Prev;
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
------------
-- Splice --
@ -1211,12 +1259,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Source : in out List)
is
begin
pragma Assert (Vet (Before), "bad cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
end if;
if Target'Address = Source'Address
@ -1284,23 +1338,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Position : Cursor)
is
begin
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unchecked_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unchecked_Access
then
raise Program_Error;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
@ -1388,23 +1453,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
@ -1484,18 +1560,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
-- Swap --
----------
procedure Swap (I, J : Cursor) is
procedure Swap
(Container : in out List;
I, J : Cursor)
is
begin
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
end if;
if I.Container /= J.Container then
if I.Container /= Container'Unchecked_Access
or else J.Container /= Container'Unchecked_Access
then
raise Program_Error;
end if;
@ -1503,12 +1581,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
if I.Container.Lock > 0 then
if Container.Lock > 0 then
raise Program_Error;
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
pragma Assert (Vet (J), "bad J cursor in Swap");
declare
EI_Copy : constant Element_Access := I.Node.Element;
begin
I.Node.Element := J.Node.Element;
J.Node.Element := EI_Copy;
@ -1524,9 +1606,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
if I.Node = null
or else J.Node = null
then
@ -1547,6 +1626,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Program_Error;
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
pragma Assert (Vet (J), "bad J cursor in Swap_Links");
declare
I_Next : constant Cursor := Next (I);
@ -1580,20 +1662,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
(Container : in out List;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
@ -1775,4 +1865,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end loop;
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
end Ada.Containers.Indefinite_Doubly_Linked_Lists;

105
gcc/ada/a-cidlli.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -62,35 +62,26 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Clear (Container : in out List);
function Element (Position : Cursor)
return Element_Type;
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out List;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Replace_Element
(Position : Cursor;
By : Element_Type);
(Container : in out List;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Move
(Target : in out List;
Source : in out List);
procedure Prepend
(Container : in out List;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Append
(Container : in out List;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Insert
(Container : in out List;
Before : Cursor;
@ -104,6 +95,16 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
Position : out Cursor;
Count : Count_Type := 1);
procedure Prepend
(Container : in out List;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Append
(Container : in out List;
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Delete
(Container : in out List;
Position : in out Cursor;
@ -117,21 +118,9 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Container : in out List;
Count : Count_Type := 1);
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
procedure Reverse_Elements (Container : in out List);
function Is_Sorted (Container : List) return Boolean;
procedure Sort (Container : in out List);
procedure Merge (Target, Source : in out List);
end Generic_Sorting;
procedure Reverse_List (Container : in out List);
procedure Swap (I, J : Cursor);
procedure Swap (Container : in out List; I, J : Cursor);
procedure Swap_Links (Container : in out List; I, J : Cursor);
@ -143,13 +132,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Splice
(Target : in out List;
Before : Cursor;
Position : Cursor);
Source : in out List;
Position : in out Cursor);
procedure Splice
(Target : in out List;
Before : Cursor;
Source : in out List;
Position : in out Cursor);
Position : Cursor);
function First (Container : List) return Cursor;
@ -159,9 +148,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type;
function Contains
(Container : List;
Item : Element_Type) return Boolean;
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 : List;
@ -173,13 +166,9 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
Item : Element_Type;
Position : Cursor := No_Element) return Cursor;
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 Contains
(Container : List;
Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
@ -191,6 +180,18 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Container : List;
Process : not null access procedure (Position : Cursor));
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Is_Sorted (Container : List) return Boolean;
procedure Sort (Container : in out List);
procedure Merge (Target, Source : in out List);
end Generic_Sorting;
private
type Node_Type;
type Node_Access is access Node_Type;
@ -244,6 +245,18 @@ private
Node : Node_Access;
end record;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
No_Element : constant Cursor := Cursor'(null, null);
end Ada.Containers.Indefinite_Doubly_Linked_Lists;

45
gcc/ada/a-cihama.adb
View File

@ -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 --
@ -713,6 +713,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Read_Nodes (Stream, Container.HT);
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------
-- Read_Node --
---------------
@ -787,7 +795,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
procedure Replace_Element
(Container : in out Map;
Position : Cursor;
New_Item : Element_Type)
is
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@ -795,6 +807,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Constraint_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
@ -803,7 +819,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Position.Node.Element := new Element_Type'(New_Item);
Free_Element (X);
end;
end Replace_Element;
@ -834,9 +850,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@ -845,9 +862,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Constraint_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
HT : Hash_Table_Type renames Container.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
@ -859,7 +879,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
Process (K, E);
exception
@ -951,6 +970,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Write_Nodes (Stream, Container.HT);
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
----------------
-- Write_Node --
----------------

84
gcc/ada/a-cihama.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -57,6 +57,12 @@ package Ada.Containers.Indefinite_Hashed_Maps is
function "=" (Left, Right : Map) return Boolean;
function Capacity (Container : Map) return Count_Type;
procedure Reserve_Capacity
(Container : in out Map;
Capacity : Count_Type);
function Length (Container : Map) return Count_Type;
function Is_Empty (Container : Map) return Boolean;
@ -67,20 +73,22 @@ package Ada.Containers.Indefinite_Hashed_Maps is
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
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
(Container : in out Map;
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
@ -105,29 +113,11 @@ package Ada.Containers.Indefinite_Hashed_Maps is
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 (Container : in out Map; Key : Key_Type);
procedure Exclude
(Container : in out Map;
Key : Key_Type);
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;
procedure Delete (Container : in out Map; Position : in out Cursor);
function First (Container : Map) return Cursor;
@ -135,29 +125,24 @@ package Ada.Containers.Indefinite_Hashed_Maps is
procedure Next (Position : in out Cursor);
function Find (Container : Map; Key : Key_Type) return Cursor;
function Contains (Container : Map; Key : Key_Type) return Boolean;
function Element (Container : Map; Key : Key_Type) return Element_Type;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Keys (Left, Right : Cursor)
return Boolean;
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean;
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
function Capacity (Container : Map) return Count_Type;
procedure Reserve_Capacity
(Container : in out Map;
Capacity : Count_Type);
private
pragma Inline ("=");
pragma Inline (Length);
@ -194,6 +179,7 @@ private
use HT_Types;
use Ada.Finalization;
use Ada.Streams;
procedure Adjust (Container : in out Map);
@ -208,12 +194,22 @@ private
Node : Node_Access;
end record;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor :=
(Container => null,
Node => null);
use Ada.Streams;
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map);

124
gcc/ada/a-cihase.adb
View File

@ -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 --
@ -73,6 +73,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Hash_Node (Node : Node_Access) return Hash_Type;
pragma Inline (Hash_Node);
procedure Insert
(HT : in out Hash_Table_Type;
New_Item : Element_Type;
Node : out Node_Access;
Inserted : out Boolean);
function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean;
pragma Inline (Is_In);
@ -326,13 +332,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
begin
if not Is_In (Right.HT, L_Node) then
declare
Indx : constant Hash_Type :=
Hash (L_Node.Element.all) mod Buckets'Length;
Src : Element_Type renames L_Node.Element.all;
Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
Bucket : Node_Access renames Buckets (Indx);
Tgt : Element_Access := new Element_Type'(Src);
begin
Bucket := new Node_Type'(L_Node.Element, Bucket);
Bucket := new Node_Type'(Tgt, Bucket);
exception
when others =>
Free_Element (Tgt);
raise;
end;
Length := Length + 1;
@ -643,6 +652,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean)
is
begin
Insert (Container.HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_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;
procedure Insert
(HT : in out Hash_Table_Type;
New_Item : Element_Type;
Node : out Node_Access;
Inserted : out Boolean)
is
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
@ -665,8 +700,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise;
end New_Node;
HT : Hash_Table_Type renames Container.HT;
-- Start of processing for Insert
begin
@ -674,30 +707,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, New_Item, Position.Node, Inserted);
Local_Insert (HT, New_Item, Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Position.Container := Container'Unchecked_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;
------------------
@ -787,13 +803,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
begin
if Is_In (Right.HT, L_Node) then
declare
Indx : constant Hash_Type :=
Hash (L_Node.Element.all) mod Buckets'Length;
Src : Element_Type renames L_Node.Element.all;
Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
Bucket : Node_Access renames Buckets (Indx);
Tgt : Element_Access := new Element_Type'(Src);
begin
Bucket := new Node_Type'(L_Node.Element, Bucket);
Bucket := new Node_Type'(Tgt, Bucket);
exception
when others =>
Free_Element (Tgt);
raise;
end;
Length := Length + 1;
@ -1040,6 +1063,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Read_Nodes (Stream, Container.HT);
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------
-- Read_Node --
---------------
@ -1502,6 +1533,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Symmetric_Difference;
------------
-- To_Set --
------------
function To_Set (New_Item : Element_Type) return Set is
HT : Hash_Table_Type;
Node : Node_Access;
Inserted : Boolean;
begin
Insert (HT, New_Item, Node, Inserted);
return Set'(Controlled with HT);
end To_Set;
-----------
-- Union --
-----------
@ -1609,13 +1654,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-------------
procedure Process (L_Node : Node_Access) is
J : constant Hash_Type :=
Hash (L_Node.Element.all) mod Buckets'Length;
Src : Element_Type renames L_Node.Element.all;
J : constant Hash_Type := Hash (Src) mod Buckets'Length;
Bucket : Node_Access renames Buckets (J);
Tgt : Element_Access := new Element_Type'(Src);
begin
Bucket := new Node_Type'(L_Node.Element, Bucket);
Bucket := new Node_Type'(Tgt, Bucket);
exception
when others =>
Free_Element (Tgt);
raise;
end Process;
-- Start of processing for Process
@ -1751,6 +1803,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Write_Nodes (Stream, Container.HT);
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
----------------
-- Write_Node --
----------------

19
gcc/ada/a-cihase.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -63,6 +63,8 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Sets (Left, Right : Set) return Boolean;
function To_Set (New_Item : Element_Type) return Set;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
@ -225,6 +227,7 @@ private
use HT_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -235,12 +238,22 @@ private
Node : Node_Access;
end record;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor :=
(Container => null,
Node => null);
use Ada.Streams;
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Set);

407
gcc/ada/a-ciorma.adb
View File

@ -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 --
@ -135,16 +135,56 @@ package body Ada.Containers.Indefinite_Ordered_Maps 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.Key = null
or else Right.Node.Key = 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.Key.all < Right.Node.Key.all;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
if Left.Node.Key = null then
raise Program_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in ""<""");
return Left.Node.Key.all < Right;
end "<";
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
if Right.Node.Key = null then
raise Program_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in ""<""");
return Left < Right.Node.Key.all;
end "<";
@ -163,16 +203,56 @@ package body Ada.Containers.Indefinite_Ordered_Maps 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.Key = null
or else Right.Node.Key = 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 Right.Node.Key.all < Left.Node.Key.all;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
if Left.Node.Key = null then
raise Program_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in "">""");
return Right < Left.Node.Key.all;
end ">";
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
if Right.Node.Key = null then
raise Program_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in "">""");
return Right.Node.Key.all < Left;
end ">";
@ -194,12 +274,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
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'Unrestricted_Access, Node);
end if;
return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
@ -268,11 +349,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
raise Constraint_Error;
end if;
if Position.Container /= Map_Access'(Container'Unrestricted_Access) then
if Position.Node.Key = null
or else Position.Node.Element = null
then
raise Program_Error;
end if;
Delete_Node_Sans_Free (Container.Tree, Position.Node);
if Position.Container /= Container'Unrestricted_Access then
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;
@ -280,13 +370,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
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;
Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end Delete;
------------------
@ -295,6 +386,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
procedure Delete_First (Container : in out Map) is
X : Node_Access := Container.Tree.First;
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@ -308,6 +400,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
procedure Delete_Last (Container : in out Map) is
X : Node_Access := Container.Tree.Last;
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@ -321,15 +414,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps 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;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
return Node.Element.all;
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 --
-------------
@ -339,7 +463,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
begin
if X /= null then
Delete_Node_Sans_Free (Container.Tree, X);
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
@ -350,12 +474,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
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'Unrestricted_Access, Node);
end if;
return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
@ -363,12 +488,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
-----------
function First (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
begin
if Container.Tree.First = null then
if T.First = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end if;
return Cursor'(Container'Unrestricted_Access, T.First);
end First;
-------------------
@ -376,8 +503,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
-------------------
function First_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.First.Element.all;
if T.First = null then
raise Constraint_Error;
end if;
return T.First.Element.all;
end First_Element;
---------------
@ -385,8 +518,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
---------------
function First_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.First.Key.all;
if T.First = null then
raise Constraint_Error;
end if;
return T.First.Key.all;
end First_Key;
-----------
@ -395,12 +534,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
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'Unrestricted_Access, Node);
end if;
return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
@ -410,11 +550,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X = null then
return;
end if;
X.Parent := X;
X.Left := X;
X.Right := X;
begin
Free_Key (X.Key);
exception
@ -664,6 +809,17 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Key = null then
raise Program_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Key");
return Position.Node.Key.all;
end Key;
@ -672,12 +828,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
----------
function Last (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
begin
if Container.Tree.Last = null then
if T.Last = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end if;
return Cursor'(Container'Unrestricted_Access, T.Last);
end Last;
------------------
@ -685,8 +843,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
------------------
function Last_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.Last.Element.all;
if T.Last = null then
raise Constraint_Error;
end if;
return T.Last.Element.all;
end Last_Element;
--------------
@ -694,8 +858,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
--------------
function Last_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.Last.Key.all;
if T.Last = null then
raise Constraint_Error;
end if;
return T.Last.Key.all;
end Last_Key;
----------
@ -738,8 +908,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
return No_Element;
end if;
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Key /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Next");
declare
Node : constant Node_Access := Tree_Operations.Next (Position.Node);
Node : constant Node_Access :=
Tree_Operations.Next (Position.Node);
begin
if Node = null then
return No_Element;
@ -773,9 +951,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
return No_Element;
end if;
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Key /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Previous");
declare
Node : constant Node_Access :=
Tree_Operations.Previous (Position.Node);
Tree_Operations.Previous (Position.Node);
begin
if Node = null then
return No_Element;
@ -799,29 +984,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
Process : not null access procedure (Key : Key_Type;
Element : Element_Type))
is
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Key = null
or else Position.Node.Element = null
then
raise Program_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Query_Element");
declare
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -863,6 +1065,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps 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 --
-------------
@ -908,15 +1118,40 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
X : Element_Access := Position.Node.Element;
procedure Replace_Element
(Container : in out Map;
Position : Cursor;
New_Item : Element_Type)
is
begin
if Position.Container.Tree.Lock > 0 then
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Key = null
or else Position.Node.Element = null
then
raise Program_Error;
end if;
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Container.Tree.Lock > 0 then
raise Program_Error;
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
"bad cursor in Replace_Element");
declare
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(New_Item);
Free_Element (X);
end;
end Replace_Element;
---------------------
@ -1010,33 +1245,55 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Key = null
or else 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");
declare
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
-----------
@ -1074,4 +1331,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps 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_Maps;

89
gcc/ada/a-ciorma.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -40,16 +40,16 @@ 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;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
type Map is tagged private;
type Cursor is private;
@ -70,17 +70,21 @@ package Ada.Containers.Indefinite_Ordered_Maps is
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
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type));
procedure Replace_Element (Position : Cursor; By : Element_Type);
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type));
procedure Move (Target : in out Map; Source : in out Map);
@ -106,54 +110,28 @@ package Ada.Containers.Indefinite_Ordered_Maps is
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 (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);
procedure Exclude
(Container : in out Map;
Key : Key_Type);
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 First_Key (Container : Map) return Key_Type;
function Last (Container : Map) return Cursor;
function Last_Key (Container : Map) return Key_Type;
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);
@ -162,6 +140,16 @@ package Ada.Containers.Indefinite_Ordered_Maps is
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;
@ -216,8 +204,9 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Map_Access is access Map;
type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
@ -225,9 +214,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;

365
gcc/ada/a-ciormu.adb
View File

@ -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 --
@ -87,6 +87,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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);
procedure Insert_With_Hint
(Dst_Tree : in out Tree_Type;
Dst_Hint : Node_Access;
@ -157,16 +162,56 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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 "<";
@ -183,20 +228,60 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
-- ">" --
---------
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
return Right < Left.Node.Element.all;
end ">";
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;
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 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 ">";
@ -313,6 +398,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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);
@ -375,9 +463,35 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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;
-------------------------
-- 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 --
---------------------
@ -420,6 +534,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
X : Node_Access;
begin
while Node /= Done loop
X := Node;
@ -464,6 +579,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
raise Constraint_Error;
end if;
if Container.Tree.First.Element = null then
raise Program_Error;
end if;
return Container.Tree.First.Element.all;
end First_Element;
@ -490,11 +613,16 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X = null then
return;
end if;
X.Parent := X;
X.Left := X;
X.Right := X;
begin
Free_Element (X.Element);
exception
@ -538,34 +666,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
---------
-- "<" --
---------
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Element.all;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right > Left.Node.Element.all;
end "<";
---------
-- ">" --
---------
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left > Right.Node.Element.all;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Element.all;
end ">";
-------------
-- Ceiling --
-------------
@ -621,11 +721,32 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
Node : constant Node_Access :=
Key_Keys.Find (Container.Tree, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
return Node.Element.all;
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 --
-------------
@ -681,9 +802,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean is
Right : Node_Access) return Boolean
is
begin
return Left > Right.Element.all;
return Key (Right.Element.all) < Left;
end Is_Greater_Key_Node;
----------------------
@ -692,9 +814,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function Is_Less_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean is
Right : Node_Access) return Boolean
is
begin
return Left < Right.Element.all;
return Left < Key (Right.Element.all);
end Is_Less_Key_Node;
-------------
@ -746,6 +869,17 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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;
@ -812,13 +946,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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 : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
@ -839,11 +980,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (Left => K, Right => Key (E)) then
return;
end if;
end;
@ -883,6 +1020,24 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
(Container : in out Set;
New_Item : Element_Type;
Position : out Cursor)
is
begin
Insert_Sans_Hint
(Container.Tree,
New_Item,
Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
----------------------
-- Insert_Sans_Hint --
----------------------
procedure Insert_Sans_Hint
(Tree : in out Tree_Type;
New_Item : Element_Type;
Node : out Node_Access)
is
function New_Node return Node_Access;
pragma Inline (New_Node);
@ -904,7 +1059,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red,
Color => Red_Black_Trees.Red,
Element => X);
exception
@ -913,16 +1068,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
raise;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert_Sans_Hint
begin
Unconditional_Insert_Sans_Hint
(Container.Tree,
(Tree,
New_Item,
Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
Node);
end Insert_Sans_Hint;
----------------------
-- Insert_With_Hint --
@ -1156,6 +1309,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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;
@ -1199,6 +1356,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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);
@ -1245,6 +1405,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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);
@ -1271,29 +1434,40 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element.all;
S : Set renames Position.Container.all;
T : Tree_Type renames S.Tree'Unrestricted_Access.all;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
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 Query_Element");
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;
----------
@ -1334,6 +1508,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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_Element --
---------------------
@ -1382,6 +1564,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function New_Node return Node_Access is
begin
Node.Element := new Element_Type'(Item); -- OK if fails
Node.Color := Red_Black_Trees.Red;
Node.Parent := null;
Node.Left := null;
Node.Right := null;
return Node;
end New_Node;
@ -1403,22 +1590,27 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all;
begin
if Position.Node = null then
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;
Replace_Element (Tree, Position.Node, By);
pragma Assert (Vet (Container.Tree, Position.Node),
"bad cursor in Replace_Element");
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
@ -1563,6 +1755,19 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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;
begin
Insert_Sans_Hint (Tree, New_Item, Node);
return Set'(Controlled with Tree);
end To_Set;
-----------
-- Union --
-----------
@ -1613,4 +1818,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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_Multisets;

95
gcc/ada/a-ciormu.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -47,6 +47,8 @@ generic
package Ada.Containers.Indefinite_Ordered_Multisets is
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
type Cursor is private;
@ -59,6 +61,8 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
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;
@ -67,15 +71,15 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
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 Replace_Element
(Container : Set;
Position : Cursor;
By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
@ -85,6 +89,14 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
procedure Insert (Container : in out Set; New_Item : Element_Type);
-- TODO: include Replace too???
--
-- 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);
@ -93,10 +105,7 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
procedure Delete_Last (Container : in out Set);
procedure Exclude (Container : in out Set; Item : Element_Type);
procedure Union (Target : in out Set;
Source : Set);
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -124,14 +133,6 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
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 First (Container : Set) return Cursor;
function First_Element (Container : Set) return Element_Type;
@ -148,6 +149,14 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
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;
@ -181,20 +190,23 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function "<" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function ">" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
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 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;
@ -202,21 +214,7 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
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;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
@ -266,6 +264,7 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -275,9 +274,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write (Stream : access Root_Stream_Type'Class; Container : Set);

322
gcc/ada/a-ciorse.adb
View File

@ -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,35 +940,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Position : out Cursor;
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
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
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,
Element => Element);
exception
when others =>
Free_Element (Element);
raise;
end New_Node;
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container.Tree,
@ -861,6 +961,54 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
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 Conditional_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
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_Black_Trees.Red,
Element => Element);
exception
when others =>
Free_Element (Element);
raise;
end New_Node;
-- Start of processing for Insert_Sans_Hint
begin
Conditional_Insert_Sans_Hint
(Tree,
New_Item,
Node,
Inserted);
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;
S : Set renames Position.Container.all;
T : Tree_Type renames S.Tree'Unrestricted_Access.all;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
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 Query_Element");
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;

19
gcc/ada/a-ciorse.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -61,6 +61,8 @@ package Ada.Containers.Indefinite_Ordered_Sets is
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;
@ -266,6 +268,7 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -275,9 +278,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;

51
gcc/ada/a-cohama.adb
View File

@ -6,7 +6,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 --
@ -624,6 +624,7 @@ package body Ada.Containers.Hashed_Maps is
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
begin
if Node = null then
return No_Element;
@ -695,6 +696,14 @@ package body Ada.Containers.Hashed_Maps is
Read_Nodes (Stream, Container.HT);
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------
-- Read_Node --
---------------
@ -743,7 +752,11 @@ package body Ada.Containers.Hashed_Maps is
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
procedure Replace_Element
(Container : in out Map;
Position : Cursor;
New_Item : Element_Type)
is
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@ -751,11 +764,15 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
Position.Node.Element := By;
Position.Node.Element := New_Item;
end Replace_Element;
----------------------
@ -784,9 +801,10 @@ package body Ada.Containers.Hashed_Maps is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@ -795,12 +813,14 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
declare
HT : Hash_Table_Type renames Container.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
@ -809,7 +829,6 @@ package body Ada.Containers.Hashed_Maps is
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
Process (K, E);
exception
@ -891,6 +910,14 @@ package body Ada.Containers.Hashed_Maps is
Write_Nodes (Stream, Container.HT);
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
----------------
-- Write_Node --
----------------

55
gcc/ada/a-cohama.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -39,13 +39,10 @@ with Ada.Finalization;
generic
type Key_Type is private;
type Element_Type is private;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Hashed_Maps is
@ -61,6 +58,11 @@ package Ada.Containers.Hashed_Maps is
function "=" (Left, Right : Map) return Boolean;
function Capacity (Container : Map) return Count_Type;
procedure Reserve_Capacity (Container : in out Map;
Capacity : Count_Type);
function Length (Container : Map) return Count_Type;
function Is_Empty (Container : Map) return Boolean;
@ -71,18 +73,22 @@ package Ada.Containers.Hashed_Maps is
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
(Position : Cursor;
Process : not null access
(Container : in out Map;
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
@ -113,24 +119,24 @@ package Ada.Containers.Hashed_Maps is
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 Exclude (Container : in out Map; Key : Key_Type);
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 First (Container : Map) return Cursor;
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Find (Container : Map; Key : Key_Type) return Cursor;
function Contains (Container : Map; Key : Key_Type) return Boolean;
function Element (Container : Map; Key : Key_Type) return Element_Type;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
@ -143,11 +149,6 @@ package Ada.Containers.Hashed_Maps is
(Container : Map;
Process : not null access procedure (Position : Cursor));
function Capacity (Container : Map) return Count_Type;
procedure Reserve_Capacity (Container : in out Map;
Capacity : Count_Type);
private
pragma Inline ("=");
pragma Inline (Length);
@ -211,6 +212,18 @@ private
Node : Node_Access;
end record;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := (Container => null, Node => null);
end Ada.Containers.Hashed_Maps;

108
gcc/ada/a-cohase.adb
View File

@ -6,7 +6,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 --
@ -72,6 +72,12 @@ package body Ada.Containers.Hashed_Sets is
function Hash_Node (Node : Node_Access) return Hash_Type;
pragma Inline (Hash_Node);
procedure Insert
(HT : in out Hash_Table_Type;
New_Item : Element_Type;
Node : out Node_Access;
Inserted : out Boolean);
function Is_In
(HT : Hash_Table_Type;
Key : Node_Access) return Boolean;
@ -595,39 +601,8 @@ package body Ada.Containers.Hashed_Sets is
Position : out Cursor;
Inserted : out Boolean)
is
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
-- New_Node --
--------------
function New_Node (Next : Node_Access) return Node_Access is
Node : constant Node_Access := new Node_Type'(New_Item, Next);
begin
return Node;
end New_Node;
HT : Hash_Table_Type renames Container.HT;
-- Start of processing for Insert
begin
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, New_Item, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Insert (Container.HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
@ -646,6 +621,43 @@ package body Ada.Containers.Hashed_Sets is
end if;
end Insert;
procedure Insert
(HT : in out Hash_Table_Type;
New_Item : Element_Type;
Node : out Node_Access;
Inserted : out Boolean)
is
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
-- New_Node --
--------------
function New_Node (Next : Node_Access) return Node_Access is
begin
return new Node_Type'(New_Item, Next);
end New_Node;
-- Start of processing for Insert
begin
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, New_Item, Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
end Insert;
------------------
-- Intersection --
------------------
@ -970,6 +982,14 @@ package body Ada.Containers.Hashed_Sets is
Read_Nodes (Stream, Container.HT);
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------
-- Read_Node --
---------------
@ -1366,6 +1386,20 @@ package body Ada.Containers.Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Symmetric_Difference;
------------
-- To_Set --
------------
function To_Set (New_Item : Element_Type) return Set is
HT : Hash_Table_Type;
Node : Node_Access;
Inserted : Boolean;
begin
Insert (HT, New_Item, Node, Inserted);
return Set'(Controlled with HT);
end To_Set;
-----------
-- Union --
-----------
@ -1595,6 +1629,14 @@ package body Ada.Containers.Hashed_Sets is
Write_Nodes (Stream, Container.HT);
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
end Write;
----------------
-- Write_Node --
----------------

19
gcc/ada/a-cohase.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -62,6 +62,8 @@ package Ada.Containers.Hashed_Sets is
function Equivalent_Sets (Left, Right : Set) return Boolean;
function To_Set (New_Item : Element_Type) return Set;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
@ -222,6 +224,7 @@ private
use HT_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -232,9 +235,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := (Container => null, Node => null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := (Container => null, Node => null);
procedure Write
(Stream : access Root_Stream_Type'Class;

189
gcc/ada/a-coinve.adb
View File

@ -6,7 +6,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 --
@ -475,44 +475,6 @@ package body Ada.Containers.Indefinite_Vectors is
Count);
end Append;
------------
-- Assign --
------------
procedure Assign
(Target : in out Vector;
Source : Vector)
is
N : constant Count_Type := Length (Source);
begin
if Target'Address = Source'Address then
return;
end if;
Clear (Target);
if N = 0 then
return;
end if;
if N > Capacity (Target) then
Reserve_Capacity (Target, Capacity => N);
end if;
for J in Index_Type'First .. Source.Last loop
declare
EA : constant Element_Access := Source.Elements (J);
begin
if EA /= null then
Target.Elements (J) := new Element_Type'(EA.all);
end if;
end;
Target.Last := J;
end loop;
end Assign;
--------------
-- Capacity --
--------------
@ -553,7 +515,8 @@ package body Ada.Containers.Indefinite_Vectors is
function Contains
(Container : Vector;
Item : Element_Type) return Boolean is
Item : Element_Type) return Boolean
is
begin
return Find_Index (Container, Item) /= No_Index;
end Contains;
@ -649,8 +612,7 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error;
end if;
if Position.Container /=
Vector_Access'(Container'Unchecked_Access)
if Position.Container /= Container'Unchecked_Access
or else Position.Index > Container.Last
then
raise Program_Error;
@ -658,11 +620,7 @@ package body Ada.Containers.Indefinite_Vectors is
Delete (Container, Position.Index, Count);
if Position.Index <= Container.Last then
Position := (Container'Unchecked_Access, Position.Index);
else
Position := No_Element;
end if;
Position := No_Element; -- See comment in a-convec.adb
end Delete;
------------------
@ -738,7 +696,16 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error;
end if;
return Container.Elements (Index).all;
declare
EA : constant Element_Access := Container.Elements (Index);
begin
if EA = null then
raise Constraint_Error;
end if;
return EA.all;
end;
end Element;
function Element (Position : Cursor) return Element_Type is
@ -773,13 +740,12 @@ package body Ada.Containers.Indefinite_Vectors is
function Find
(Container : Vector;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor is
Position : Cursor := No_Element) return Cursor
is
begin
if Position.Container /= null
and then (Position.Container /=
Vector_Access'(Container'Unchecked_Access)
or else Position.Index > Container.Last)
and then (Position.Container /= Container'Unchecked_Access
or else Position.Index > Container.Last)
then
raise Program_Error;
end if;
@ -802,7 +768,8 @@ package body Ada.Containers.Indefinite_Vectors is
function Find_Index
(Container : Vector;
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index is
Index : Index_Type := Index_Type'First) return Extended_Index
is
begin
for Indx in Index .. Container.Last loop
if Container.Elements (Indx) /= null
@ -1287,7 +1254,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Before.Container /= null
and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
and then Before.Container /= Container'Unchecked_Access
then
raise Program_Error;
end if;
@ -1843,6 +1810,10 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error;
end if;
if V.Elements (Index) = null then
raise Constraint_Error;
end if;
B := B + 1;
L := L + 1;
@ -1907,14 +1878,22 @@ package body Ada.Containers.Indefinite_Vectors is
end loop;
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Position : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
By : Element_Type)
New_Item : Element_Type)
is
begin
if Index > Container.Last then
@ -1928,18 +1907,26 @@ package body Ada.Containers.Indefinite_Vectors is
declare
X : Element_Access := Container.Elements (Index);
begin
Container.Elements (Index) := new Element_Type'(By);
Container.Elements (Index) := new Element_Type'(New_Item);
Free (X);
end;
end Replace_Element;
procedure Replace_Element (Position : Cursor; By : Element_Type) is
procedure Replace_Element
(Container : in out Vector;
Position : Cursor;
New_Item : Element_Type)
is
begin
if Position.Container = null then
raise Constraint_Error;
end if;
Replace_Element (Position.Container.all, Position.Index, By);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Replace_Element (Container, Position.Index, New_Item);
end Replace_Element;
----------------------
@ -2083,6 +2070,41 @@ package body Ada.Containers.Indefinite_Vectors is
end;
end Reserve_Capacity;
----------------------
-- Reverse_Elements --
----------------------
procedure Reverse_Elements (Container : in out Vector) is
begin
if Container.Length <= 1 then
return;
end if;
if Container.Lock > 0 then
raise Program_Error;
end if;
declare
I : Index_Type := Index_Type'First;
J : Index_Type := Container.Last;
E : Elements_Type renames Container.Elements.all;
begin
while I < J loop
declare
EI : constant Element_Access := E (I);
begin
E (I) := E (J);
E (J) := EI;
end;
I := I + 1;
J := J - 1;
end loop;
end;
end Reverse_Elements;
------------------
-- Reverse_Find --
------------------
@ -2096,8 +2118,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container /= null
and then Position.Container /=
Vector_Access'(Container'Unchecked_Access)
and then Position.Container /= Container'Unchecked_Access
then
raise Program_Error;
end if;
@ -2230,7 +2251,7 @@ package body Ada.Containers.Indefinite_Vectors is
----------
procedure Swap
(Container : Vector;
(Container : in out Vector;
I, J : Index_Type)
is
begin
@ -2260,7 +2281,9 @@ package body Ada.Containers.Indefinite_Vectors is
end;
end Swap;
procedure Swap (I, J : Cursor)
procedure Swap
(Container : in out Vector;
I, J : Cursor)
is
begin
if I.Container = null
@ -2269,11 +2292,13 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error;
end if;
if I.Container /= J.Container then
if I.Container /= Container'Unrestricted_Access
or else J.Container /= Container'Unrestricted_Access
then
raise Program_Error;
end if;
Swap (I.Container.all, I.Index, J.Index);
Swap (Container, I.Index, J.Index);
end Swap;
---------------
@ -2387,24 +2412,27 @@ package body Ada.Containers.Indefinite_Vectors is
--------------------
procedure Update_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
if Index > Container.Last then
raise Constraint_Error;
end if;
if Container.Elements (Index) = null then
raise Constraint_Error;
end if;
B := B + 1;
L := L + 1;
begin
Process (V.Elements (Index).all);
Process (Container.Elements (Index).all);
exception
when others =>
L := L - 1;
@ -2417,15 +2445,20 @@ package body Ada.Containers.Indefinite_Vectors is
end Update_Element;
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
if Position.Container = null then
raise Constraint_Error;
end if;
Update_Element (Position.Container.all, Position.Index, Process);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------
@ -2466,4 +2499,12 @@ package body Ada.Containers.Indefinite_Vectors is
end;
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Position : Cursor)
is
begin
raise Program_Error;
end Write;
end Ada.Containers.Indefinite_Vectors;

109
gcc/ada/a-coinve.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -38,7 +38,6 @@ with Ada.Streams;
generic
type Index_Type is range <>;
type Element_Type (<>) is private;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
@ -52,8 +51,6 @@ package Ada.Containers.Indefinite_Vectors is
No_Index : constant Extended_Index := Extended_Index'First;
subtype Index_Subtype is Index_Type;
type Vector is tagged private;
type Cursor is private;
@ -62,6 +59,8 @@ package Ada.Containers.Indefinite_Vectors is
No_Element : constant Cursor;
function "=" (Left, Right : Vector) return Boolean;
function To_Vector (Length : Count_Type) return Vector;
function To_Vector
@ -76,8 +75,6 @@ package Ada.Containers.Indefinite_Vectors is
function "&" (Left, Right : Element_Type) return Vector;
function "=" (Left, Right : Vector) return Boolean;
function Capacity (Container : Vector) return Count_Type;
procedure Reserve_Capacity
@ -86,6 +83,10 @@ package Ada.Containers.Indefinite_Vectors is
function Length (Container : Vector) return Count_Type;
procedure Set_Length
(Container : in out Vector;
Length : Count_Type);
function Is_Empty (Container : Vector) return Boolean;
procedure Clear (Container : in out Vector);
@ -102,6 +103,16 @@ package Ada.Containers.Indefinite_Vectors is
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Vector;
Index : Index_Type;
New_Item : Element_Type);
procedure Replace_Element
(Container : in out Vector;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : Vector;
Index : Index_Type;
@ -112,24 +123,14 @@ package Ada.Containers.Indefinite_Vectors is
Process : not null access procedure (Element : Element_Type));
procedure Update_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Replace_Element
(Container : Vector;
Index : Index_Type;
By : Element_Type);
procedure Replace_Element
(Position : Cursor;
By : Element_Type);
procedure Assign (Target : in out Vector; Source : Vector);
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Move (Target : in out Vector; Source : in out Vector);
@ -197,10 +198,6 @@ package Ada.Containers.Indefinite_Vectors is
Position : out Cursor;
Count : Count_Type := 1);
procedure Set_Length
(Container : in out Vector;
Length : Count_Type);
procedure Delete
(Container : in out Vector;
Index : Extended_Index;
@ -219,6 +216,12 @@ package Ada.Containers.Indefinite_Vectors is
(Container : in out Vector;
Count : Count_Type := 1);
procedure Reverse_Elements (Container : in out Vector);
procedure Swap (Container : in out Vector; I, J : Index_Type);
procedure Swap (Container : in out Vector; I, J : Cursor);
function First_Index (Container : Vector) return Index_Type;
function First (Container : Vector) return Cursor;
@ -231,21 +234,13 @@ package Ada.Containers.Indefinite_Vectors is
function Last_Element (Container : Vector) return Element_Type;
procedure Swap (Container : Vector; I, J : Index_Type);
function Next (Position : Cursor) return Cursor;
procedure Swap (I, J : Cursor);
procedure Next (Position : in out Cursor);
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Previous (Position : Cursor) return Cursor;
function Is_Sorted (Container : Vector) return Boolean;
procedure Sort (Container : in out Vector);
procedure Merge (Target, Source : in out Vector);
end Generic_Sorting;
procedure Previous (Position : in out Cursor);
function Find_Index
(Container : Vector;
@ -255,30 +250,22 @@ package Ada.Containers.Indefinite_Vectors is
function Find
(Container : Vector;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor;
Position : Cursor := No_Element) return Cursor;
function Reverse_Find_Index
(Container : Vector;
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index;
function Reverse_Find (Container : Vector;
Item : Element_Type;
Position : Cursor := No_Element)
return Cursor;
function Reverse_Find
(Container : Vector;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor;
function Contains
(Container : Vector;
Item : Element_Type) return Boolean;
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;
procedure Iterate
@ -289,6 +276,18 @@ package Ada.Containers.Indefinite_Vectors is
(Container : Vector;
Process : not null access procedure (Position : Cursor));
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Is_Sorted (Container : Vector) return Boolean;
procedure Sort (Container : in out Vector);
procedure Merge (Target : in out Vector; Source : in out Vector);
end Generic_Sorting;
private
pragma Inline (First_Index);
@ -346,6 +345,18 @@ private
Index : Index_Type := Index_Type'First;
end record;
procedure Write
(Stream : access Root_Stream_Type'Class;
Position : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Position : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
end Ada.Containers.Indefinite_Vectors;

191
gcc/ada/a-convec.adb
View File

@ -303,37 +303,6 @@ package body Ada.Containers.Vectors is
Count);
end Append;
------------
-- Assign --
------------
procedure Assign
(Target : in out Vector;
Source : Vector)
is
N : constant Count_Type := Length (Source);
begin
if Target'Address = Source'Address then
return;
end if;
Clear (Target);
if N = 0 then
return;
end if;
if N > Capacity (Target) then
Reserve_Capacity (Target, Capacity => N);
end if;
Target.Elements (Index_Type'First .. Source.Last) :=
Source.Elements (Index_Type'First .. Source.Last);
Target.Last := Source.Last;
end Assign;
--------------
-- Capacity --
--------------
@ -443,8 +412,7 @@ package body Ada.Containers.Vectors is
raise Constraint_Error;
end if;
if Position.Container /=
Vector_Access'(Container'Unchecked_Access)
if Position.Container /= Container'Unrestricted_Access
or else Position.Index > Container.Last
then
raise Program_Error;
@ -452,11 +420,17 @@ package body Ada.Containers.Vectors is
Delete (Container, Position.Index, Count);
if Position.Index <= Container.Last then
Position := (Container'Unchecked_Access, Position.Index);
else
Position := No_Element;
end if;
-- This is the old behavior, prior to the York API (2005/06):
-- if Position.Index <= Container.Last then
-- Position := (Container'Unchecked_Access, Position.Index);
-- else
-- Position := No_Element;
-- end if;
-- This is the behavior specified by the York API:
Position := No_Element;
end Delete;
------------------
@ -539,6 +513,7 @@ package body Ada.Containers.Vectors is
procedure Finalize (Container : in out Vector) is
X : Elements_Access := Container.Elements;
begin
if Container.Busy > 0 then
raise Program_Error;
@ -556,13 +531,12 @@ package body Ada.Containers.Vectors is
function Find
(Container : Vector;
Item : Element_Type;
Position : Cursor := No_Element) return Cursor is
Position : Cursor := No_Element) return Cursor
is
begin
if Position.Container /= null
and then (Position.Container /=
Vector_Access'(Container'Unchecked_Access)
or else Position.Index > Container.Last)
and then (Position.Container /= Container'Unrestricted_Access
or else Position.Index > Container.Last)
then
raise Program_Error;
end if;
@ -583,7 +557,8 @@ package body Ada.Containers.Vectors is
function Find_Index
(Container : Vector;
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index is
Index : Index_Type := Index_Type'First) return Extended_Index
is
begin
for Indx in Index .. Container.Last loop
if Container.Elements (Indx) = Item then
@ -1152,6 +1127,31 @@ package body Ada.Containers.Vectors is
Position := Cursor'(Container'Unchecked_Access, Index);
end Insert;
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1)
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
begin
Insert (Container, Before, New_Item, Count);
end Insert;
procedure Insert
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1)
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
------------------
-- Insert_Space --
------------------
@ -1339,7 +1339,7 @@ package body Ada.Containers.Vectors is
Index := Before.Index;
end if;
Insert_Space (Container, Index, Count);
Insert_Space (Container, Index, Count => Count);
Position := Cursor'(Container'Unchecked_Access, Index);
end Insert_Space;
@ -1365,7 +1365,6 @@ package body Ada.Containers.Vectors is
B : Natural renames V.Busy;
begin
B := B + 1;
begin
@ -1379,7 +1378,6 @@ package body Ada.Containers.Vectors is
end;
B := B - 1;
end Iterate;
----------
@ -1620,14 +1618,22 @@ package body Ada.Containers.Vectors is
end loop;
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
Position : out Cursor)
is
begin
raise Program_Error;
end Read;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
By : Element_Type)
New_Item : Element_Type)
is
begin
if Index > Container.Last then
@ -1638,16 +1644,24 @@ package body Ada.Containers.Vectors is
raise Program_Error;
end if;
Container.Elements (Index) := By;
Container.Elements (Index) := New_Item;
end Replace_Element;
procedure Replace_Element (Position : Cursor; By : Element_Type) is
procedure Replace_Element
(Container : in out Vector;
Position : Cursor;
New_Item : Element_Type)
is
begin
if Position.Container = null then
raise Constraint_Error;
end if;
Replace_Element (Position.Container.all, Position.Index, By);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Replace_Element (Container, Position.Index, New_Item);
end Replace_Element;
----------------------
@ -1799,6 +1813,41 @@ package body Ada.Containers.Vectors is
end;
end Reserve_Capacity;
----------------------
-- Reverse_Elements --
----------------------
procedure Reverse_Elements (Container : in out Vector) is
begin
if Container.Length <= 1 then
return;
end if;
if Container.Lock > 0 then
raise Program_Error;
end if;
declare
I : Index_Type := Index_Type'First;
J : Index_Type := Container.Last;
E : Elements_Type renames Container.Elements.all;
begin
while I < J loop
declare
EI : constant Element_Type := E (I);
begin
E (I) := E (J);
E (J) := EI;
end;
I := I + 1;
J := J - 1;
end loop;
end;
end Reverse_Elements;
------------------
-- Reverse_Find --
------------------
@ -1921,7 +1970,7 @@ package body Ada.Containers.Vectors is
-- Swap --
----------
procedure Swap (Container : Vector; I, J : Index_Type) is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
if I > Container.Last
or else J > Container.Last
@ -1949,7 +1998,7 @@ package body Ada.Containers.Vectors is
end;
end Swap;
procedure Swap (I, J : Cursor) is
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
if I.Container = null
or else J.Container = null
@ -1957,11 +2006,13 @@ package body Ada.Containers.Vectors is
raise Constraint_Error;
end if;
if I.Container /= J.Container then
if I.Container /= Container'Unrestricted_Access
or else J.Container /= Container'Unrestricted_Access
then
raise Program_Error;
end if;
Swap (I.Container.all, I.Index, J.Index);
Swap (Container, I.Index, J.Index);
end Swap;
---------------
@ -2057,13 +2108,12 @@ package body Ada.Containers.Vectors is
--------------------
procedure Update_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
if Index > Container.Last then
@ -2074,7 +2124,7 @@ package body Ada.Containers.Vectors is
L := L + 1;
begin
Process (V.Elements (Index));
Process (Container.Elements (Index));
exception
when others =>
L := L - 1;
@ -2087,15 +2137,20 @@ package body Ada.Containers.Vectors is
end Update_Element;
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
if Position.Container = null then
raise Constraint_Error;
end if;
Update_Element (Position.Container.all, Position.Index, Process);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------
@ -2114,4 +2169,12 @@ package body Ada.Containers.Vectors is
end loop;
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
Position : Cursor)
is
begin
raise Program_Error;
end Write;
end Ada.Containers.Vectors;

107
gcc/ada/a-convec.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -50,8 +50,6 @@ package Ada.Containers.Vectors is
No_Index : constant Extended_Index := Extended_Index'First;
subtype Index_Subtype is Index_Type;
type Vector is tagged private;
type Cursor is private;
@ -60,6 +58,8 @@ package Ada.Containers.Vectors is
No_Element : constant Cursor;
function "=" (Left, Right : Vector) return Boolean;
function To_Vector (Length : Count_Type) return Vector;
function To_Vector
@ -74,8 +74,6 @@ package Ada.Containers.Vectors is
function "&" (Left, Right : Element_Type) return Vector;
function "=" (Left, Right : Vector) return Boolean;
function Capacity (Container : Vector) return Count_Type;
procedure Reserve_Capacity
@ -84,6 +82,10 @@ package Ada.Containers.Vectors is
function Length (Container : Vector) return Count_Type;
procedure Set_Length
(Container : in out Vector;
Length : Count_Type);
function Is_Empty (Container : Vector) return Boolean;
procedure Clear (Container : in out Vector);
@ -100,6 +102,16 @@ package Ada.Containers.Vectors is
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Vector;
Index : Index_Type;
New_Item : Element_Type);
procedure Replace_Element
(Container : in out Vector;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : Vector;
Index : Index_Type;
@ -110,22 +122,14 @@ package Ada.Containers.Vectors is
Process : not null access procedure (Element : Element_Type));
procedure Update_Element
(Container : Vector;
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Replace_Element
(Container : Vector;
Index : Index_Type;
By : Element_Type);
procedure Replace_Element (Position : Cursor; By : Element_Type);
procedure Assign (Target : in out Vector; Source : Vector);
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Move (Target : in out Vector; Source : in out Vector);
@ -164,6 +168,17 @@ package Ada.Containers.Vectors is
Position : out Cursor;
Count : Count_Type := 1);
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1);
procedure Insert
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1);
procedure Prepend
(Container : in out Vector;
New_Item : Vector);
@ -193,10 +208,6 @@ package Ada.Containers.Vectors is
Position : out Cursor;
Count : Count_Type := 1);
procedure Set_Length
(Container : in out Vector;
Length : Count_Type);
procedure Delete
(Container : in out Vector;
Index : Extended_Index;
@ -215,6 +226,12 @@ package Ada.Containers.Vectors is
(Container : in out Vector;
Count : Count_Type := 1);
procedure Reverse_Elements (Container : in out Vector);
procedure Swap (Container : in out Vector; I, J : Index_Type);
procedure Swap (Container : in out Vector; I, J : Cursor);
function First_Index (Container : Vector) return Index_Type;
function First (Container : Vector) return Cursor;
@ -227,21 +244,13 @@ package Ada.Containers.Vectors is
function Last_Element (Container : Vector) return Element_Type;
procedure Swap (Container : Vector; I, J : Index_Type);
function Next (Position : Cursor) return Cursor;
procedure Swap (I, J : Cursor);
procedure Next (Position : in out Cursor);
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Previous (Position : Cursor) return Cursor;
function Is_Sorted (Container : Vector) return Boolean;
procedure Sort (Container : in out Vector);
procedure Merge (Target, Source : in out Vector);
end Generic_Sorting;
procedure Previous (Position : in out Cursor);
function Find_Index
(Container : Vector;
@ -267,14 +276,6 @@ package Ada.Containers.Vectors is
(Container : Vector;
Item : Element_Type) return Boolean;
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;
procedure Iterate
@ -285,6 +286,18 @@ package Ada.Containers.Vectors is
(Container : Vector;
Process : not null access procedure (Position : Cursor));
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
function Is_Sorted (Container : Vector) return Boolean;
procedure Sort (Container : in out Vector);
procedure Merge (Target : in out Vector; Source : in out Vector);
end Generic_Sorting;
private
pragma Inline (First_Index);
@ -340,6 +353,18 @@ private
Index : Index_Type := Index_Type'First;
end record;
procedure Write
(Stream : access Root_Stream_Type'Class;
Position : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Position : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
end Ada.Containers.Vectors;

365
gcc/ada/a-coorma.adb
View File

@ -6,7 +6,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 --
@ -81,6 +81,8 @@ package body Ada.Containers.Ordered_Maps is
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
procedure Free (X : in out Node_Access);
function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
pragma Inline (Is_Equal_Node_Node);
@ -98,8 +100,6 @@ package body Ada.Containers.Ordered_Maps is
-- Local Instantiations --
--------------------------
procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package Tree_Operations is
new Red_Black_Trees.Generic_Operations (Tree_Types);
@ -127,16 +127,42 @@ package body Ada.Containers.Ordered_Maps is
function "<" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_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.Key < Right.Node.Key;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in ""<""");
return Left.Node.Key < Right;
end "<";
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in ""<""");
return Left < Right.Node.Key;
end "<";
@ -155,16 +181,42 @@ package body Ada.Containers.Ordered_Maps is
function ">" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_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 Right.Node.Key < Left.Node.Key;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in "">""");
return Right < Left.Node.Key;
end ">";
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in "">""");
return Right.Node.Key < Left;
end ">";
@ -231,12 +283,12 @@ package body Ada.Containers.Ordered_Maps is
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,
new Node_Type'(Color => Source.Color,
Key => Source.Key,
Element => Source.Element);
Element => Source.Element,
Parent => null,
Left => null,
Right => null);
begin
return Target;
end Copy_Node;
@ -246,16 +298,20 @@ package body Ada.Containers.Ordered_Maps is
------------
procedure Delete (Container : in out Map; Position : in out Cursor) is
Tree : Tree_Type renames Container.Tree;
begin
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Map_Access'(Container'Unrestricted_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
pragma Assert (Vet (Tree, Position.Node), "bad cursor in Delete");
Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
@ -269,7 +325,7 @@ package body Ada.Containers.Ordered_Maps 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;
@ -279,6 +335,7 @@ package body Ada.Containers.Ordered_Maps is
procedure Delete_First (Container : in out Map) is
X : Node_Access := Container.Tree.First;
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@ -292,6 +349,7 @@ package body Ada.Containers.Ordered_Maps is
procedure Delete_Last (Container : in out Map) is
X : Node_Access := Container.Tree.Last;
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@ -305,15 +363,42 @@ package body Ada.Containers.Ordered_Maps is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Element");
return Position.Node.Element;
end Element;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
return 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 --
-------------
@ -323,7 +408,7 @@ package body Ada.Containers.Ordered_Maps is
begin
if X /= null then
Delete_Node_Sans_Free (Container.Tree, X);
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
@ -348,12 +433,14 @@ package body Ada.Containers.Ordered_Maps is
-----------
function First (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
begin
if Container.Tree.First = null then
if T.First = null then
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
return Cursor'(Container'Unrestricted_Access, T.First);
end First;
-------------------
@ -361,8 +448,14 @@ package body Ada.Containers.Ordered_Maps is
-------------------
function First_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.First.Element;
if T.First = null then
raise Constraint_Error;
end if;
return T.First.Element;
end First_Element;
---------------
@ -370,8 +463,14 @@ package body Ada.Containers.Ordered_Maps is
---------------
function First_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.First.Key;
if T.First = null then
raise Constraint_Error;
end if;
return T.First.Key;
end First_Key;
-----------
@ -389,6 +488,26 @@ package body Ada.Containers.Ordered_Maps is
return Cursor'(Container'Unrestricted_Access, Node);
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
return;
end if;
X.Parent := X;
X.Left := X;
X.Right := X;
Deallocate (X);
end Free;
-----------------
-- Has_Element --
-----------------
@ -444,15 +563,13 @@ package body Ada.Containers.Ordered_Maps is
--------------
function New_Node return Node_Access is
Node : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red,
Key => Key,
Element => New_Item);
begin
return Node;
return new Node_Type'(Key => Key,
Element => New_Item,
Color => Red_Black_Trees.Red,
Parent => null,
Left => null,
Right => null);
end New_Node;
-- Start of processing for Insert
@ -507,18 +624,13 @@ package body Ada.Containers.Ordered_Maps is
--------------
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
begin
begin
Node.Key := Key;
exception
when others =>
Free (Node);
raise;
end;
return Node;
return new Node_Type'(Key => Key,
Element => <>,
Color => Red_Black_Trees.Red,
Parent => null,
Left => null,
Right => null);
end New_Node;
-- Start of processing for Insert
@ -633,6 +745,13 @@ package body Ada.Containers.Ordered_Maps is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Key");
return Position.Node.Key;
end Key;
@ -641,12 +760,14 @@ package body Ada.Containers.Ordered_Maps is
----------
function Last (Container : Map) return Cursor is
T : Tree_Type renames Container.Tree;
begin
if Container.Tree.Last = null then
if T.Last = null then
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
return Cursor'(Container'Unrestricted_Access, T.Last);
end Last;
------------------
@ -654,8 +775,14 @@ package body Ada.Containers.Ordered_Maps is
------------------
function Last_Element (Container : Map) return Element_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.Last.Element;
if T.Last = null then
raise Constraint_Error;
end if;
return T.Last.Element;
end Last_Element;
--------------
@ -663,8 +790,14 @@ package body Ada.Containers.Ordered_Maps is
--------------
function Last_Key (Container : Map) return Key_Type is
T : Tree_Type renames Container.Tree;
begin
return Container.Tree.Last.Key;
if T.Last = null then
raise Constraint_Error;
end if;
return T.Last.Key;
end Last_Key;
----------
@ -712,6 +845,9 @@ package body Ada.Containers.Ordered_Maps 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);
@ -749,6 +885,9 @@ package body Ada.Containers.Ordered_Maps 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);
@ -771,29 +910,40 @@ package body Ada.Containers.Ordered_Maps is
Process : not null access procedure (Key : Key_Type;
Element : Element_Type))
is
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Query_Element");
declare
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -835,6 +985,14 @@ package body Ada.Containers.Ordered_Maps 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 --
-------------
@ -863,15 +1021,28 @@ package body Ada.Containers.Ordered_Maps is
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
E : Element_Type renames Position.Node.Element;
procedure Replace_Element
(Container : in out Map;
Position : Cursor;
New_Item : Element_Type)
is
begin
if Position.Container.Tree.Lock > 0 then
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
E := By;
if Container.Tree.Lock > 0 then
raise Program_Error;
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
"bad cursor in Replace_Element");
Position.Node.Element := New_Item;
end Replace_Element;
---------------------
@ -968,33 +1139,49 @@ package body Ada.Containers.Ordered_Maps is
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
T : Tree_Type renames Position.Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_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");
declare
T : Tree_Type renames Container.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
-----------
@ -1032,4 +1219,12 @@ package body Ada.Containers.Ordered_Maps 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.Ordered_Maps;

77
gcc/ada/a-coorma.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -38,9 +38,7 @@ 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 <>;
@ -49,6 +47,8 @@ generic
package Ada.Containers.Ordered_Maps is
pragma Preelaborate;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
type Map is tagged private;
type Cursor is private;
@ -69,18 +69,22 @@ package Ada.Containers.Ordered_Maps is
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
(Position : Cursor;
Process : not null access
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : in out Element_Type));
procedure Replace_Element (Position : Cursor; By : in Element_Type);
procedure Move (Target : in out Map; Source : in out Map);
procedure Insert
@ -111,6 +115,8 @@ package Ada.Containers.Ordered_Maps is
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);
@ -119,9 +125,25 @@ package Ada.Containers.Ordered_Maps is
procedure Delete_Last (Container : in out Map);
procedure Exclude (Container : in out Map; Key : Key_Type);
function First (Container : Map) return Cursor;
function Contains (Container : Map; Key : Key_Type) return Boolean;
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;
@ -131,25 +153,7 @@ package Ada.Containers.Ordered_Maps is
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;
procedure Next (Position : in out Cursor);
function Previous (Position : Cursor) return Cursor;
procedure Previous (Position : in out Cursor);
function Contains (Container : Map; Key : Key_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
@ -202,8 +206,9 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Map_Access is access Map;
type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
@ -211,9 +216,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;

319
gcc/ada/a-coormu.adb
View File

@ -6,7 +6,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 --
@ -84,6 +84,13 @@ package body Ada.Containers.Ordered_Multisets is
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
procedure Free (X : in out Node_Access);
procedure Insert_Sans_Hint
(Tree : in out Tree_Type;
New_Item : Element_Type;
Node : out Node_Access);
procedure Insert_With_Hint
(Dst_Tree : in out Tree_Type;
Dst_Hint : Node_Access;
@ -115,9 +122,6 @@ package body Ada.Containers.Ordered_Multisets is
-- Local Instantiations --
--------------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package Tree_Operations is
new Red_Black_Trees.Generic_Operations (Tree_Types);
@ -154,18 +158,44 @@ package body Ada.Containers.Ordered_Multisets is
function "<" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_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 < Right.Node.Element;
end "<";
function "<" (Left : Cursor; Right : Element_Type)
return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in ""<""");
return Left.Node.Element < Right;
end "<";
function "<" (Left : Element_Type; Right : Cursor)
return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in ""<""");
return Left < Right.Node.Element;
end "<";
@ -184,6 +214,18 @@ package body Ada.Containers.Ordered_Multisets is
function ">" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_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 < Left.Node.Element;
@ -192,12 +234,26 @@ package body Ada.Containers.Ordered_Multisets is
function ">" (Left : Cursor; Right : Element_Type)
return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in "">""");
return Right < Left.Node.Element;
end ">";
function ">" (Left : Element_Type; Right : Cursor)
return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in "">""");
return Right.Node.Element < Left;
end ">";
@ -299,7 +355,7 @@ package body Ada.Containers.Ordered_Multisets is
end loop;
end Delete;
procedure Delete (Container : in out Set; Position : in out Cursor) is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
raise Constraint_Error;
@ -309,6 +365,9 @@ package body Ada.Containers.Ordered_Multisets is
raise Program_Error;
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
"bad cursor in Delete");
Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
@ -371,9 +430,31 @@ package body Ada.Containers.Ordered_Multisets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Element");
return 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 --
---------------------
@ -460,6 +541,10 @@ package body Ada.Containers.Ordered_Multisets 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;
end First_Element;
@ -479,6 +564,24 @@ package body Ada.Containers.Ordered_Multisets is
return Cursor'(Container'Unrestricted_Access, Node);
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
X.Parent := X;
X.Left := X;
X.Right := X;
Deallocate (X);
end if;
end Free;
------------------
-- Generic_Keys --
------------------
@ -510,34 +613,6 @@ package body Ada.Containers.Ordered_Multisets is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
---------
-- "<" --
---------
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Element;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right > Left.Node.Element;
end "<";
---------
-- ">" --
---------
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Element;
end ">";
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left > Right.Node.Element;
end ">";
-------------
-- Ceiling --
-------------
@ -596,9 +671,28 @@ package body Ada.Containers.Ordered_Multisets is
Node : constant Node_Access :=
Key_Keys.Find (Container.Tree, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
return 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 --
-------------
@ -608,6 +702,7 @@ package body Ada.Containers.Ordered_Multisets is
Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
X : Node_Access;
begin
while Node /= Done loop
X := Node;
@ -657,7 +752,7 @@ package body Ada.Containers.Ordered_Multisets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left > Right.Element;
return Key (Right.Element) < Left;
end Is_Greater_Key_Node;
----------------------
@ -668,7 +763,7 @@ package body Ada.Containers.Ordered_Multisets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left < Right.Element;
return Left < Key (Right.Element);
end Is_Less_Key_Node;
-------------
@ -720,6 +815,13 @@ package body Ada.Containers.Ordered_Multisets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Key");
return Key (Position.Node.Element);
end Key;
@ -786,9 +888,12 @@ package body Ada.Containers.Ordered_Multisets is
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;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
@ -809,11 +914,7 @@ package body Ada.Containers.Ordered_Multisets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (Left => K, Right => Key (E)) then
return;
end if;
end;
@ -853,6 +954,24 @@ package body Ada.Containers.Ordered_Multisets is
(Container : in out Set;
New_Item : Element_Type;
Position : out Cursor)
is
begin
Insert_Sans_Hint
(Container.Tree,
New_Item,
Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
----------------------
-- Insert_Sans_Hint --
----------------------
procedure Insert_Sans_Hint
(Tree : in out Tree_Type;
New_Item : Element_Type;
Node : out Node_Access)
is
function New_Node return Node_Access;
pragma Inline (New_Node);
@ -869,25 +988,23 @@ package body Ada.Containers.Ordered_Multisets is
function New_Node return Node_Access is
Node : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red,
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red_Black_Trees.Red,
Element => New_Item);
begin
return Node;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert_Sans_Hint
begin
Unconditional_Insert_Sans_Hint
(Container.Tree,
(Tree,
New_Item,
Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
Node);
end Insert_Sans_Hint;
----------------------
-- Insert_With_Hint --
@ -1116,6 +1233,10 @@ package body Ada.Containers.Ordered_Multisets 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;
end Last_Element;
@ -1165,6 +1286,9 @@ package body Ada.Containers.Ordered_Multisets 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);
@ -1211,6 +1335,9 @@ package body Ada.Containers.Ordered_Multisets 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);
@ -1231,29 +1358,36 @@ package body Ada.Containers.Ordered_Multisets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element;
S : Set renames Position.Container.all;
T : Tree_Type renames S.Tree'Unrestricted_Access.all;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Query_Element");
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);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -1294,6 +1428,14 @@ package body Ada.Containers.Ordered_Multisets 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_Element --
---------------------
@ -1336,6 +1478,11 @@ package body Ada.Containers.Ordered_Multisets is
function New_Node return Node_Access is
begin
Node.Element := Item;
Node.Color := Red_Black_Trees.Red;
Node.Parent := null;
Node.Left := null;
Node.Right := null;
return Node;
end New_Node;
@ -1354,12 +1501,10 @@ package body Ada.Containers.Ordered_Multisets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all;
begin
if Position.Node = null then
raise Constraint_Error;
@ -1369,7 +1514,10 @@ package body Ada.Containers.Ordered_Multisets is
raise Program_Error;
end if;
Replace_Element (Tree, Position.Node, By);
pragma Assert (Vet (Container.Tree, Position.Node),
"bad cursor in Replace_Element");
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
@ -1514,6 +1662,19 @@ package body Ada.Containers.Ordered_Multisets 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;
begin
Insert_Sans_Hint (Tree, New_Item, Node);
return Set'(Controlled with Tree);
end To_Set;
-----------
-- Union --
-----------
@ -1564,4 +1725,12 @@ package body Ada.Containers.Ordered_Multisets 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.Ordered_Multisets;

101
gcc/ada/a-coormu.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -46,6 +46,8 @@ generic
package Ada.Containers.Ordered_Multisets is
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
type Cursor is private;
@ -58,6 +60,8 @@ package Ada.Containers.Ordered_Multisets is
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;
@ -66,18 +70,16 @@ package Ada.Containers.Ordered_Multisets is
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 Replace_Element
(Container : Set;
Position : Cursor;
By : Element_Type);
procedure Move
(Target : in out Set;
Source : in out Set);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
(Container : in out Set;
@ -88,6 +90,16 @@ package Ada.Containers.Ordered_Multisets is
(Container : in out Set;
New_Item : Element_Type);
-- TODO: include Replace too???
--
-- 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);
@ -100,10 +112,6 @@ package Ada.Containers.Ordered_Multisets is
procedure Delete_Last (Container : in out Set);
procedure Exclude
(Container : in out Set;
Item : Element_Type);
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -132,14 +140,6 @@ package Ada.Containers.Ordered_Multisets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
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 First (Container : Set) return Cursor;
function First_Element (Container : Set) return Element_Type;
@ -156,6 +156,14 @@ package Ada.Containers.Ordered_Multisets is
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;
@ -189,19 +197,23 @@ package Ada.Containers.Ordered_Multisets is
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function "<" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function ">" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
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 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;
@ -209,27 +221,13 @@ package Ada.Containers.Ordered_Multisets is
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
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;
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));
procedure (Element : in out Element_Type));
procedure Iterate
(Container : Set;
@ -271,6 +269,7 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -280,9 +279,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;

285
gcc/ada/a-coorse.adb
View File

@ -6,7 +6,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 --
@ -84,6 +84,14 @@ package body Ada.Containers.Ordered_Sets is
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
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;
@ -115,9 +123,6 @@ package body Ada.Containers.Ordered_Sets is
-- Local Instantiations --
--------------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package Tree_Operations is
new Red_Black_Trees.Generic_Operations (Tree_Types);
@ -154,16 +159,42 @@ package body Ada.Containers.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;
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 < Right.Node.Element;
end "<";
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in ""<""");
return Left.Node.Element < Right;
end "<";
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in ""<""");
return Left < Right.Node.Element;
end "<";
@ -182,6 +213,18 @@ package body Ada.Containers.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;
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 < Left.Node.Element;
@ -189,11 +232,25 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
"bad Right cursor in "">""");
return Right.Node.Element < Left;
end ">";
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
"bad Left cursor in "">""");
return Right < Left.Node.Element;
end ">";
@ -287,6 +344,9 @@ package body Ada.Containers.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;
@ -356,6 +416,13 @@ package body Ada.Containers.Ordered_Sets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Element");
return Position.Node.Element;
end Element;
@ -455,6 +522,10 @@ package body Ada.Containers.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;
end First_Element;
@ -474,6 +545,24 @@ package body Ada.Containers.Ordered_Sets is
return Cursor'(Container'Unrestricted_Access, Node);
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
X.Parent := X;
X.Left := X;
X.Right := X;
Deallocate (X);
end if;
end Free;
------------------
-- Generic_Keys --
------------------
@ -550,13 +639,15 @@ package body Ada.Containers.Ordered_Sets is
-- Element --
-------------
function Element
(Container : Set;
Key : Key_Type) return Element_Type
is
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
function Element (Container : Set; Key : Key_Type) return Element_Type is
Node : constant Node_Access :=
Key_Keys.Find (Container.Tree, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
return Node.Element;
end Element;
@ -649,6 +740,13 @@ package body Ada.Containers.Ordered_Sets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Key");
return Key (Position.Node.Element);
end Key;
@ -691,6 +789,9 @@ package body Ada.Containers.Ordered_Sets is
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;
K : constant Key_Type := Key (E);
@ -770,32 +871,6 @@ package body Ada.Containers.Ordered_Sets is
Position : out Cursor;
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
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
Node : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red,
Element => New_Item);
begin
return Node;
end New_Node;
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container.Tree,
@ -821,6 +896,48 @@ package body Ada.Containers.Ordered_Sets is
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 Conditional_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
begin
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red_Black_Trees.Red,
Element => New_Item);
end New_Node;
-- Start of processing for Insert_Sans_Hint
begin
Conditional_Insert_Sans_Hint
(Tree,
New_Item,
Node,
Inserted);
end Insert_Sans_Hint;
----------------------
-- Insert_With_Hint --
----------------------
@ -1012,6 +1129,10 @@ package body Ada.Containers.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;
end Last_Element;
@ -1055,6 +1176,9 @@ package body Ada.Containers.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);
@ -1101,6 +1225,9 @@ package body Ada.Containers.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);
@ -1127,29 +1254,36 @@ package body Ada.Containers.Ordered_Sets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element;
S : Set renames Position.Container.all;
T : Tree_Type renames S.Tree'Unrestricted_Access.all;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
if Position.Node = null then
raise Constraint_Error;
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Query_Element");
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);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -1192,6 +1326,14 @@ package body Ada.Containers.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 --
-------------
@ -1254,6 +1396,11 @@ package body Ada.Containers.Ordered_Sets is
function New_Node return Node_Access is
begin
Node.Element := Item;
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
@ -1294,6 +1441,11 @@ package body Ada.Containers.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;
@ -1330,6 +1482,9 @@ package body Ada.Containers.Ordered_Sets is
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;
@ -1436,6 +1591,20 @@ package body Ada.Containers.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 --
-----------
@ -1486,4 +1655,12 @@ package body Ada.Containers.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.Ordered_Sets;

19
gcc/ada/a-coorse.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -60,6 +60,8 @@ package Ada.Containers.Ordered_Sets is
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;
@ -255,6 +257,7 @@ private
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
@ -264,9 +267,19 @@ private
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;
Item : Cursor);
use Ada.Streams;
for Cursor'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
(Stream : access Root_Stream_Type'Class;

306
gcc/ada/a-crbtgo.adb
View File

@ -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 --
@ -49,91 +49,91 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access);
procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
---------------------
-- Check_Invariant --
---------------------
-- ---------------------
-- -- Check_Invariant --
-- ---------------------
procedure Check_Invariant (Tree : Tree_Type) is
Root : constant Node_Access := Tree.Root;
function Check (Node : Node_Access) return Natural;
-----------
-- Check --
-----------
function Check (Node : Node_Access) return Natural is
begin
if Node = null then
return 0;
end if;
if Color (Node) = Red then
declare
L : constant Node_Access := Left (Node);
begin
pragma Assert (L = null or else Color (L) = Black);
null;
end;
declare
R : constant Node_Access := Right (Node);
begin
pragma Assert (R = null or else Color (R) = Black);
null;
end;
declare
NL : constant Natural := Check (Left (Node));
NR : constant Natural := Check (Right (Node));
begin
pragma Assert (NL = NR);
return NL;
end;
end if;
declare
NL : constant Natural := Check (Left (Node));
NR : constant Natural := Check (Right (Node));
begin
pragma Assert (NL = NR);
return NL + 1;
end;
end Check;
-- Start of processing for Check_Invariant
begin
if Root = null then
pragma Assert (Tree.First = null);
pragma Assert (Tree.Last = null);
pragma Assert (Tree.Length = 0);
null;
else
pragma Assert (Color (Root) = Black);
pragma Assert (Tree.Length > 0);
pragma Assert (Tree.Root /= null);
pragma Assert (Tree.First /= null);
pragma Assert (Tree.Last /= null);
pragma Assert (Parent (Tree.Root) = null);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and Tree.First = Tree.Root));
pragma Assert (Left (Tree.First) = null);
pragma Assert (Right (Tree.Last) = null);
declare
L : constant Node_Access := Left (Root);
R : constant Node_Access := Right (Root);
NL : constant Natural := Check (L);
NR : constant Natural := Check (R);
begin
pragma Assert (NL = NR);
null;
end;
end if;
end Check_Invariant;
-- procedure Check_Invariant (Tree : Tree_Type) is
-- Root : constant Node_Access := Tree.Root;
--
-- function Check (Node : Node_Access) return Natural;
--
-- -----------
-- -- Check --
-- -----------
--
-- function Check (Node : Node_Access) return Natural is
-- begin
-- if Node = null then
-- return 0;
-- end if;
--
-- if Color (Node) = Red then
-- declare
-- L : constant Node_Access := Left (Node);
-- begin
-- pragma Assert (L = null or else Color (L) = Black);
-- null;
-- end;
--
-- declare
-- R : constant Node_Access := Right (Node);
-- begin
-- pragma Assert (R = null or else Color (R) = Black);
-- null;
-- end;
--
-- declare
-- NL : constant Natural := Check (Left (Node));
-- NR : constant Natural := Check (Right (Node));
-- begin
-- pragma Assert (NL = NR);
-- return NL;
-- end;
-- end if;
--
-- declare
-- NL : constant Natural := Check (Left (Node));
-- NR : constant Natural := Check (Right (Node));
-- begin
-- pragma Assert (NL = NR);
-- return NL + 1;
-- end;
-- end Check;
--
-- -- Start of processing for Check_Invariant
--
-- begin
-- if Root = null then
-- pragma Assert (Tree.First = null);
-- pragma Assert (Tree.Last = null);
-- pragma Assert (Tree.Length = 0);
-- null;
--
-- else
-- pragma Assert (Color (Root) = Black);
-- pragma Assert (Tree.Length > 0);
-- pragma Assert (Tree.Root /= null);
-- pragma Assert (Tree.First /= null);
-- pragma Assert (Tree.Last /= null);
-- pragma Assert (Parent (Tree.Root) = null);
-- pragma Assert ((Tree.Length > 1)
-- or else (Tree.First = Tree.Last
-- and Tree.First = Tree.Root));
-- pragma Assert (Left (Tree.First) = null);
-- pragma Assert (Right (Tree.Last) = null);
--
-- declare
-- L : constant Node_Access := Left (Root);
-- R : constant Node_Access := Right (Root);
-- NL : constant Natural := Check (L);
-- NR : constant Natural := Check (R);
-- begin
-- pragma Assert (NL = NR);
-- null;
-- end;
-- end if;
-- end Check_Invariant;
------------------
-- Delete_Fixup --
@ -249,22 +249,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
raise Program_Error;
end if;
pragma Assert (Tree.Length > 0);
pragma Assert (Tree.Root /= null);
pragma Assert (Tree.First /= null);
pragma Assert (Tree.Last /= null);
pragma Assert (Parent (Tree.Root) = null);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and then Tree.First = Tree.Root));
pragma Assert ((Left (Node) = null)
or else (Parent (Left (Node)) = Node));
pragma Assert ((Right (Node) = null)
or else (Parent (Right (Node)) = Node));
pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
or else ((Parent (Node) /= null) and then
((Left (Parent (Node)) = Node)
or else (Right (Parent (Node)) = Node))));
-- pragma Assert (Tree.Length > 0);
-- pragma Assert (Tree.Root /= null);
-- pragma Assert (Tree.First /= null);
-- pragma Assert (Tree.Last /= null);
-- pragma Assert (Parent (Tree.Root) = null);
-- pragma Assert ((Tree.Length > 1)
-- or else (Tree.First = Tree.Last
-- and then Tree.First = Tree.Root));
-- pragma Assert ((Left (Node) = null)
-- or else (Parent (Left (Node)) = Node));
-- pragma Assert ((Right (Node) = null)
-- or else (Parent (Right (Node)) = Node));
-- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
-- or else ((Parent (Node) /= null) and then
-- ((Left (Parent (Node)) = Node)
-- or else (Right (Parent (Node)) = Node))));
if Left (Z) = null then
if Right (Z) = null then
@ -545,7 +545,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
P, X : Node_Access;
begin
if Right (Source_Root) /= null then
Set_Right
(Node => Target_Root,
@ -586,7 +585,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
when others =>
Delete_Tree (Target_Root);
raise;
end Generic_Copy_Tree;
-------------------------
@ -1049,4 +1047,106 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Set_Parent (Y, X);
end Right_Rotate;
---------
-- Vet --
---------
function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
begin
if Node = null then
return True;
end if;
if Parent (Node) = Node
or else Left (Node) = Node
or else Right (Node) = Node
then
return False;
end if;
if Tree.Length = 0
or else Tree.Root = null
or else Tree.First = null
or else Tree.Last = null
then
return False;
end if;
if Parent (Tree.Root) /= null then
return False;
end if;
if Left (Tree.First) /= null then
return False;
end if;
if Right (Tree.Last) /= null 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 Node /= Tree.First then
return False;
end if;
if Parent (Node) /= null
or else Left (Node) /= null
or else Right (Node) /= null
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 /= Node
and then Tree.Last /= Node
then
return False;
end if;
end if;
if Left (Node) /= null
and then Parent (Left (Node)) /= Node
then
return False;
end if;
if Right (Node) /= null
and then Parent (Right (Node)) /= Node
then
return False;
end if;
if Parent (Node) = null then
if Tree.Root /= Node then
return False;
end if;
elsif Left (Parent (Node)) /= Node
and then Right (Parent (Node)) /= Node
then
return False;
end if;
return True;
end Vet;
end Ada.Containers.Red_Black_Trees.Generic_Operations;

11
gcc/ada/a-crbtgo.ads
View File

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- 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 --
@ -56,7 +56,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
function Max (Node : Node_Access) return Node_Access;
procedure Check_Invariant (Tree : Tree_Type);
-- NOTE: The Check_Invariant operation was used during early
-- development of the red-black tree. Now that the tree type
-- implementation has matured, we don't really need Check_Invariant
-- anymore.
-- procedure Check_Invariant (Tree : Tree_Type);
function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean;
function Next (Node : Node_Access) return Node_Access;