Skip to content

R
riscv-gcc-1
Commit ba355842 by Matthew Heaney Committed by Arnaud Charlet
Options

a-cihase.adb, [...]: Synchronized with latest draft (Draft 13, August 2005) of Ada Amendment 1. 

2005-09-01  Matthew Heaney  <heaney@adacore.com>

	* a-cihase.adb, a-coorse.ads, a-coorse.adb, a-cohama.adb,
	a-ciorse.ads, a-ciorse.adb, a-cihama.adb, a-cdlili.adb,
	a-cidlli.adb, a-chtgop.adb, a-cihase.adb, a-cihase.ads,
	a-cohase.adb, a-cohase.adb, a-cohase.ads: Synchronized with latest
	draft (Draft 13, August 2005) of Ada Amendment 1.

From-SVN: r103892
parent c1cd0d96
Showing with 1751 additions and 1723 deletions
gcc/ada/a-cdlili.adb
......@@ -38,18 +38,19 @@ with Ada.Unchecked_Deallocation;
package body Ada.Containers.Doubly_Linked_Lists is
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Free (X : in out Node_Access);
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
New_Node : Node_Access);
function Vet (Position : Cursor) return Boolean;
---------
-- "=" --
---------
......@@ -110,7 +111,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
Container.Length := 1;
Src := Src.Next;
while Src /= null loop
Container.Last.Next := new Node_Type'(Element => Src.Element,
Prev => Container.Last,
......@@ -162,9 +162,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (X.Next.Prev = Container.First);
Container.First := X.Next;
X.Next := null; -- prevent mischief
Container.First.Prev := null;
Container.Length := Container.Length - 1;
Free (X);
......@@ -181,7 +180,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Clear;
--------------
-- Continue --
-- Contains --
--------------
function Contains
......@@ -203,28 +202,16 @@ 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
pragma Assert (Position.Container = null);
raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
......@@ -249,7 +236,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
Container.Last := X.Prev;
Container.Last.Next := null;
X.Prev := null; -- prevent mischief
Free (X);
return;
end if;
......@@ -259,8 +245,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
X.Next.Prev := X.Prev;
X.Prev.Next := X.Next;
X.Next := null;
X.Prev := null;
Free (X);
end loop;
end Delete;
......@@ -298,7 +282,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
Container.Length := Container.Length - 1;
X.Next := null; -- prevent mischief
Free (X);
end loop;
end Delete_First;
......@@ -336,7 +319,6 @@ package body Ada.Containers.Doubly_Linked_Lists is
Container.Length := Container.Length - 1;
X.Prev := null; -- prevent mischief
Free (X);
end loop;
end Delete_Last;
......@@ -347,20 +329,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
pragma Assert (Vet (Position), "bad cursor in Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element;
end Element;
......@@ -379,23 +352,13 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Node = null then
Node := Container.First;
else
if Position.Container /= List_Access'(Container'Unchecked_Access) then
pragma Assert (Vet (Position), "bad cursor in Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
end if;
while Node /= null loop
......@@ -428,9 +391,27 @@ package body Ada.Containers.Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
raise Constraint_Error;
end if;
return Container.First.Element;
end First_Element;
----------
-- Free --
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
X.Prev := X;
X.Next := X;
Deallocate (X);
end Free;
---------------------
-- Generic_Sorting --
---------------------
......@@ -605,26 +586,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
------------
......@@ -641,23 +604,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Container.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Container.Last);
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
end if;
if Count = 0 then
......@@ -704,23 +656,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
New_Node : Node_Access;
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Container.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Container.Last);
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
end if;
if Count = 0 then
......@@ -853,6 +794,10 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
raise Constraint_Error;
end if;
return Container.Last.Element;
end Last_Element;
......@@ -900,25 +845,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Next (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
Position.Node := Position.Node.Next;
if Position.Node = null then
......@@ -928,25 +860,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
......@@ -977,25 +896,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous");
if Position.Node = null then
pragma Assert (Position.Container = null);
return;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
Position.Node := Position.Node.Prev;
if Position.Node = null then
......@@ -1005,25 +911,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Previous (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
......@@ -1043,42 +936,34 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
E : Element_Type renames Position.Node.Element;
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.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;
----------
......@@ -1141,29 +1026,18 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Position : Cursor;
By : Element_Type)
is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
E : Element_Type renames Position.Node.Element;
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
raise Program_Error;
end if;
E := By;
Position.Node.Element := By;
end Replace_Element;
------------------
......@@ -1180,23 +1054,13 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Node = null then
Node := Container.Last;
else
if Position.Container /= List_Access'(Container'Unchecked_Access) then
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
end if;
while Node /= null loop
......@@ -1336,23 +1200,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
Source : in out List)
is
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Vet (Before), "bad cursor in Splice");
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
end if;
if Target'Address = Source'Address
......@@ -1421,46 +1274,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
Position : Cursor)
is
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unchecked_Access
then
raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Target'Unchecked_Access) then
if Position.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Target.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Target.Last);
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
......@@ -1548,46 +1378,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
return;
end if;
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Source'Unchecked_Access) then
if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Source.Length >= 1);
pragma Assert (Source.First.Prev = null);
pragma Assert (Source.Last.Next = null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Source.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Source.Last);
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
......@@ -1600,12 +1407,14 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Position.Node = Source.First then
Source.First := Position.Node.Next;
Source.First.Prev := null;
if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
else
Source.First.Prev := null;
end if;
elsif Position.Node = Source.Last then
......@@ -1667,8 +1476,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Swap (I, J : Cursor) is
begin
if I.Container = null
or else J.Container = null
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;
......@@ -1677,51 +1489,22 @@ package body Ada.Containers.Doubly_Linked_Lists is
raise Program_Error;
end if;
declare
C : List renames I.Container.all;
begin
pragma Assert (C.Length >= 1);
pragma Assert (C.First.Prev = null);
pragma Assert (C.Last.Next = null);
pragma Assert (I.Node /= null);
pragma Assert (I.Node.Prev = null
or else I.Node.Prev.Next = I.Node);
pragma Assert (I.Node.Next = null
or else I.Node.Next.Prev = I.Node);
pragma Assert (I.Node.Prev /= null
or else I.Node = C.First);
pragma Assert (I.Node.Next /= null
or else I.Node = C.Last);
if I.Node = J.Node then
return;
end if;
if I.Node = J.Node then
return;
end if;
pragma Assert (C.Length >= 2);
pragma Assert (J.Node /= null);
pragma Assert (J.Node.Prev = null
or else J.Node.Prev.Next = J.Node);
pragma Assert (J.Node.Next = null
or else J.Node.Next.Prev = J.Node);
pragma Assert (J.Node.Prev /= null
or else J.Node = C.First);
pragma Assert (J.Node.Next /= null
or else J.Node = C.Last);
if C.Lock > 0 then
raise Program_Error;
end if;
if I.Container.Lock > 0 then
raise Program_Error;
end if;
declare
EI : Element_Type renames I.Node.Element;
EJ : Element_Type renames J.Node.Element;
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;
end;
EI_Copy : constant Element_Type := EI;
begin
EI := EJ;
EJ := EI_Copy;
end;
end Swap;
......@@ -1733,50 +1516,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Container : in out List;
I, J : Cursor) is
begin
if I.Container = null
or else J.Container = null
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
raise Constraint_Error;
end if;
if I.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
if J.Container /= I.Container then
if I.Container /= Container'Unrestricted_Access
or else I.Container /= J.Container
then
raise Program_Error;
end if;
pragma Assert (Container.Length >= 1);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (I.Node /= null);
pragma Assert (I.Node.Prev = null
or else I.Node.Prev.Next = I.Node);
pragma Assert (I.Node.Next = null
or else I.Node.Next.Prev = I.Node);
pragma Assert (I.Node.Prev /= null
or else I.Node = Container.First);
pragma Assert (I.Node.Next /= null
or else I.Node = Container.Last);
if I.Node = J.Node then
return;
end if;
pragma Assert (Container.Length >= 2);
pragma Assert (J.Node /= null);
pragma Assert (J.Node.Prev = null
or else J.Node.Prev.Next = J.Node);
pragma Assert (J.Node.Next = null
or else J.Node.Next.Prev = J.Node);
pragma Assert (J.Node.Prev /= null
or else J.Node = Container.First);
pragma Assert (J.Node.Next /= null
or else J.Node = Container.Last);
if Container.Busy > 0 then
raise Program_Error;
end if;
......@@ -1813,46 +1571,177 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type)) is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length >= 1);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
E : Element_Type renames Position.Node.Element;
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
Process : not null access procedure (Element : in out Element_Type))
is
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.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 Update_Element;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
if Position.Node.Prev = Position.Node then
return False;
end if;
declare
L : List renames Position.Container.all;
begin
if L.Length = 0 then
return False;
end if;
if L.First = null then
return False;
end if;
if L.Last = null then
return False;
end if;
if L.First.Prev /= null then
return False;
end if;
if L.Last.Next /= null then
return False;
end if;
if Position.Node.Prev = null
and then Position.Node /= L.First
then
return False;
end if;
if Position.Node.Next = null
and then Position.Node /= L.Last
then
return False;
end if;
if L.Length = 1 then
return L.First = L.Last;
end if;
if L.First = L.Last then
return False;
end if;
if L.First.Next = null then
return False;
end if;
if L.Last.Prev = null then
return False;
end if;
if L.First.Next.Prev /= L.First then
return False;
end if;
if L.Last.Prev.Next /= L.Last then
return False;
end if;
if L.Length = 2 then
if L.First.Next /= L.Last then
return False;
end if;
if L.Last.Prev /= L.First then
return False;
end if;
return True;
end if;
if L.First.Next = L.Last then
return False;
end if;
if L.Last.Prev = L.First then
return False;
end if;
if Position.Node = L.First then
return True;
end if;
if Position.Node = L.Last then
return True;
end if;
if Position.Node.Next = null then
return False;
end if;
if Position.Node.Prev = null then
return False;
end if;
if Position.Node.Next.Prev /= Position.Node then
return False;
end if;
if Position.Node.Prev.Next /= Position.Node then
return False;
end if;
if L.Length = 3 then
if L.First.Next /= Position.Node then
return False;
end if;
if L.Last.Prev /= Position.Node then
return False;
end if;
end if;
return True;
end;
end Vet;
-----------
-- Write --
-----------
......
gcc/ada/a-chtgop.adb
......@@ -42,14 +42,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
procedure Free is
new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Rehash
(HT : in out Hash_Table_Type;
Size : Hash_Type);
------------
-- Adjust --
------------
......@@ -405,27 +397,33 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
begin
Clear (HT);
declare
B : Buckets_Access := HT.Buckets;
begin
HT.Buckets := null;
HT.Length := 0;
Free (B); -- can this fail???
end;
Hash_Type'Read (Stream, Last);
-- TODO: don't immediately deallocate the buckets array we
-- already have. Instead, allocate a new buckets array only
-- if it needs to expanded because of the value of Last.
Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
if N = 0 then
return;
end if;
if Last /= 0 then
if HT.Buckets = null
or else HT.Buckets'Last /= Last
then
Free (HT.Buckets);
HT.Buckets := new Buckets_Type (0 .. Last);
end if;
Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
while N > 0 loop
-- TODO: should we rewrite this algorithm so that it doesn't
-- depend on preserving the exactly length of the hash table
-- array? We would prefer to not have to (re)allocate a
-- buckets array (the array that HT already has might be large
-- enough), and to not have to stream the count of the number
-- of nodes in each bucket. The algorithm below is vestigial,
-- as it was written prior to the meeting in Palma, when the
-- semantics of equality were changed (and which obviated the
-- need to preserve the hash table length).
loop
Hash_Type'Read (Stream, I);
pragma Assert (I in HT.Buckets'Range);
pragma Assert (HT.Buckets (I) = null);
......@@ -454,6 +452,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
end loop;
N := N - M;
exit when N = 0;
end loop;
end Generic_Read;
......@@ -481,6 +481,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return;
end if;
-- TODO: see note in Generic_Read???
for Indx in HT.Buckets'Range loop
X := HT.Buckets (Indx);
......@@ -577,104 +579,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return null;
end Next;
------------
-- Rehash --
------------
procedure Rehash
(HT : in out Hash_Table_Type;
Size : Hash_Type)
is
subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
Src_Buckets : Buckets_Access := HT.Buckets;
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
begin
if Src_Buckets = null then
pragma Assert (L = 0);
HT.Buckets := Dst_Buckets;
return;
end if;
if L = 0 then
HT.Buckets := Dst_Buckets;
Free (Src_Buckets);
return;
end if;
-- We might want to change this to iter from 1 .. L instead ???
for Src_Index in Src_Buckets'Range loop
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
begin
while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
Index (Dst_Buckets.all, Src_Node);
Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
begin
Src_Bucket := Next (Src_Node);
Set_Next (Src_Node, Dst_Bucket);
Dst_Bucket := Src_Node;
end;
pragma Assert (L > 0);
L := L - 1;
end loop;
exception
when others =>
-- NOTE: see todo below.
-- Not clear that we can deallocate the nodes,
-- because they may be designated by outstanding
-- iterators. Which means they're now lost... ???
-- for J in NB'Range loop
-- declare
-- Dst : Node_Access renames NB (J);
-- X : Node_Access;
-- begin
-- while Dst /= null loop
-- X := Dst;
-- Dst := Succ (Dst);
-- Free (X);
-- end loop;
-- end;
-- end loop;
-- TODO: 17 Apr 2005
-- What I should do instead is go ahead and deallocate the
-- nodes, since when assertions are enabled, we vet the
-- cursors, and we modify the state of a node enough when
-- it is deallocated in order to detect mischief.
-- END TODO.
Free (Dst_Buckets);
raise; -- TODO: raise Program_Error instead
end;
-- exit when L = 0;
-- need to bother???
end loop;
pragma Assert (L = 0);
HT.Buckets := Dst_Buckets;
HT.Length := LL;
Free (Src_Buckets);
end Rehash;
----------------------
-- Reserve_Capacity --
----------------------
......@@ -686,74 +590,142 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
NN : Hash_Type;
begin
if N = 0 then
if HT.Length = 0 then
Free (HT.Buckets);
if HT.Buckets = null then
if N > 0 then
NN := Prime_Numbers.To_Prime (N);
HT.Buckets := new Buckets_Type (0 .. NN - 1);
end if;
elsif HT.Length < HT.Buckets'Length then
NN := Prime_Numbers.To_Prime (HT.Length);
return;
end if;
-- ASSERT: NN >= HT.Length
if HT.Length = 0 then
if N = 0 then
Free (HT.Buckets);
return;
end if;
if NN < HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
end if;
if N = HT.Buckets'Length then
return;
end if;
Rehash (HT, Size => NN);
end if;
NN := Prime_Numbers.To_Prime (N);
if NN = HT.Buckets'Length then
return;
end if;
declare
X : Buckets_Access := HT.Buckets;
begin
HT.Buckets := new Buckets_Type (0 .. NN - 1);
Free (X);
end;
return;
end if;
if HT.Buckets = null then
NN := Prime_Numbers.To_Prime (N);
-- ASSERT: NN >= N
Rehash (HT, Size => NN);
if N = HT.Buckets'Length then
return;
end if;
if N <= HT.Length then
if N < HT.Buckets'Length then
if HT.Length >= HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (HT.Length);
-- ASSERT: NN >= HT.Length
if NN >= HT.Buckets'Length then
return;
end if;
if NN < HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
end if;
else
NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
Rehash (HT, Size => NN);
if NN = HT.Buckets'Length then -- can't expand any more
return;
end if;
end if;
return;
if HT.Busy > 0 then
raise Program_Error;
end if;
-- ASSERT: N > HT.Length
Rehash : declare
Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
Src_Buckets : Buckets_Access := HT.Buckets;
if N = HT.Buckets'Length then
return;
end if;
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
NN := Prime_Numbers.To_Prime (N);
Src_Index : Hash_Type := Src_Buckets'First;
-- ASSERT: NN >= N
-- ASSERT: NN > HT.Length
begin
while L > 0 loop
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
if NN /= HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
end if;
begin
while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
Index (Dst_Buckets.all, Src_Node);
Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
begin
Src_Bucket := Next (Src_Node);
Set_Next (Src_Node, Dst_Bucket);
Dst_Bucket := Src_Node;
end;
pragma Assert (L > 0);
L := L - 1;
end loop;
exception
when others =>
-- If there's an error computing a hash value during a
-- rehash, then AI-302 says the nodes "become lost." The
-- issue is whether to actually deallocate these lost nodes,
-- since they might be designated by extant cursors. Here
-- we decide to deallocate the nodes, since it's better to
-- solve real problems (storage consumption) rather than
-- imaginary ones (the user might, or might not, dereference
-- a cursor designating a node that has been deallocated),
-- and because we have a way to vet a dangling cursor
-- reference anyway, and hence can actually detect the
-- problem.
for Dst_Index in Dst_Buckets'Range loop
declare
B : Node_Access renames Dst_Buckets (Dst_Index);
X : Node_Access;
begin
while B /= null loop
X := B;
B := Next (X);
Free (X);
end loop;
end;
end loop;
Free (Dst_Buckets);
raise Program_Error;
end;
Rehash (HT, Size => NN);
end if;
Src_Index := Src_Index + 1;
end loop;
HT.Buckets := Dst_Buckets;
HT.Length := LL;
Free (Src_Buckets);
end Rehash;
end Reserve_Capacity;
end Ada.Containers.Hash_Tables.Generic_Operations;
gcc/ada/a-cidlli.adb
......@@ -40,20 +40,21 @@ with Ada.Unchecked_Deallocation;
package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Free (X : in out Node_Access);
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
New_Node : Node_Access);
function Vet (Position : Cursor) return Boolean;
---------
-- "=" --
---------
......@@ -188,18 +189,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Container.First := X.Next;
Container.First.Prev := null;
Container.Length := Container.Length - 1;
X.Next := null; -- prevent mischief
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Container.Length := Container.Length - 1;
Free (X);
end loop;
......@@ -211,15 +202,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Container.Last := null;
Container.Length := 0;
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Free (X);
end Clear;
......@@ -246,28 +228,16 @@ 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.Container /= List_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
......@@ -292,17 +262,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Container.Last := X.Prev;
Container.Last.Next := null;
X.Prev := null; -- prevent mischief
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Free (X);
return;
end if;
......@@ -312,18 +271,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
X.Next.Prev := X.Prev;
X.Prev.Next := X.Next;
X.Prev := null;
X.Next := null;
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Free (X);
end loop;
end Delete;
......@@ -361,17 +308,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Container.Length := Container.Length - 1;
X.Next := null; -- prevent mischief
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Free (X);
end loop;
end Delete_First;
......@@ -409,17 +345,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Container.Length := Container.Length - 1;
X.Prev := null; -- prevent mischief
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Free (X);
raise;
end;
Free (X);
end loop;
end Delete_Last;
......@@ -430,21 +355,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
pragma Assert (Vet (Position), "bad cursor in Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element.all;
end Element;
......@@ -465,23 +380,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Node := Container.First;
else
if Position.Container /= List_Access'(Container'Unchecked_Access) then
pragma Assert (Vet (Position), "bad cursor in Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
end if;
while Node /= null loop
......@@ -514,9 +417,37 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
raise Constraint_Error;
end if;
return Container.First.Element.all;
end First_Element;
----------
-- Free --
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
X.Next := X;
X.Prev := X;
begin
Free (X.Element);
exception
when others =>
X.Element := null;
Deallocate (X);
raise;
end;
Deallocate (X);
end Free;
---------------------
-- Generic_Sorting --
---------------------
......@@ -686,27 +617,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
------------
......@@ -723,24 +635,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
New_Node : Node_Access;
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Vet (Before), "bad cursor in Insert");
pragma Assert (Before.Node.Element /= null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Container.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Container.Last);
if Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error;
end if;
if Count = 0 then
......@@ -884,32 +784,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end Iterate;
----------
-- Move --
----------
procedure Move (Target : in out List; Source : in out List) is
begin
if Target'Address = Source'Address then
return;
end if;
if Source.Busy > 0 then
raise Program_Error;
end if;
Clear (Target);
Target.First := Source.First;
Source.First := null;
Target.Last := Source.Last;
Source.Last := null;
Target.Length := Source.Length;
Source.Length := 0;
end Move;
----------
-- Last --
----------
......@@ -928,6 +802,10 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
raise Constraint_Error;
end if;
return Container.Last.Element.all;
end Last_Element;
......@@ -941,31 +819,43 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end Length;
----------
-- Move --
----------
procedure Move (Target : in out List; Source : in out List) is
begin
if Target'Address = Source'Address then
return;
end if;
if Source.Busy > 0 then
raise Program_Error;
end if;
Clear (Target);
Target.First := Source.First;
Source.First := null;
Target.Last := Source.Last;
Source.Last := null;
Target.Length := Source.Length;
Source.Length := 0;
end Move;
----------
-- Next --
----------
procedure Next (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
Position.Node := Position.Node.Next;
if Position.Node = null then
......@@ -975,26 +865,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
......@@ -1025,26 +901,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous");
if Position.Node = null then
pragma Assert (Position.Container = null);
return;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
Position.Node := Position.Node.Prev;
if Position.Node = null then
......@@ -1054,26 +916,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Previous (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
......@@ -1093,43 +941,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
E : Element_Type renames Position.Node.Element.all;
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.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;
----------
......@@ -1193,31 +1032,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Position : Cursor;
By : Element_Type)
is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
X : Element_Access := Position.Node.Element;
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
raise Program_Error;
end if;
Position.Node.Element := new Element_Type'(By);
Free (X);
declare
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Free (X);
end;
end Replace_Element;
------------------
......@@ -1236,23 +1067,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Node := Container.Last;
else
if Position.Container /= List_Access'(Container'Unchecked_Access) then
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Container.Length > 0);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Container.Last);
end if;
while Node /= null loop
......@@ -1392,24 +1211,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Source : in out List)
is
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Vet (Before), "bad cursor in Splice");
pragma Assert (Before.Node.Element /= null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
end if;
if Target'Address = Source'Address
......@@ -1477,48 +1284,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Position : Cursor)
is
begin
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
pragma Assert (Before.Node.Element /= null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unchecked_Access
then
raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Target'Unchecked_Access) then
if Position.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Target.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Target.Last);
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
......@@ -1606,48 +1388,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
return;
end if;
if Before.Node /= null then
if Before.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
pragma Assert (Target.Length >= 1);
pragma Assert (Target.First.Prev = null);
pragma Assert (Target.Last.Next = null);
pragma Assert (Vet (Before), "bad Before cursor in Splice");
pragma Assert (Vet (Position), "bad Position cursor in Splice");
pragma Assert (Before.Node.Element /= null);
pragma Assert (Before.Node.Prev = null
or else Before.Node.Prev.Next = Before.Node);
pragma Assert (Before.Node.Next = null
or else Before.Node.Next.Prev = Before.Node);
pragma Assert (Before.Node.Prev /= null
or else Before.Node = Target.First);
pragma Assert (Before.Node.Next /= null
or else Before.Node = Target.Last);
if Before.Container /= null
and then Before.Container /= Target'Unrestricted_Access
then
raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Source'Unchecked_Access) then
if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Source.Length >= 1);
pragma Assert (Source.First.Prev = null);
pragma Assert (Source.Last.Next = null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Source.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Source.Last);
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
......@@ -1660,12 +1417,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Position.Node = Source.First then
Source.First := Position.Node.Next;
Source.First.Prev := null;
if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
else
Source.First.Prev := null;
end if;
elsif Position.Node = Source.Last then
......@@ -1727,8 +1486,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Swap (I, J : Cursor) is
begin
if I.Container = null
or else J.Container = null
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;
......@@ -1737,50 +1499,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
raise Program_Error;
end if;
declare
C : List renames I.Container.all;
begin
pragma Assert (C.Length > 0);
pragma Assert (C.First.Prev = null);
pragma Assert (C.Last.Next = null);
pragma Assert (I.Node /= null);
pragma Assert (I.Node.Element /= null);
pragma Assert (I.Node.Prev = null
or else I.Node.Prev.Next = I.Node);
pragma Assert (I.Node.Next = null
or else I.Node.Next.Prev = I.Node);
pragma Assert (I.Node.Prev /= null
or else I.Node = C.First);
pragma Assert (I.Node.Next /= null
or else I.Node = C.Last);
if I.Node = J.Node then
return;
end if;
if I.Node = J.Node then
return;
end if;
pragma Assert (C.Length > 1);
pragma Assert (J.Node /= null);
pragma Assert (J.Node.Element /= null);
pragma Assert (J.Node.Prev = null
or else J.Node.Prev.Next = J.Node);
pragma Assert (J.Node.Next = null
or else J.Node.Next.Prev = J.Node);
pragma Assert (J.Node.Prev /= null
or else J.Node = C.First);
pragma Assert (J.Node.Next /= null
or else J.Node = C.Last);
if C.Lock > 0 then
raise Program_Error;
end if;
if I.Container.Lock > 0 then
raise Program_Error;
end if;
declare
EI_Copy : constant Element_Access := I.Node.Element;
begin
I.Node.Element := J.Node.Element;
J.Node.Element := EI_Copy;
end;
declare
EI_Copy : constant Element_Access := I.Node.Element;
begin
I.Node.Element := J.Node.Element;
J.Node.Element := EI_Copy;
end;
end Swap;
......@@ -1793,51 +1524,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Container = null
or else J.Container = null
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
raise Constraint_Error;
end if;
if I.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
if J.Container /= I.Container then
if I.Container /= Container'Unrestricted_Access
or else I.Container /= J.Container
then
raise Program_Error;
end if;
pragma Assert (Container.Length >= 1);
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
pragma Assert (I.Node /= null);
pragma Assert (I.Node.Element /= null);
pragma Assert (I.Node.Prev = null
or else I.Node.Prev.Next = I.Node);
pragma Assert (I.Node.Next = null
or else I.Node.Next.Prev = I.Node);
pragma Assert (I.Node.Prev /= null
or else I.Node = Container.First);
pragma Assert (I.Node.Next /= null
or else I.Node = Container.Last);
if I.Node = J.Node then
return;
end if;
pragma Assert (Container.Length >= 2);
pragma Assert (J.Node /= null);
pragma Assert (J.Node.Element /= null);
pragma Assert (J.Node.Prev = null
or else J.Node.Prev.Next = J.Node);
pragma Assert (J.Node.Next = null
or else J.Node.Next.Prev = J.Node);
pragma Assert (J.Node.Prev /= null
or else J.Node = Container.First);
pragma Assert (J.Node.Next /= null
or else J.Node = Container.Last);
if Container.Busy > 0 then
raise Program_Error;
end if;
......@@ -1878,45 +1583,179 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
pragma Assert (Position.Container /= null);
pragma Assert (Position.Container.Length > 0);
pragma Assert (Position.Container.First.Prev = null);
pragma Assert (Position.Container.Last.Next = null);
pragma Assert (Position.Node /= null);
pragma Assert (Position.Node.Element /= null);
pragma Assert (Position.Node.Prev = null
or else Position.Node.Prev.Next = Position.Node);
pragma Assert (Position.Node.Next = null
or else Position.Node.Next.Prev = Position.Node);
pragma Assert (Position.Node.Prev /= null
or else Position.Node = Position.Container.First);
pragma Assert (Position.Node.Next /= null
or else Position.Node = Position.Container.Last);
E : Element_Type renames Position.Node.Element.all;
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
C : List renames Position.Container.all'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.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 Update_Element;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
if Position.Node.Prev = Position.Node then
return False;
end if;
if Position.Node.Element = null then
return False;
end if;
declare
L : List renames Position.Container.all;
begin
if L.Length = 0 then
return False;
end if;
if L.First = null then
return False;
end if;
if L.Last = null then
return False;
end if;
if L.First.Prev /= null then
return False;
end if;
if L.Last.Next /= null then
return False;
end if;
if Position.Node.Prev = null
and then Position.Node /= L.First
then
return False;
end if;
if Position.Node.Next = null
and then Position.Node /= L.Last
then
return False;
end if;
if L.Length = 1 then
return L.First = L.Last;
end if;
if L.First = L.Last then
return False;
end if;
if L.First.Next = null then
return False;
end if;
if L.Last.Prev = null then
return False;
end if;
if L.First.Next.Prev /= L.First then
return False;
end if;
if L.Last.Prev.Next /= L.Last then
return False;
end if;
if L.Length = 2 then
if L.First.Next /= L.Last then
return False;
end if;
if L.Last.Prev /= L.First then
return False;
end if;
return True;
end if;
if L.First.Next = L.Last then
return False;
end if;
if L.Last.Prev = L.First then
return False;
end if;
if Position.Node = L.First then
return True;
end if;
if Position.Node = L.Last then
return True;
end if;
if Position.Node.Next = null then
return False;
end if;
if Position.Node.Prev = null then
return False;
end if;
if Position.Node.Next.Prev /= Position.Node then
return False;
end if;
if Position.Node.Prev.Next /= Position.Node then
return False;
end if;
if L.Length = 3 then
if L.First.Next /= Position.Node then
return False;
end if;
if L.Last.Prev /= Position.Node then
return False;
end if;
end if;
return True;
end;
end Vet;
-----------
-- Write --
-----------
......@@ -1926,8 +1765,10 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Item : List)
is
Node : Node_Access := Item.First;
begin
Count_Type'Base'Write (Stream, Item.Length);
while Node /= null loop
Element_Type'Output (Stream, Node.Element.all); -- X.all
Node := Node.Next;
......
gcc/ada/a-cihama.adb
......@@ -194,19 +194,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
return;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Position.Node.Next /= Position.Node);
pragma Assert (Position.Node.Key /= null);
pragma Assert (Position.Node.Element /= null);
if Container.HT.Busy > 0 then
raise Program_Error;
end if;
......@@ -222,14 +219,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-------------
function Element (Container : Map; Key : Key_Type) return Element_Type is
C : constant Cursor := Find (Container, Key);
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
return C.Node.Element.all;
if Node = null then
raise Constraint_Error;
end if;
return Node.Element.all;
end Element;
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element.all;
end Element;
......@@ -251,8 +258,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Equivalent_Keys (Left, Right : Cursor) return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Right));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
end Equivalent_Keys;
......@@ -261,7 +275,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Key_Type) return Boolean
is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key.all, Right);
end Equivalent_Keys;
......@@ -270,7 +289,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Cursor) return Boolean
is
begin
pragma Assert (Vet (Right));
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left, Right.Node.Key.all);
end Equivalent_Keys;
......@@ -338,6 +362,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function First (Container : Map) return Cursor is
Node : constant Node_Access := HT_Ops.First (Container.HT);
begin
if Node = null then
return No_Element;
......@@ -396,13 +421,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Vet (Position));
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
......@@ -468,7 +488,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
is
function New_Node (Next : Node_Access) return Node_Access;
procedure Insert is
procedure Local_Insert is
new Key_Ops.Generic_Conditional_Insert (New_Node);
--------------
......@@ -478,6 +498,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function New_Node (Next : Node_Access) return Node_Access is
K : Key_Access := new Key_Type'(Key);
E : Element_Access;
begin
E := new Element_Type'(New_Item);
return new Node_Type'(K, E, Next);
......@@ -493,12 +514,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: see note in a-cohama.adb.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, Key, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
......@@ -562,7 +589,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Key.all;
end Key;
......@@ -603,13 +635,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
pragma Assert (Vet (Position));
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
......@@ -631,32 +663,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
if Position.Node = null then
raise Constraint_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
begin
B := B + 1;
L := L + 1;
B : Natural renames HT.Busy;
L : Natural renames HT.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;
----------
......@@ -748,15 +788,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
pragma Assert (Vet (Position));
X : Element_Access := Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
declare
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end;
end Replace_Element;
----------------------
......@@ -789,32 +838,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
pragma Assert (Vet (Position));
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
if Position.Node = null then
raise Constraint_Error;
end if;
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
B : Natural renames HT.Busy;
L : Natural renames HT.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;
---------
......@@ -824,6 +881,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
......@@ -842,12 +903,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null then
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
......@@ -862,7 +926,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
return False;
end if;
if X = X.Next then -- weird
if X = X.Next then -- to prevent endless loop
return False;
end if;
......
gcc/ada/a-cihase.adb
......@@ -84,13 +84,15 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type);
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
function Vet (Position : Cursor) return Boolean;
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
......@@ -217,11 +219,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Position : in out Cursor)
is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
......@@ -232,7 +240,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
......@@ -351,6 +358,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then -- handle dangling reference
raise Program_Error;
end if;
return Position.Node.Element.all;
end Element;
......@@ -370,6 +387,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
if Left.Node.Element = null -- handle dangling cursor reference
or else Right.Node.Element = null
then
raise Program_Error;
end if;
return Equivalent_Elements
(Left.Node.Element.all,
Right.Node.Element.all);
......@@ -378,12 +410,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
if Left.Node.Element = null then -- handling dangling reference
raise Program_Error;
end if;
return Equivalent_Elements (Left.Node.Element.all, Right);
end Equivalent_Elements;
function Equivalent_Elements (Left : Element_Type; Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
if Right.Node.Element = null then -- handle dangling cursor reference
raise Program_Error;
end if;
return Equivalent_Elements (Left, Right.Node.Element.all);
end Equivalent_Elements;
......@@ -520,6 +572,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return;
end if;
X.Next := X; -- detect mischief (in Vet)
begin
Free_Element (X.Element);
exception
......@@ -538,12 +592,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
......@@ -597,7 +647,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Insert is
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
......@@ -620,12 +670,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: optimize this (see a-cohase.adb)
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
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 (HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
......@@ -763,7 +819,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Is_Empty (Container : Set) return Boolean is
begin
return Container.Length = 0;
return Container.HT.Length = 0;
end Is_Empty;
-----------
......@@ -833,22 +889,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Process_Node;
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
begin
Iterate (HT);
exception
when others =>
B := B - 1;
raise;
end;
-- TODO: resolve whether HT_Ops.Generic_Iteration should
-- manipulate busy bit.
B := B - 1;
Iterate (HT);
end Iterate;
------------
......@@ -880,11 +928,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
......@@ -939,29 +992,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element.all;
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
if Position.Node = null then
raise Constraint_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
if Position.Node.Element = null then
raise Program_Error;
end if;
begin
B := B + 1;
L := L + 1;
declare
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.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;
----------
......@@ -1027,13 +1091,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
---------------------
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type)
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element.all, Element) then
pragma Assert (Hash (Node.Element.all) = Hash (Element));
if Equivalent_Elements (Node.Element.all, New_Item) then
pragma Assert (Hash (Node.Element.all) = Hash (New_Item));
if HT.Lock > 0 then
raise Program_Error;
......@@ -1042,7 +1106,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
declare
X : Element_Access := Node.Element;
begin
Node.Element := new Element_Type'(Element); -- OK if fails
Node.Element := new Element_Type'(New_Item); -- OK if fails
Free_Element (X);
end;
......@@ -1068,7 +1132,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := new Element_Type'(Element); -- OK if fails
Node.Element := new Element_Type'(New_Item); -- OK if fails
Node.Next := Next;
return Node;
end New_Node;
......@@ -1084,7 +1148,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Attempt_Insert : begin
Insert
(HT => HT,
Key => Element,
Key => New_Item,
Node => Result,
Inserted => Inserted);
exception
......@@ -1093,7 +1157,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Attempt_Insert;
if Inserted then
pragma Assert (Result = Node);
Free_Element (X); -- Just propagate if fails
return;
end if;
......@@ -1137,22 +1200,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
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 (HT, Position.Node, By);
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
----------------------
......@@ -1613,6 +1680,65 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Union;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
if Position.Node.Element = null then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
for J in 1 .. HT.Length loop
if X = Position.Node then
return True;
end if;
if X = null then
return False;
end if;
if X = X.Next then -- to prevent unnecessary looping
return False;
end if;
X := X.Next;
end loop;
return False;
end;
end Vet;
-----------
-- Write --
-----------
......@@ -1714,29 +1840,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Key : Key_Type;
Node : Node_Access) return Boolean is
begin
return Equivalent_Keys (Key, Node.Element.all);
return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
end Equivalent_Key_Node;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean
is
begin
return Equivalent_Keys (Right, Left.Node.Element.all);
end Equivalent_Keys;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean
is
begin
return Equivalent_Keys (Left, Right.Node.Element.all);
end Equivalent_Keys;
-------------
-- Exclude --
-------------
......@@ -1775,6 +1881,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
return Key (Position.Node.Element.all);
end Key;
......@@ -1804,20 +1920,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type))
is
HT : Hash_Table_Type renames Container.HT;
HT : Hash_Table_Type renames Container.HT;
Indx : Hash_Type;
begin
pragma Assert
(Vet (Position),
"bad cursor in Update_Element_Preserving_Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Node.Element = null
or else Position.Node.Next = Position.Node
then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
or else HT.Length = 0
then
raise Program_Error;
end if;
Indx := HT_Ops.Index (HT, Position.Node);
declare
E : Element_Type renames Position.Node.Element.all;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
......@@ -1838,16 +1974,38 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, E) then
if Equivalent_Keys (K, Key (E)) then
pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
if HT.Buckets (Indx) = Position.Node then
HT.Buckets (Indx) := Position.Node.Next;
else
declare
Prev : Node_Access := HT.Buckets (Indx);
begin
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
if Prev = null then
raise Program_Error;
end if;
end loop;
Prev.Next := Position.Node.Next;
end;
end if;
HT.Length := HT.Length - 1;
declare
X : Node_Access := Position.Node;
begin
HT_Ops.Delete_Node_Sans_Free (HT, X);
Free (X);
end;
......
gcc/ada/a-cihase.ads
......@@ -49,8 +49,7 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Hashed_Sets is
pragma Preelaborate (Indefinite_Hashed_Sets);
pragma Preelaborate;
type Set is tagged private;
......@@ -64,6 +63,12 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Sets (Left, Right : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
......@@ -72,15 +77,15 @@ package Ada.Containers.Indefinite_Hashed_Sets 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);
......@@ -97,37 +102,11 @@ package Ada.Containers.Indefinite_Hashed_Sets is
procedure Replace (Container : in out Set; New_Item : Element_Type);
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Exclude (Container : in out Set; Item : Element_Type);
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find (Container : Set; Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Union (Target : in out Set; Source : Set);
......@@ -158,41 +137,59 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
function First (Container : Set) return Cursor;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Find (Container : Set; Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
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 Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys
(Key : Key_Type;
Element : Element_Type) return Boolean;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
function Find (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 Replace
procedure Replace -- TODO: ask Randy why this is still here
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
......@@ -200,13 +197,6 @@ package Ada.Containers.Indefinite_Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type));
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean;
end Generic_Keys;
private
......
gcc/ada/a-ciorse.adb
......@@ -369,6 +369,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
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 --
---------------------
......@@ -528,34 +543,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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 --
-------------
......@@ -609,6 +596,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
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 --
-------------
......@@ -663,7 +665,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left > Right.Element.all;
return Key (Right.Element.all) < Left;
end Is_Greater_Key_Node;
----------------------
......@@ -674,7 +676,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left < Right.Element.all;
return Left < Key (Right.Element.all);
end Is_Less_Key_Node;
---------
......@@ -728,7 +730,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
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;
......@@ -749,11 +751,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
......@@ -1365,12 +1363,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets 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;
......@@ -1380,7 +1376,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
raise Program_Error;
end if;
Replace_Element (Tree, Position.Node, By);
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
......
gcc/ada/a-ciorse.ads
......@@ -45,7 +45,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Ordered_Sets is
pragma Preelaborate (Indefinite_Ordered_Sets);
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
......@@ -67,15 +69,15 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
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; -- TODO: need ruling from ARG
Position : Cursor;
By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
......@@ -96,6 +98,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
(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);
......@@ -108,10 +114,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
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;
......@@ -124,8 +126,7 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
function "and" (Left, Right : Set) return Set renames Intersection;
procedure Difference (Target : in out Set;
Source : Set);
procedure Difference (Target : in out Set; Source : Set);
function Difference (Left, Right : Set) return Set;
......@@ -141,14 +142,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
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;
......@@ -165,6 +158,14 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
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;
......@@ -188,21 +189,28 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
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 Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
function Find
(Container : Set;
......@@ -216,28 +224,9 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
(Container : Set;
Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element
function Contains
(Container : Set;
Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set; -- TODO: need ruling from ARG
Key : Key_Type;
New_Item : 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;
Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
......
gcc/ada/a-cohama.adb
......@@ -188,16 +188,16 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Position.Node.Next /= Position.Node);
if Container.HT.Busy > 0 then
raise Program_Error;
end if;
......@@ -213,14 +213,24 @@ package body Ada.Containers.Hashed_Maps is
-------------
function Element (Container : Map; Key : Key_Type) return Element_Type is
C : constant Cursor := Find (Container, Key);
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
return C.Node.Element;
if Node = null then
raise Constraint_Error;
end if;
return Node.Element;
end Element;
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element;
end Element;
......@@ -242,20 +252,37 @@ package body Ada.Containers.Hashed_Maps is
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Right));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key, Right);
end Equivalent_Keys;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
pragma Assert (Vet (Right));
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left, Right.Node.Key);
end Equivalent_Keys;
......@@ -352,13 +379,8 @@ package body Ada.Containers.Hashed_Maps is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Vet (Position));
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
......@@ -435,25 +457,18 @@ package body Ada.Containers.Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
-- TODO: 17 Apr 2005
-- We should defer the expansion until we're sure that the
-- element was successfully inserted. We can do that by
-- first performing the insertion attempt, and allowing the
-- invariant len <= cap to be violated temporarily. After
-- the insertion we can restore the invariant. The
-- worst that can happen is that the insertion succeeds
-- (new element is added to the map), but the
-- invariant is broken (len > cap). But it's only
-- broken by a little (since len = cap + 1), so the
-- effect is benign.
-- END TODO.
Local_Insert (HT, Key, Position.Node, Inserted);
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Local_Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
......@@ -485,12 +500,18 @@ package body Ada.Containers.Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: see note above.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, Key, Position.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;
......@@ -553,7 +574,12 @@ package body Ada.Containers.Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Key;
end Key;
......@@ -589,16 +615,15 @@ package body Ada.Containers.Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
pragma Assert (Vet (Position));
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;
......@@ -621,34 +646,41 @@ package body Ada.Containers.Hashed_Maps is
(Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
if Position.Node = null then
raise Constraint_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
begin
B := B + 1;
L := L + 1;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
B := B + 1;
L := L + 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;
L := L - 1;
B := B - 1;
end Query_Element;
----------
......@@ -712,15 +744,18 @@ package body Ada.Containers.Hashed_Maps is
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
pragma Assert (Vet (Position));
E : Element_Type renames Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
E := By;
Position.Node.Element := By;
end Replace_Element;
----------------------
......@@ -753,32 +788,40 @@ package body Ada.Containers.Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
if Position.Node = null then
raise Constraint_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
begin
B := B + 1;
L := L + 1;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
B := B + 1;
L := L + 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;
L := L - 1;
B := B - 1;
end Update_Element;
---------
......@@ -788,34 +831,32 @@ package body Ada.Containers.Hashed_Maps is
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return False;
return Position.Container = null;
end if;
if Position.Node.Next = Position.Node then
if Position.Container = null then
return False;
end if;
if Position.Container = null then
if Position.Node.Next = Position.Node then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null then
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
-- NOTE: see notes in Insert.
-- if HT.Length > HT.Buckets'Length then
-- return False;
-- end if;
X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
for J in 1 .. HT.Length loop
......@@ -827,7 +868,7 @@ package body Ada.Containers.Hashed_Maps is
return False;
end if;
if X = X.Next then -- weird
if X = X.Next then -- to prevent endless loop
return False;
end if;
......
gcc/ada/a-cohase.adb
......@@ -67,6 +67,8 @@ package body Ada.Containers.Hashed_Sets is
(R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean;
procedure Free (X : in out Node_Access);
function Hash_Node (Node : Node_Access) return Hash_Type;
pragma Inline (Hash_Node);
......@@ -83,13 +85,15 @@ package body Ada.Containers.Hashed_Sets is
pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type);
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
function Vet (Position : Cursor) return Boolean;
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
......@@ -99,9 +103,6 @@ package body Ada.Containers.Hashed_Sets is
-- Local Instantiations --
--------------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package HT_Ops is
new Hash_Tables.Generic_Operations
(HT_Types => HT_Types,
......@@ -211,11 +212,13 @@ package body Ada.Containers.Hashed_Sets is
Position : in out Cursor)
is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
......@@ -226,7 +229,6 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
......@@ -345,6 +347,12 @@ package body Ada.Containers.Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element;
end Element;
......@@ -364,18 +372,39 @@ package body Ada.Containers.Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
end Equivalent_Elements;
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left.Node.Element, Right);
end Equivalent_Elements;
function Equivalent_Elements (Left : Element_Type; Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left, Right.Node.Element);
end Equivalent_Elements;
......@@ -499,18 +528,29 @@ package body Ada.Containers.Hashed_Sets is
return Cursor'(Container'Unrestricted_Access, Node);
end First;
----------
-- 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.Next := X; -- detect mischief (in Vet)
Deallocate (X);
end if;
end Free;
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
......@@ -576,18 +616,18 @@ package body Ada.Containers.Hashed_Sets is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
-- TODO:
-- Perform the insertion first, and then reserve
-- capacity, but only if the insertion succeeds and
-- the (new) length is greater then current capacity.
-- END TODO.
Local_Insert (HT, New_Item, Position.Node, Inserted);
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Local_Insert (HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
......@@ -725,7 +765,7 @@ package body Ada.Containers.Hashed_Sets is
function Is_Empty (Container : Set) return Boolean is
begin
return Container.Length = 0;
return Container.HT.Length = 0;
end Is_Empty;
-----------
......@@ -790,23 +830,13 @@ package body Ada.Containers.Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
begin
Iterate (HT);
exception
when others =>
B := B - 1;
raise;
end;
-- TODO: resolve whether HT_Ops.Generic_Iteration should
-- manipulate busy bit.
B := B - 1;
Iterate (Container.HT);
end Iterate;
------------
......@@ -838,8 +868,9 @@ package body Ada.Containers.Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
......@@ -896,28 +927,35 @@ package body Ada.Containers.Hashed_Sets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
HT : Hash_Table_Type renames Position.Container.HT;
if Position.Node = null then
raise Constraint_Error;
end if;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
declare
HT : Hash_Table_Type renames Position.Container.HT;
begin
B := B + 1;
L := L + 1;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
begin
Process (Position.Node.Element);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
......@@ -955,7 +993,7 @@ package body Ada.Containers.Hashed_Sets is
-------------
procedure Replace
(Container : in out Set; -- TODO: need ruling from ARG
(Container : in out Set;
New_Item : Element_Type)
is
Node : constant Node_Access :=
......@@ -978,19 +1016,19 @@ package body Ada.Containers.Hashed_Sets is
---------------------
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type)
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element, Element) then
pragma Assert (Hash (Node.Element) = Hash (Element));
if Equivalent_Elements (Node.Element, New_Item) then
pragma Assert (Hash (Node.Element) = Hash (New_Item));
if HT.Lock > 0 then
raise Program_Error;
end if;
Node.Element := Element; -- Note that this assignment can fail
Node.Element := New_Item; -- Note that this assignment can fail
return;
end if;
......@@ -1013,7 +1051,7 @@ package body Ada.Containers.Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := Element; -- Note that this assignment can fail
Node.Element := New_Item; -- Note that this assignment can fail
Node.Next := Next;
return Node;
end New_Node;
......@@ -1026,12 +1064,11 @@ package body Ada.Containers.Hashed_Sets is
begin
Local_Insert
(HT => HT,
Key => Element,
Key => New_Item,
Node => Result,
Inserted => Inserted);
if Inserted then
pragma Assert (Result = Node);
return;
end if;
exception
......@@ -1076,22 +1113,22 @@ package body Ada.Containers.Hashed_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Replace_Element (HT, Position.Node, By);
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
----------------------
......@@ -1491,6 +1528,61 @@ package body Ada.Containers.Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Union;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
for J in 1 .. HT.Length loop
if X = Position.Node then
return True;
end if;
if X = null then
return False;
end if;
if X = X.Next then -- to prevent unnecessary looping
return False;
end if;
X := X.Next;
end loop;
return False;
end;
end Vet;
-----------
-- Write --
-----------
......@@ -1594,27 +1686,9 @@ package body Ada.Containers.Hashed_Sets is
Node : Node_Access) return Boolean
is
begin
return Equivalent_Keys (Key, Node.Element);
return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
end Equivalent_Key_Node;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean is
begin
return Equivalent_Keys (Right, Left.Node.Element);
end Equivalent_Keys;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean is
begin
return Equivalent_Keys (Left, Right.Node.Element);
end Equivalent_Keys;
-------------
-- Exclude --
-------------
......@@ -1654,6 +1728,12 @@ package body Ada.Containers.Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Key (Position.Node.Element);
end Key;
......@@ -1687,20 +1767,35 @@ package body Ada.Containers.Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type))
is
HT : Hash_Table_Type renames Container.HT;
HT : Hash_Table_Type renames Container.HT;
Indx : Hash_Type;
begin
pragma Assert
(Vet (Position),
"bad cursor in Update_Element_Preserving_Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
or else HT.Length = 0
or else Position.Node.Next = Position.Node
then
raise Program_Error;
end if;
Indx := HT_Ops.Index (HT, Position.Node);
declare
E : Element_Type renames Position.Node.Element;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
......@@ -1721,16 +1816,38 @@ package body Ada.Containers.Hashed_Sets is
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, E) then
if Equivalent_Keys (K, Key (E)) then
pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
if HT.Buckets (Indx) = Position.Node then
HT.Buckets (Indx) := Position.Node.Next;
else
declare
Prev : Node_Access := HT.Buckets (Indx);
begin
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
if Prev = null then
raise Program_Error;
end if;
end loop;
Prev.Next := Position.Node.Next;
end;
end if;
HT.Length := HT.Length - 1;
declare
X : Node_Access := Position.Node;
begin
HT_Ops.Delete_Node_Sans_Free (HT, X);
Free (X);
end;
......
gcc/ada/a-cohase.ads
......@@ -48,7 +48,7 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Hashed_Sets is
pragma Preelaborate (Hashed_Sets);
pragma Preelaborate;
type Set is tagged private;
......@@ -62,6 +62,12 @@ pragma Preelaborate (Hashed_Sets);
function Equivalent_Sets (Left, Right : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
......@@ -70,15 +76,15 @@ pragma Preelaborate (Hashed_Sets);
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
......@@ -93,39 +99,11 @@ pragma Preelaborate (Hashed_Sets);
procedure Replace (Container : in out Set; New_Item : Element_Type);
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Exclude (Container : in out Set; Item : Element_Type);
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find
(Container : Set;
Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Union (Target : in out Set; Source : Set);
......@@ -156,41 +134,61 @@ pragma Preelaborate (Hashed_Sets);
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
function First (Container : Set) return Cursor;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Find
(Container : Set;
Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
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 Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys
(Key : Key_Type;
Element : Element_Type) return Boolean;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
function Find (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 Replace
procedure Replace -- TODO: ask Randy why this wasn't removed
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
......@@ -198,18 +196,9 @@ pragma Preelaborate (Hashed_Sets);
Process : not null access
procedure (Element : in out Element_Type));
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean;
end Generic_Keys;
private
type Node_Type;
type Node_Access is access Node_Type;
......
gcc/ada/a-coorse.adb
......@@ -359,6 +359,21 @@ package body Ada.Containers.Ordered_Sets is
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 --
---------------------
......@@ -490,34 +505,6 @@ package body Ada.Containers.Ordered_Sets 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 : 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 ">";
-------------
-- Ceiling --
-------------
......@@ -573,6 +560,21 @@ package body Ada.Containers.Ordered_Sets is
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 --
-------------
......@@ -626,7 +628,7 @@ package body Ada.Containers.Ordered_Sets is
Right : Node_Access) return Boolean
is
begin
return Left > Right.Element;
return Key (Right.Element) < Left;
end Is_Greater_Key_Node;
----------------------
......@@ -638,7 +640,7 @@ package body Ada.Containers.Ordered_Sets is
Right : Node_Access) return Boolean
is
begin
return Left < Right.Element;
return Left < Key (Right.Element);
end Is_Less_Key_Node;
---------
......@@ -691,7 +693,7 @@ package body Ada.Containers.Ordered_Sets is
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;
......@@ -712,11 +714,7 @@ package body Ada.Containers.Ordered_Sets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
......@@ -1319,12 +1317,10 @@ package body Ada.Containers.Ordered_Sets 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;
......@@ -1334,7 +1330,7 @@ package body Ada.Containers.Ordered_Sets is
raise Program_Error;
end if;
Replace_Element (Tree, Position.Node, By);
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
......
gcc/ada/a-coorse.ads
......@@ -38,14 +38,15 @@ with Ada.Finalization;
with Ada.Streams;
generic
type Element_Type is private;
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Ordered_Sets is
pragma Preelaborate (Ordered_Sets);
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
......@@ -67,18 +68,16 @@ pragma Preelaborate (Ordered_Sets);
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; -- TODO: need ARG ruling
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;
......@@ -95,9 +94,13 @@ pragma Preelaborate (Ordered_Sets);
New_Item : Element_Type);
procedure Replace
(Container : in out Set; -- TODO: need ARG ruling
(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);
......@@ -110,10 +113,6 @@ pragma Preelaborate (Ordered_Sets);
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;
......@@ -126,8 +125,7 @@ pragma Preelaborate (Ordered_Sets);
function "and" (Left, Right : Set) return Set renames Intersection;
procedure Difference (Target : in out Set;
Source : Set);
procedure Difference (Target : in out Set; Source : Set);
function Difference (Left, Right : Set) return Set;
......@@ -143,14 +141,6 @@ pragma Preelaborate (Ordered_Sets);
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;
......@@ -167,6 +157,14 @@ pragma Preelaborate (Ordered_Sets);
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;
......@@ -190,48 +188,36 @@ pragma Preelaborate (Ordered_Sets);
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 Find (Container : Set; Key : Key_Type) return Cursor;
function Floor (Container : Set; Key : Key_Type) return Cursor;
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set; -- TODO: need ARG ruling
(Container : in out Set;
Key : Key_Type;
New_Item : 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;
procedure Delete (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
function Floor (Container : Set; Key : Key_Type) return Cursor;
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment