-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Doubly_Linked_Lists is
pragma Preelaborate;
+ pragma Remote_Types;
type List is tagged private;
pragma Preelaborable_Initialization (List);
end Generic_Sorting;
private
+
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package body Ada.Containers.Hash_Tables.Generic_Operations is
- procedure Free is
- new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
+ type Buckets_Allocation is access all Buckets_Type;
+ -- Used for allocation and deallocation (see New_Buckets and
+ -- Free_Buckets). This is necessary because Buckets_Access has an empty
+ -- storage pool.
------------
-- Adjust --
-- source table. This has the benefit that when iterating, elements of
-- the target are delivered in the exact same order as for the source.
- HT.Buckets := new Buckets_Type (Src_Buckets'Range);
+ HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index);
procedure Finalize (HT : in out Hash_Table_Type) is
begin
Clear (HT);
- Free (HT.Buckets);
+ Free_Buckets (HT.Buckets);
end Finalize;
-----------
end loop;
end First;
+ ------------------
+ -- Free_Buckets --
+ ------------------
+
+ procedure Free_Buckets (Buckets : in out Buckets_Access) is
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
+
+ begin
+ -- Buckets must have been created by New_Buckets. Here, we convert back
+ -- to the Buckets_Allocation type, and do the free on that.
+
+ Free (Buckets_Allocation (Buckets));
+ end Free_Buckets;
+
---------------------
-- Free_Hash_Table --
---------------------
end loop;
end loop;
- Free (Buckets);
+ Free_Buckets (Buckets);
end Free_Hash_Table;
-------------------
-------------------
function Generic_Equal
- (L, R : Hash_Table_Type) return Boolean is
-
+ (L, R : Hash_Table_Type) return Boolean
+ is
L_Index : Hash_Type;
L_Node : Node_Access;
if HT.Buckets = null
or else HT.Buckets'Length < N
then
- Free (HT.Buckets);
+ Free_Buckets (HT.Buckets);
NN := Prime_Numbers.To_Prime (N);
- HT.Buckets := new Buckets_Type (0 .. NN - 1);
+ HT.Buckets := New_Buckets (Length => NN);
end if;
for J in 1 .. N loop
Source.Length := 0;
end Move;
+ -----------------
+ -- New_Buckets --
+ -----------------
+
+ function New_Buckets (Length : Hash_Type) return Buckets_Access is
+ subtype Rng is Hash_Type range 0 .. Length - 1;
+
+ begin
+ -- Allocate in Buckets_Allocation'Storage_Pool, then convert to
+ -- Buckets_Access.
+
+ return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
+ end New_Buckets;
+
----------
-- Next --
----------
if HT.Buckets = null then
if N > 0 then
NN := Prime_Numbers.To_Prime (N);
- HT.Buckets := new Buckets_Type (0 .. NN - 1);
+ HT.Buckets := New_Buckets (Length => NN);
end if;
return;
-- length that corresponds to a prime number.)
if N = 0 then
- Free (HT.Buckets);
+ Free_Buckets (HT.Buckets);
return;
end if;
declare
X : Buckets_Access := HT.Buckets;
begin
- HT.Buckets := new Buckets_Type (0 .. NN - 1);
- Free (X);
+ HT.Buckets := New_Buckets (Length => NN);
+ Free_Buckets (X);
end;
return;
end if;
Rehash : declare
- Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
+ Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
Src_Buckets : Buckets_Access := HT.Buckets;
L : Count_Type renames HT.Length;
end;
end loop;
- Free (Dst_Buckets);
+ Free_Buckets (Dst_Buckets);
raise Program_Error with
"hash function raised exception during rehash";
end;
HT.Buckets := Dst_Buckets;
HT.Length := LL;
- Free (Src_Buckets);
+ Free_Buckets (Src_Buckets);
end Rehash;
end Reserve_Capacity;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- first clears hash table HT, then populates the hash table by calling
-- New_Node for each item in Stream.
+ function New_Buckets (Length : Hash_Type) return Buckets_Access;
+ pragma Inline (New_Buckets);
+ -- Allocate a new Buckets_Type array with bounds 0..Length-1.
+
+ procedure Free_Buckets (Buckets : in out Buckets_Access);
+ pragma Inline (Free_Buckets);
+ -- Unchecked_Deallocate Buckets.
+
+ -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has
+ -- an empty pool.
+
end Ada.Containers.Hash_Tables.Generic_Operations;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Preelaborate;
+ pragma Remote_Types;
type List is tagged private;
pragma Preelaborable_Initialization (List);
end Generic_Sorting;
private
+
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Hashed_Maps is
pragma Preelaborate;
+ pragma Remote_Types;
type Map is tagged private;
pragma Preelaborable_Initialization (Map);
pragma Inline (Reserve_Capacity);
pragma Inline (Has_Element);
pragma Inline (Equivalent_Keys);
+ pragma Inline (Next);
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
declare
Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
declare
Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
Size : constant Hash_Type :=
Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
Size : constant Hash_Type :=
Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Iterate_Left : declare
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Hashed_Sets is
pragma Preelaborate;
+ pragma Remote_Types;
type Set is tagged private;
pragma Preelaborable_Initialization (Set);
end Generic_Keys;
private
+
+ pragma Inline (Next);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Ordered_Maps is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Ordered_Multisets is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Indefinite_Ordered_Sets is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Hashed_Maps is
pragma Preelaborate;
+ pragma Remote_Types;
type Map is tagged private;
pragma Preelaborable_Initialization (Map);
pragma Inline (Reserve_Capacity);
pragma Inline (Has_Element);
pragma Inline (Equivalent_Keys);
+ pragma Inline (Next);
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
declare
Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
declare
Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
Size : constant Hash_Type :=
Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
Size : constant Hash_Type :=
Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Iterate_Left : declare
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Hashed_Sets is
pragma Preelaborate;
+ pragma Remote_Types;
type Set is tagged private;
pragma Preelaborable_Initialization (Set);
end Generic_Keys;
private
+
+ pragma Inline (Next);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- containers.
package Ada.Containers.Hash_Tables is
- pragma Preelaborate;
+ pragma Pure; -- so this can be imported by Remote_Types packages
generic
type Node_Type (<>) is limited private;
package Generic_Hash_Table_Types is
type Buckets_Type is array (Hash_Type range <>) of Node_Access;
- type Buckets_Access is access Buckets_Type;
+ type Buckets_Access is access all Buckets_Type;
+ for Buckets_Access'Storage_Size use 0; -- so this package can be Pure
type Hash_Table_Type is tagged record
Buckets : Buckets_Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
declare
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access :=
- new Elements_Type (RE'Range);
+ new Elements_Type (Right.Last);
begin
- for I in Elements'Range loop
+ for I in Elements.EA'Range loop
begin
if RE (I) /= null then
- Elements (I) := new Element_Type'(RE (I).all);
+ Elements.EA (I) := new Element_Type'(RE (I).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
if RN = 0 then
declare
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : Elements_Access :=
- new Elements_Type (LE'Range);
+ new Elements_Type (Left.Last);
begin
- for I in Elements'Range loop
+ for I in Elements.EA'Range loop
begin
if LE (I) /= null then
- Elements (I) := new Element_Type'(LE (I).all);
+ Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ Elements : Elements_Access := new Elements_Type (Last);
I : Index_Type'Base := No_Index;
begin
if LE (LI) /= null then
- Elements (I) := new Element_Type'(LE (LI).all);
+ Elements.EA (I) := new Element_Type'(LE (LI).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
begin
if RE (RI) /= null then
- Elements (I) := new Element_Type'(RE (RI).all);
+ Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
begin
if LN = 0 then
declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. Index_Type'First);
-
- Elements : Elements_Access := new Elements_Subtype;
+ Elements : Elements_Access := new Elements_Type (Index_Type'First);
begin
begin
- Elements (Elements'First) := new Element_Type'(Right);
+ Elements.EA (Index_Type'First) := new Element_Type'(Right);
exception
when others =>
Free (Elements);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ new Elements_Type (Last);
begin
for I in LE'Range loop
begin
if LE (I) /= null then
- Elements (I) := new Element_Type'(LE (I).all);
+ Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
end loop;
begin
- Elements (Elements'Last) := new Element_Type'(Right);
+ Elements.EA (Last) := new Element_Type'(Right);
+
exception
when others =>
- for J in Index_Type'First .. Elements'Last - 1 loop
- Free (Elements (J));
+ for J in Index_Type'First .. Last - 1 loop
+ Free (Elements.EA (J));
end loop;
Free (Elements);
begin
if RN = 0 then
declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. Index_Type'First);
-
- Elements : Elements_Access := new Elements_Subtype;
+ Elements : Elements_Access := new Elements_Type (Index_Type'First);
begin
begin
- Elements (Elements'First) := new Element_Type'(Left);
+ Elements.EA (Index_Type'First) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ new Elements_Type (Last);
I : Index_Type'Base := Index_Type'First;
begin
begin
- Elements (I) := new Element_Type'(Left);
+ Elements.EA (I) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
begin
if RE (RI) /= null then
- Elements (I) := new Element_Type'(RE (RI).all);
+ Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
+
exception
when others =>
for J in Index_Type'First .. I - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
end if;
declare
- Last : constant Index_Type := Index_Type'First + 1;
-
- subtype ET is Elements_Type (Index_Type'First .. Last);
-
- Elements : Elements_Access := new ET;
+ Last : constant Index_Type := Index_Type'First + 1;
+ Elements : Elements_Access := new Elements_Type (Last);
begin
begin
- Elements (Elements'First) := new Element_Type'(Left);
+ Elements.EA (Index_Type'First) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
end;
begin
- Elements (Elements'Last) := new Element_Type'(Right);
+ Elements.EA (Last) := new Element_Type'(Right);
exception
when others =>
- Free (Elements (Elements'First));
+ Free (Elements.EA (Index_Type'First));
Free (Elements);
raise;
end;
- return (Controlled with Elements, Elements'Last, 0, 0);
+ return (Controlled with Elements, Last, 0, 0);
end;
end "&";
end if;
for J in Index_Type'First .. Left.Last loop
- if Left.Elements (J) = null then
- if Right.Elements (J) /= null then
+ if Left.Elements.EA (J) = null then
+ if Right.Elements.EA (J) /= null then
return False;
end if;
- elsif Right.Elements (J) = null then
+ elsif Right.Elements.EA (J) = null then
return False;
- elsif Left.Elements (J).all /= Right.Elements (J).all then
+ elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
return False;
end if;
end loop;
end if;
declare
- E : Elements_Type renames Container.Elements.all;
L : constant Index_Type := Container.Last;
+ E : Elements_Array renames
+ Container.Elements.EA (Index_Type'First .. L);
begin
Container.Elements := null;
Container.Busy := 0;
Container.Lock := 0;
- Container.Elements := new Elements_Type (Index_Type'First .. L);
+ Container.Elements := new Elements_Type (L);
- for I in Container.Elements'Range loop
+ for I in E'Range loop
if E (I) /= null then
- Container.Elements (I) := new Element_Type'(E (I).all);
+ Container.Elements.EA (I) := new Element_Type'(E (I).all);
end if;
Container.Last := I;
return 0;
end if;
- return Container.Elements'Length;
+ return Container.Elements.EA'Length;
end Capacity;
-----------
while Container.Last >= Index_Type'First loop
declare
- X : Element_Access := Container.Elements (Container.Last);
+ X : Element_Access := Container.Elements.EA (Container.Last);
begin
- Container.Elements (Container.Last) := null;
+ Container.Elements.EA (Container.Last) := null;
Container.Last := Container.Last - 1;
Free (X);
end;
N : constant Int'Base := Int'Min (Count1, Count2);
J_As_Int : constant Int'Base := Index_As_Int + N;
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
if J_As_Int > Old_Last_As_Int then
Delete (Container, Position.Index, Count);
- Position := No_Element; -- See comment in a-convec.adb
+ Position := No_Element;
end Delete;
------------------
end if;
declare
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
for Indx in 1 .. Count_Type'Min (Count, N) loop
end if;
declare
- EA : constant Element_Access := Container.Elements (Index);
+ EA : constant Element_Access := Container.Elements.EA (Index);
begin
if EA = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- return Element (Position.Container.all, Position.Index);
+ if Position.Index > Position.Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ declare
+ EA : constant Element_Access :=
+ Position.Container.Elements.EA (Position.Index);
+
+ begin
+ if EA = null then
+ raise Constraint_Error with "element is empty";
+ end if;
+
+ return EA.all;
+ end;
end Element;
--------------
end if;
for J in Position.Index .. Container.Last loop
- if Container.Elements (J) /= null
- and then Container.Elements (J).all = Item
+ if Container.Elements.EA (J) /= null
+ and then Container.Elements.EA (J).all = Item
then
return (Container'Unchecked_Access, J);
end if;
is
begin
for Indx in Index .. Container.Last loop
- if Container.Elements (Indx) /= null
- and then Container.Elements (Indx).all = Item
+ if Container.Elements.EA (Indx) /= null
+ and then Container.Elements.EA (Indx).all = Item
then
return Indx;
end if;
function First_Element (Container : Vector) return Element_Type is
begin
- return Element (Container, Index_Type'First);
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ declare
+ EA : constant Element_Access :=
+ Container.Elements.EA (Index_Type'First);
+
+ begin
+ if EA = null then
+ raise Constraint_Error with "first element is empty";
+ end if;
+
+ return EA.all;
+ end;
end First_Element;
-----------------
end if;
declare
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then
-----------
procedure Merge (Target, Source : in out Vector) is
- I : Index_Type'Base := Target.Last;
- J : Index_Type'Base;
+ I, J : Index_Type'Base;
begin
if Target.Last < Index_Type'First then
"attempt to tamper with elements (vector is busy)";
end if;
+ I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
- J := Target.Last;
+ J := Target.Last; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop
pragma Assert
(Source.Last <= Index_Type'First
or else not (Is_Less
- (Source.Elements (Source.Last),
- Source.Elements (Source.Last - 1))));
+ (Source.Elements.EA (Source.Last),
+ Source.Elements.EA (Source.Last - 1))));
if I < Index_Type'First then
declare
- Src : Elements_Type renames
- Source.Elements (Index_Type'First .. Source.Last);
+ Src : Elements_Array renames
+ Source.Elements.EA (Index_Type'First .. Source.Last);
begin
- Target.Elements (Index_Type'First .. J) := Src;
+ Target.Elements.EA (Index_Type'First .. J) := Src;
Src := (others => null);
end;
pragma Assert
(I <= Index_Type'First
or else not (Is_Less
- (Target.Elements (I),
- Target.Elements (I - 1))));
+ (Target.Elements.EA (I),
+ Target.Elements.EA (I - 1))));
declare
- Src : Element_Access renames Source.Elements (Source.Last);
- Tgt : Element_Access renames Target.Elements (I);
+ Src : Element_Access renames Source.Elements.EA (Source.Last);
+ Tgt : Element_Access renames Target.Elements.EA (I);
begin
if Is_Less (Src, Tgt) then
- Target.Elements (J) := Tgt;
+ Target.Elements.EA (J) := Tgt;
Tgt := null;
I := I - 1;
else
- Target.Elements (J) := Src;
+ Target.Elements.EA (J) := Src;
Src := null;
Source.Last := Source.Last - 1;
end if;
new Generic_Array_Sort
(Index_Type => Index_Type,
Element_Type => Element_Access,
- Array_Type => Elements_Type,
+ Array_Type => Elements_Array,
"<" => Is_Less);
-- Start of processing for Sort
"attempt to tamper with cursors (vector is locked)";
end if;
- Sort (Container.Elements (Index_Type'First .. Container.Last));
+ Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
end Sort;
end Generic_Sorting;
end if;
if Container.Elements = null then
- Container.Elements :=
- new Elements_Type (Index_Type'First .. New_Last);
-
+ Container.Elements := new Elements_Type (New_Last);
Container.Last := No_Index;
- for J in Container.Elements'Range loop
- Container.Elements (J) := new Element_Type'(New_Item);
+ for J in Container.Elements.EA'Range loop
+ Container.Elements.EA (J) := new Element_Type'(New_Item);
Container.Last := J;
end loop;
return;
end if;
- if New_Last <= Container.Elements'Last then
+ if New_Last <= Container.Elements.Last then
declare
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
if Before <= Container.Last then
C, CC : UInt;
begin
- C := UInt'Max (1, Container.Elements'Length);
+ C := UInt'Max (1, Container.Elements.EA'Length); -- ???
while C < New_Length loop
if C > UInt'Last / 2 then
C := UInt'Last;
Index_Type (First + UInt'Pos (C) - Int'(1));
begin
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ Dst := new Elements_Type (Dst_Last);
end;
end;
Src : Elements_Access := Container.Elements;
begin
- Dst (Index_Type'First .. Before - 1) :=
- Src (Index_Type'First .. Before - 1);
+ Dst.EA (Index_Type'First .. Before - 1) :=
+ Src.EA (Index_Type'First .. Before - 1);
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
Container.Elements := Dst;
Container.Last := New_Last;
Free (Src);
for J in Before .. Index - 1 loop
- Dst (J) := new Element_Type'(New_Item);
+ Dst.EA (J) := new Element_Type'(New_Item);
end loop;
end;
Src : Elements_Access := Container.Elements;
begin
- Dst (Index_Type'First .. Container.Last) :=
- Src (Index_Type'First .. Container.Last);
+ Dst.EA (Index_Type'First .. Container.Last) :=
+ Src.EA (Index_Type'First .. Container.Last);
Container.Elements := Dst;
Free (Src);
for J in Before .. New_Last loop
- Dst (J) := new Element_Type'(New_Item);
+ Dst.EA (J) := new Element_Type'(New_Item);
Container.Last := J;
end loop;
end;
Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
- Dst : Elements_Type renames
- Container.Elements (Before .. Dst_Last);
+ Dst : Elements_Array renames
+ Container.Elements.EA (Before .. Dst_Last);
Dst_Index : Index_Type'Base := Before - 1;
begin
if Container'Address /= New_Item'Address then
declare
- Src : Elements_Type renames
- New_Item.Elements (Index_Type'First .. New_Item.Last);
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Index_Type'First .. New_Item.Last;
+
+ Src : Elements_Array renames
+ New_Item.Elements.EA (Src_Index_Subtype);
begin
for Src_Index in Src'Range loop
subtype Src_Index_Subtype is Index_Type'Base range
Index_Type'First .. Before - 1;
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
begin
for Src_Index in Src'Range loop
subtype Src_Index_Subtype is Index_Type'Base range
Dst_Last + 1 .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
begin
for Src_Index in Src'Range loop
end if;
if Container.Elements = null then
- Container.Elements :=
- new Elements_Type (Index_Type'First .. New_Last);
-
+ Container.Elements := new Elements_Type (New_Last);
Container.Last := New_Last;
return;
end if;
- if New_Last <= Container.Elements'Last then
+ if New_Last <= Container.Elements.Last then
declare
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
if Before <= Container.Last then
C, CC : UInt;
begin
- C := UInt'Max (1, Container.Elements'Length);
+ C := UInt'Max (1, Container.Elements.EA'Length); -- ???
while C < New_Length loop
if C > UInt'Last / 2 then
C := UInt'Last;
Index_Type (First + UInt'Pos (C) - 1);
begin
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ Dst := new Elements_Type (Dst_Last);
end;
end;
Index : constant Index_Type := Index_Type (Index_As_Int);
begin
- Dst (Index_Type'First .. Before - 1) :=
- Src (Index_Type'First .. Before - 1);
+ Dst.EA (Index_Type'First .. Before - 1) :=
+ Src.EA (Index_Type'First .. Before - 1);
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
end;
else
- Dst (Index_Type'First .. Container.Last) :=
- Src (Index_Type'First .. Container.Last);
+ Dst.EA (Index_Type'First .. Container.Last) :=
+ Src.EA (Index_Type'First .. Container.Last);
end if;
Container.Elements := Dst;
function Last_Element (Container : Vector) return Element_Type is
begin
- return Element (Container, Container.Last);
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ declare
+ EA : constant Element_Access :=
+ Container.Elements.EA (Container.Last);
+
+ begin
+ if EA = null then
+ raise Constraint_Error with "last element is empty";
+ end if;
+
+ return EA.all;
+ end;
end Last_Element;
----------------
raise Constraint_Error with "Index is out of range";
end if;
- if V.Elements (Index) = null then
+ if V.Elements.EA (Index) = null then
raise Constraint_Error with "element is null";
end if;
L := L + 1;
begin
- Process (V.Elements (Index).all);
+ Process (V.Elements.EA (Index).all);
exception
when others =>
L := L - 1;
Boolean'Read (Stream, B);
if B then
- Container.Elements (Last) :=
+ Container.Elements.EA (Last) :=
new Element_Type'(Element_Type'Input (Stream));
end if;
end if;
declare
- X : Element_Access := Container.Elements (Index);
+ X : Element_Access := Container.Elements.EA (Index);
begin
- Container.Elements (Index) := new Element_Type'(New_Item);
+ Container.Elements.EA (Index) := new Element_Type'(New_Item);
Free (X);
end;
end Replace_Element;
raise Program_Error with "Position cursor denotes wrong container";
end if;
- Replace_Element (Container, Position.Index, New_Item);
+ if Position.Index > Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ declare
+ X : Element_Access := Container.Elements.EA (Position.Index);
+ begin
+ Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
+ Free (X);
+ end;
end Replace_Element;
----------------------
Free (X);
end;
- elsif N < Container.Elements'Length then
+ elsif N < Container.Elements.EA'Length then
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
subtype Array_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Array_Index_Subtype);
X : Elements_Access := Container.Elements;
begin
- Container.Elements := new Array_Subtype'(Src);
+ Container.Elements := new Elements_Type'(Container.Last, Src);
Free (X);
end;
end if;
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
begin
- Container.Elements := new Array_Subtype;
+ Container.Elements := new Elements_Type (Last);
end;
end;
end if;
if Capacity <= N then
- if N < Container.Elements'Length then
+ if N < Container.Elements.EA'Length then
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
subtype Array_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Array_Index_Subtype);
X : Elements_Access := Container.Elements;
begin
- Container.Elements := new Array_Subtype'(Src);
+ Container.Elements := new Elements_Type'(Container.Last, Src);
Free (X);
end;
end if;
return;
end if;
- if Capacity = Container.Elements'Length then
+ if Capacity = Container.Elements.EA'Length then
return;
end if;
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
+ X : Elements_Access := Container.Elements;
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
- X : Elements_Access := Container.Elements;
+ subtype Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Container.Last;
begin
- Container.Elements := new Array_Subtype;
+ Container.Elements := new Elements_Type (Last);
declare
- Src : Elements_Type renames
- X (Index_Type'First .. Container.Last);
+ Src : Elements_Array renames
+ X.EA (Index_Subtype);
- Tgt : Elements_Type renames
- Container.Elements (Index_Type'First .. Container.Last);
+ Tgt : Elements_Array renames
+ Container.Elements.EA (Index_Subtype);
begin
Tgt := Src;
declare
I : Index_Type;
J : Index_Type;
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
I := Index_Type'First;
end if;
for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (Indx) /= null
- and then Container.Elements (Indx).all = Item
+ if Container.Elements.EA (Indx) /= null
+ and then Container.Elements.EA (Indx).all = Item
then
return (Container'Unchecked_Access, Indx);
end if;
end if;
for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (Indx) /= null
- and then Container.Elements (Indx).all = Item
+ if Container.Elements.EA (Indx) /= null
+ and then Container.Elements.EA (Indx).all = Item
then
return Indx;
end if;
for Index in 1 .. N - Length loop
declare
J : constant Index_Type := Container.Last;
- X : Element_Access := Container.Elements (J);
+ X : Element_Access := Container.Elements.EA (J);
begin
- Container.Elements (J) := null;
+ Container.Elements.EA (J) := null;
Container.Last := J - 1;
Free (X);
end;
end if;
declare
- EI : Element_Access renames Container.Elements (I);
- EJ : Element_Access renames Container.Elements (J);
+ EI : Element_Access renames Container.Elements.EA (I);
+ EJ : Element_Access renames Container.Elements.EA (J);
EI_Copy : constant Element_Access := EI;
end if;
Last := Index_Type (Last_As_Int);
- Elements := new Elements_Type (Index_Type'First .. Last);
+ Elements := new Elements_Type (Last);
return (Controlled with Elements, Last, 0, 0);
end;
end if;
Last := Index_Type (Last_As_Int);
- Elements := new Elements_Type (Index_Type'First .. Last);
+ Elements := new Elements_Type (Last);
Last := Index_Type'First;
begin
loop
- Elements (Last) := new Element_Type'(New_Item);
- exit when Last = Elements'Last;
+ Elements.EA (Last) := new Element_Type'(New_Item);
+ exit when Last = Elements.Last;
Last := Last + 1;
end loop;
+
exception
when others =>
for J in Index_Type'First .. Last - 1 loop
- Free (Elements (J));
+ Free (Elements.EA (J));
end loop;
Free (Elements);
raise Constraint_Error with "Index is out of range";
end if;
- if Container.Elements (Index) = null then
+ if Container.Elements.EA (Index) = null then
raise Constraint_Error with "element is null";
end if;
L := L + 1;
begin
- Process (Container.Elements (Index).all);
+ Process (Container.Elements.EA (Index).all);
exception
when others =>
L := L - 1;
end if;
declare
- E : Elements_Type renames Container.Elements.all;
+ E : Elements_Array renames Container.Elements.EA;
begin
for Indx in Index_Type'First .. Container.Last loop
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Finalization;
-with Ada.Streams;
+private with Ada.Finalization;
+private with Ada.Streams;
generic
type Index_Type is range <>;
package Ada.Containers.Indefinite_Vectors is
pragma Preelaborate;
+ pragma Remote_Types;
subtype Extended_Index is Index_Type'Base
range Index_Type'First - 1 ..
pragma Inline (Update_Element);
pragma Inline (Replace_Element);
pragma Inline (Contains);
+ pragma Inline (Next);
+ pragma Inline (Previous);
type Element_Access is access Element_Type;
- type Elements_Type is array (Index_Type range <>) of Element_Access;
+ type Elements_Array is array (Index_Type range <>) of Element_Access;
+ function "=" (L, R : Elements_Array) return Boolean is abstract;
- function "=" (L, R : Elements_Type) return Boolean is abstract;
+ type Elements_Type (Last : Index_Type) is limited record
+ EA : Elements_Array (Index_Type'First .. Last);
+ end record;
type Elements_Access is access Elements_Type;
Lock : Natural := 0;
end record;
+ overriding
procedure Adjust (Container : in out Vector);
+ overriding
procedure Finalize (Container : in out Vector);
use Ada.Streams;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
declare
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(RE);
+ new Elements_Type'(Right.Last, RE);
begin
return (Controlled with Elements, Right.Last, 0, 0);
if RN = 0 then
declare
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(LE);
+ new Elements_Type'(Left.Last, LE);
begin
return (Controlled with Elements, Left.Last, 0, 0);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(LE & RE);
+ new Elements_Type'(Last, LE & RE);
begin
return (Controlled with Elements, Last, 0, 0);
begin
if LN = 0 then
declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. Index_Type'First);
-
Elements : constant Elements_Access :=
- new Elements_Subtype'(others => Right);
+ new Elements_Type'
+ (Last => Index_Type'First,
+ EA => (others => Right));
begin
return (Controlled with Elements, Index_Type'First, 0, 0);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
-
- subtype ET is Elements_Type (Index_Type'First .. Last);
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
- Elements : constant Elements_Access := new ET'(LE & Right);
+ Elements : constant Elements_Access :=
+ new Elements_Type'
+ (Last => Last,
+ EA => LE & Right);
begin
return (Controlled with Elements, Last, 0, 0);
begin
if RN = 0 then
declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. Index_Type'First);
-
Elements : constant Elements_Access :=
- new Elements_Subtype'(others => Left);
+ new Elements_Type'
+ (Last => Index_Type'First,
+ EA => (others => Left));
begin
return (Controlled with Elements, Index_Type'First, 0, 0);
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
- subtype ET is Elements_Type (Index_Type'First .. Last);
-
- Elements : constant Elements_Access := new ET'(Left & RE);
+ Elements : constant Elements_Access :=
+ new Elements_Type'
+ (Last => Last,
+ EA => Left & RE);
begin
return (Controlled with Elements, Last, 0, 0);
declare
Last : constant Index_Type := Index_Type'First + 1;
- subtype ET is Elements_Type (Index_Type'First .. Last);
-
- Elements : constant Elements_Access := new ET'(Left, Right);
+ Elements : constant Elements_Access :=
+ new Elements_Type'
+ (Last => Last,
+ EA => (Left, Right));
begin
return (Controlled with Elements, Last, 0, 0);
end if;
for J in Index_Type range Index_Type'First .. Left.Last loop
- if Left.Elements (J) /= Right.Elements (J) then
+ if Left.Elements.EA (J) /= Right.Elements.EA (J) then
return False;
end if;
end loop;
end if;
declare
- E : constant Elements_Access := Container.Elements;
- L : constant Index_Type := Container.Last;
+ L : constant Index_Type := Container.Last;
+ EA : Elements_Array renames
+ Container.Elements.EA (Index_Type'First .. L);
begin
Container.Elements := null;
Container.Last := No_Index;
Container.Busy := 0;
Container.Lock := 0;
- Container.Elements := new Elements_Type'(E (Index_Type'First .. L));
+
+ Container.Elements := new Elements_Type'(L, EA);
Container.Last := L;
end;
end Adjust;
return 0;
end if;
- return Container.Elements'Length;
+ return Container.Elements.EA'Length;
end Capacity;
-----------
else
declare
- J : constant Index_Type := Index_Type (J_As_Int);
- E : Elements_Type renames Container.Elements.all;
+ J : constant Index_Type := Index_Type (J_As_Int);
+ EA : Elements_Array renames Container.Elements.EA;
New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
New_Last : constant Index_Type :=
Index_Type (New_Last_As_Int);
begin
- E (Index .. New_Last) := E (J .. Container.Last);
+ EA (Index .. New_Last) := EA (J .. Container.Last);
Container.Last := New_Last;
end;
end if;
end if;
Delete (Container, Position.Index, Count);
-
- -- This is the old behavior, prior to the York API (2005/06):
-
- -- if Position.Index <= Container.Last then
- -- Position := (Container'Unchecked_Access, Position.Index);
- -- else
- -- Position := No_Element;
- -- end if;
-
- -- This is the behavior specified by the York API:
-
Position := No_Element;
end Delete;
raise Constraint_Error with "Index is out of range";
end if;
- return Container.Elements (Index);
+ return Container.Elements.EA (Index);
end Element;
function Element (Position : Cursor) return Element_Type is
raise Constraint_Error with "Position cursor has no element";
end if;
- return Element (Position.Container.all, Position.Index);
+ if Position.Index > Position.Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ return Position.Container.Elements.EA (Position.Index);
end Element;
--------------
end if;
for J in Position.Index .. Container.Last loop
- if Container.Elements (J) = Item then
+ if Container.Elements.EA (J) = Item then
return (Container'Unchecked_Access, J);
end if;
end loop;
is
begin
for Indx in Index .. Container.Last loop
- if Container.Elements (Indx) = Item then
+ if Container.Elements.EA (Indx) = Item then
return Indx;
end if;
end loop;
function First_Element (Container : Vector) return Element_Type is
begin
- return Element (Container, Index_Type'First);
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Container.Elements.EA (Index_Type'First);
end First_Element;
-----------------
end if;
declare
- E : Elements_Type renames Container.Elements.all;
+ EA : Elements_Array renames Container.Elements.EA;
begin
for I in Index_Type'First .. Container.Last - 1 loop
- if E (I + 1) < E (I) then
+ if EA (I + 1) < EA (I) then
return False;
end if;
end loop;
Target.Set_Length (Length (Target) + Length (Source));
- J := Target.Last;
- while Source.Last >= Index_Type'First loop
- pragma Assert (Source.Last <= Index_Type'First
- or else not (Source.Elements (Source.Last) <
- Source.Elements (Source.Last - 1)));
-
- if I < Index_Type'First then
- Target.Elements (Index_Type'First .. J) :=
- Source.Elements (Index_Type'First .. Source.Last);
+ declare
+ TA : Elements_Array renames Target.Elements.EA;
+ SA : Elements_Array renames Source.Elements.EA;
- Source.Last := No_Index;
- return;
- end if;
+ begin
+ J := Target.Last;
+ while Source.Last >= Index_Type'First loop
+ pragma Assert (Source.Last <= Index_Type'First
+ or else not (SA (Source.Last) <
+ SA (Source.Last - 1)));
+
+ if I < Index_Type'First then
+ TA (Index_Type'First .. J) :=
+ SA (Index_Type'First .. Source.Last);
+
+ Source.Last := No_Index;
+ return;
+ end if;
- pragma Assert (I <= Index_Type'First
- or else not (Target.Elements (I) <
- Target.Elements (I - 1)));
+ pragma Assert (I <= Index_Type'First
+ or else not (TA (I) < TA (I - 1)));
- if Source.Elements (Source.Last) < Target.Elements (I) then
- Target.Elements (J) := Target.Elements (I);
- I := I - 1;
+ if SA (Source.Last) < TA (I) then
+ TA (J) := TA (I);
+ I := I - 1;
- else
- Target.Elements (J) := Source.Elements (Source.Last);
- Source.Last := Source.Last - 1;
- end if;
+ else
+ TA (J) := SA (Source.Last);
+ Source.Last := Source.Last - 1;
+ end if;
- J := J - 1;
- end loop;
+ J := J - 1;
+ end loop;
+ end;
end Merge;
----------
new Generic_Array_Sort
(Index_Type => Index_Type,
Element_Type => Element_Type,
- Array_Type => Elements_Type,
+ Array_Type => Elements_Array,
"<" => "<");
begin
"attempt to tamper with cursors (vector is locked)";
end if;
- Sort (Container.Elements (Index_Type'First .. Container.Last));
+ Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
end Sort;
end Generic_Sorting;
end if;
if Container.Elements = null then
- declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. New_Last);
- begin
- Container.Elements := new Elements_Subtype'(others => New_Item);
- end;
-
+ Container.Elements := new Elements_Type'
+ (Last => New_Last,
+ EA => (others => New_Item));
Container.Last := New_Last;
return;
end if;
- if New_Last <= Container.Elements'Last then
+ if New_Last <= Container.Elements.Last then
declare
- E : Elements_Type renames Container.Elements.all;
+ EA : Elements_Array renames Container.Elements.EA;
begin
if Before <= Container.Last then
Index : constant Index_Type := Index_Type (Index_As_Int);
begin
- E (Index .. New_Last) := E (Before .. Container.Last);
+ EA (Index .. New_Last) := EA (Before .. Container.Last);
- E (Before .. Index_Type'Pred (Index)) :=
+ EA (Before .. Index_Type'Pred (Index)) :=
(others => New_Item);
end;
else
- E (Before .. New_Last) := (others => New_Item);
+ EA (Before .. New_Last) := (others => New_Item);
end if;
end;
C, CC : UInt;
begin
- C := UInt'Max (1, Container.Elements'Length);
+ C := UInt'Max (1, Container.Elements.EA'Length); -- ???
while C < New_Length loop
if C > UInt'Last / 2 then
C := UInt'Last;
Index_Type (First + UInt'Pos (C) - 1);
begin
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ Dst := new Elements_Type (Dst_Last);
end;
end;
declare
- Src : Elements_Type renames Container.Elements.all;
+ SA : Elements_Array renames Container.Elements.EA;
+ DA : Elements_Array renames Dst.EA;
begin
- Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
- Src (Index_Type'First .. Index_Type'Pred (Before));
+ DA (Index_Type'First .. Index_Type'Pred (Before)) :=
+ SA (Index_Type'First .. Index_Type'Pred (Before));
if Before <= Container.Last then
declare
Index : constant Index_Type := Index_Type (Index_As_Int);
begin
- Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item);
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ DA (Before .. Index_Type'Pred (Index)) := (others => New_Item);
+ DA (Index .. New_Last) := SA (Before .. Container.Last);
end;
else
- Dst (Before .. New_Last) := (others => New_Item);
+ DA (Before .. New_Last) := (others => New_Item);
end if;
exception
when others =>
begin
if Container'Address /= New_Item'Address then
- Container.Elements (Before .. Dst_Last) :=
- New_Item.Elements (Index_Type'First .. New_Item.Last);
+ Container.Elements.EA (Before .. Dst_Last) :=
+ New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
return;
end if;
subtype Src_Index_Subtype is Index_Type'Base range
Index_Type'First .. Before - 1;
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
Index_As_Int : constant Int'Base :=
Int (Before) + Src'Length - 1;
Index : constant Index_Type'Base :=
Index_Type'Base (Index_As_Int);
- Dst : Elements_Type renames
- Container.Elements (Before .. Index);
+ Dst : Elements_Array renames
+ Container.Elements.EA (Before .. Index);
begin
Dst := Src;
subtype Src_Index_Subtype is Index_Type'Base range
Dst_Last + 1 .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
Index_As_Int : constant Int'Base :=
Dst_Last_As_Int - Src'Length + 1;
Index : constant Index_Type :=
Index_Type (Index_As_Int);
- Dst : Elements_Type renames
- Container.Elements (Index .. Dst_Last);
+ Dst : Elements_Array renames
+ Container.Elements.EA (Index .. Dst_Last);
begin
Dst := Src;
end if;
if Container.Elements = null then
- Container.Elements :=
- new Elements_Type (Index_Type'First .. New_Last);
-
+ Container.Elements := new Elements_Type (New_Last);
Container.Last := New_Last;
return;
end if;
- if New_Last <= Container.Elements'Last then
+ if New_Last <= Container.Elements.Last then
declare
- E : Elements_Type renames Container.Elements.all;
+ EA : Elements_Array renames Container.Elements.EA;
begin
if Before <= Container.Last then
declare
Index : constant Index_Type := Index_Type (Index_As_Int);
begin
- E (Index .. New_Last) := E (Before .. Container.Last);
+ EA (Index .. New_Last) := EA (Before .. Container.Last);
end;
end if;
end;
C, CC : UInt;
begin
- C := UInt'Max (1, Container.Elements'Length);
+ C := UInt'Max (1, Container.Elements.EA'Length); -- ???
while C < New_Length loop
if C > UInt'Last / 2 then
C := UInt'Last;
Index_Type (First + UInt'Pos (C) - 1);
begin
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ Dst := new Elements_Type (Dst_Last);
end;
end;
declare
- Src : Elements_Type renames Container.Elements.all;
+ SA : Elements_Array renames Container.Elements.EA;
+ DA : Elements_Array renames Dst.EA;
begin
- Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
- Src (Index_Type'First .. Index_Type'Pred (Before));
+ DA (Index_Type'First .. Index_Type'Pred (Before)) :=
+ SA (Index_Type'First .. Index_Type'Pred (Before));
if Before <= Container.Last then
declare
Index : constant Index_Type := Index_Type (Index_As_Int);
begin
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ DA (Index .. New_Last) := SA (Before .. Container.Last);
end;
end if;
exception
function Last_Element (Container : Vector) return Element_Type is
begin
- return Element (Container, Container.Last);
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Container.Elements.EA (Container.Last);
end Last_Element;
----------------
L := L + 1;
begin
- Process (V.Elements (Index));
+ Process (V.Elements.EA (Index));
exception
when others =>
L := L - 1;
for J in Count_Type range 1 .. Length loop
Last := Last + 1;
- Element_Type'Read (Stream, Container.Elements (Last));
+ Element_Type'Read (Stream, Container.Elements.EA (Last));
Container.Last := Last;
end loop;
end Read;
"attempt to tamper with cursors (vector is locked)";
end if;
- Container.Elements (Index) := New_Item;
+ Container.Elements.EA (Index) := New_Item;
end Replace_Element;
procedure Replace_Element
raise Program_Error with "Position cursor denotes wrong container";
end if;
- Replace_Element (Container, Position.Index, New_Item);
+ if Position.Index > Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element;
----------------------
Free (X);
end;
- elsif N < Container.Elements'Length then
+ elsif N < Container.Elements.EA'Length then
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
- subtype Array_Index_Subtype is Index_Type'Base range
+ subtype Src_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
X : Elements_Access := Container.Elements;
begin
- Container.Elements := new Array_Subtype'(Src);
+ Container.Elements := new Elements_Type'(Container.Last, Src);
Free (X);
end;
end if;
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
begin
- Container.Elements := new Array_Subtype;
+ Container.Elements := new Elements_Type (Last);
end;
end;
end if;
if Capacity <= N then
- if N < Container.Elements'Length then
+ if N < Container.Elements.EA'Length then
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
- subtype Array_Index_Subtype is Index_Type'Base range
+ subtype Src_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
- Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
+ Src : Elements_Array renames
+ Container.Elements.EA (Src_Index_Subtype);
X : Elements_Access := Container.Elements;
begin
- Container.Elements := new Array_Subtype'(Src);
+ Container.Elements := new Elements_Type'(Container.Last, Src);
Free (X);
end;
return;
end if;
- if Capacity = Container.Elements'Length then
+ if Capacity = Container.Elements.EA'Length then
return;
end if;
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
- E : Elements_Access := new Array_Subtype;
+ E : Elements_Access := new Elements_Type (Last);
begin
declare
- Src : Elements_Type renames
- Container.Elements (Index_Type'First .. Container.Last);
+ subtype Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+
+ Src : Elements_Array renames
+ Container.Elements.EA (Index_Subtype);
- Tgt : Elements_Type renames
- E (Index_Type'First .. Container.Last);
+ Tgt : Elements_Array renames E.EA (Index_Subtype);
begin
Tgt := Src;
J := Container.Last;
while I < J loop
declare
- EI : constant Element_Type := E (I);
+ EI : constant Element_Type := E.EA (I);
begin
- E (I) := E (J);
- E (J) := EI;
+ E.EA (I) := E.EA (J);
+ E.EA (J) := EI;
end;
I := I + 1;
end if;
for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (Indx) = Item then
+ if Container.Elements.EA (Indx) = Item then
return (Container'Unchecked_Access, Indx);
end if;
end loop;
end if;
for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (Indx) = Item then
+ if Container.Elements.EA (Indx) = Item then
return Indx;
end if;
end loop;
end if;
declare
- EI : Element_Type renames Container.Elements (I);
- EJ : Element_Type renames Container.Elements (J);
+ EI : Element_Type renames Container.Elements.EA (I);
+ EJ : Element_Type renames Container.Elements.EA (J);
EI_Copy : constant Element_Type := EI;
end if;
Last := Index_Type (Last_As_Int);
- Elements := new Elements_Type (Index_Type'First .. Last);
+ Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, 0, 0);
end;
end if;
Last := Index_Type (Last_As_Int);
- Elements := new Elements_Type'(Index_Type'First .. Last => New_Item);
+ Elements := new Elements_Type'(Last, EA => (others => New_Item));
return Vector'(Controlled with Elements, Last, 0, 0);
end;
L := L + 1;
begin
- Process (Container.Elements (Index));
+ Process (Container.Elements.EA (Index));
exception
when others =>
L := L - 1;
Count_Type'Base'Write (Stream, Length (Container));
for J in Index_Type'First .. Container.Last loop
- Element_Type'Write (Stream, Container.Elements (J));
+ Element_Type'Write (Stream, Container.Elements.EA (J));
end loop;
end Write;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Finalization;
-with Ada.Streams;
+
+private with Ada.Finalization;
+private with Ada.Streams;
generic
type Index_Type is range <>;
package Ada.Containers.Vectors is
pragma Preelaborate;
+ pragma Remote_Types;
subtype Extended_Index is Index_Type'Base
range Index_Type'First - 1 ..
pragma Inline (Update_Element);
pragma Inline (Replace_Element);
pragma Inline (Contains);
+ pragma Inline (Next);
+ pragma Inline (Previous);
- type Elements_Type is array (Index_Type range <>) of Element_Type;
+ type Elements_Array is array (Index_Type range <>) of Element_Type;
+ function "=" (L, R : Elements_Array) return Boolean is abstract;
- function "=" (L, R : Elements_Type) return Boolean is abstract;
+ type Elements_Type (Last : Index_Type) is limited record
+ EA : Elements_Array (Index_Type'First .. Last);
+ end record;
type Elements_Access is access Elements_Type;
Lock : Natural := 0;
end record;
+ overriding
procedure Adjust (Container : in out Vector);
+ overriding
procedure Finalize (Container : in out Vector);
use Ada.Streams;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Ordered_Maps is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Ordered_Multisets is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package Ada.Containers.Ordered_Sets is
pragma Preelaborate;
+ pragma Remote_Types;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
private
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
type Node_Type;
type Node_Access is access Node_Type;
OSDN Git Service
