------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.INDEFINITE_VECTORS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- -- apply solely to the contents of the part following the private keyword. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This unit has originally being developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is type Int is range System.Min_Int .. System.Max_Int; procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); procedure Adjust (Container : in out Vector) is begin if Container.Elements = null then return; end if; if Container.Elements'Length = 0 or else Container.Last < Index_Type'First then Container.Elements := null; return; end if; declare E : Elements_Type renames Container.Elements.all; L : constant Index_Type := Container.Last; begin Container.Elements := null; Container.Last := Index_Type'Pred (Index_Type'First); Container.Elements := new Elements_Type (Index_Type'First .. L); for I in Container.Elements'Range loop if E (I) /= null then Container.Elements (I) := new Element_Type'(E (I).all); end if; Container.Last := I; end loop; end; end Adjust; procedure Finalize (Container : in out Vector) is E : Elements_Access := Container.Elements; L : constant Index_Type'Base := Container.Last; begin Container.Elements := null; Container.Last := Index_Type'Pred (Index_Type'First); for I in Index_Type'First .. L loop Free (E (I)); end loop; Free (E); end Finalize; procedure Write (Stream : access Root_Stream_Type'Class; Container : in Vector) is N : constant Count_Type := Length (Container); begin Count_Type'Base'Write (Stream, N); if N = 0 then return; end if; declare E : Elements_Type renames Container.Elements.all; begin for I in Index_Type'First .. Container.Last loop -- There's another way to do this. Instead a separate -- Boolean for each element, you could write a Boolean -- followed by a count of how many nulls or non-nulls -- follow in the array. Alternately you could use a -- signed integer, and use the sign as the indicator -- or null-ness. if E (I) = null then Boolean'Write (Stream, False); else Boolean'Write (Stream, True); Element_Type'Output (Stream, E (I).all); end if; end loop; end; end Write; procedure Read (Stream : access Root_Stream_Type'Class; Container : out Vector) is Length : Count_Type'Base; Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); B : Boolean; begin Clear (Container); Count_Type'Base'Read (Stream, Length); if Length > Capacity (Container) then Reserve_Capacity (Container, Capacity => Length); end if; for I in Count_Type range 1 .. Length loop Last := Index_Type'Succ (Last); Boolean'Read (Stream, B); if B then Container.Elements (Last) := new Element_Type'(Element_Type'Input (Stream)); end if; Container.Last := Last; end loop; end Read; function To_Vector (Length : Count_Type) return Vector is begin if Length = 0 then return Empty_Vector; end if; declare First : constant Int := Int (Index_Type'First); Last_As_Int : constant Int'Base := First + Int (Length) - 1; Last : constant Index_Type := Index_Type (Last_As_Int); Elements : constant Elements_Access := new Elements_Type (Index_Type'First .. Last); begin return (Controlled with Elements, Last); end; end To_Vector; function To_Vector (New_Item : Element_Type; Length : Count_Type) return Vector is begin if Length = 0 then return Empty_Vector; end if; declare First : constant Int := Int (Index_Type'First); Last_As_Int : constant Int'Base := First + Int (Length) - 1; Last : constant Index_Type := Index_Type (Last_As_Int); Elements : Elements_Access := new Elements_Type (Index_Type'First .. Last); begin for I in Elements'Range loop begin Elements (I) := new Element_Type'(New_Item); exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; return (Controlled with Elements, Last); end; end To_Vector; function "=" (Left, Right : Vector) return Boolean is begin if Left'Address = Right'Address then return True; end if; if Left.Last /= Right.Last then return False; end if; for I in Index_Type'First .. Left.Last loop -- NOTE: -- I think it's a bounded error to read or otherwise manipulate -- an "empty" element, which here means that it has the value -- null. If it's a bounded error then an exception might -- propagate, or it might not. We take advantage of that -- permission here to allow empty elements to be compared. -- -- Whether this is the right decision I'm not really sure. If -- you have a contrary argument then let me know. -- END NOTE. if Left.Elements (I) = null then if Right.Elements (I) /= null then return False; end if; elsif Right.Elements (I) = null then return False; elsif Left.Elements (I).all /= Right.Elements (I).all then return False; end if; end loop; return True; end "="; function Length (Container : Vector) return Count_Type is L : constant Int := Int (Container.Last); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; begin return Count_Type (N); end Length; function Is_Empty (Container : Vector) return Boolean is begin return Container.Last < Index_Type'First; end Is_Empty; procedure Set_Length (Container : in out Vector; Length : in Count_Type) is N : constant Count_Type := Indefinite_Vectors.Length (Container); begin if Length = N then return; end if; if Length = 0 then Clear (Container); return; end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Length) - 1; Last : constant Index_Type := Index_Type (Last_As_Int); begin if Length > N then if Length > Capacity (Container) then Reserve_Capacity (Container, Capacity => Length); end if; Container.Last := Last; return; end if; for I in reverse Index_Type'Succ (Last) .. Container.Last loop declare X : Element_Access := Container.Elements (I); begin Container.Elements (I) := null; Container.Last := Index_Type'Pred (Container.Last); Free (X); end; end loop; end; end Set_Length; procedure Clear (Container : in out Vector) is begin for I in reverse Index_Type'First .. Container.Last loop declare X : Element_Access := Container.Elements (I); begin Container.Elements (I) := null; Container.Last := Index_Type'Pred (I); Free (X); end; end loop; end Clear; procedure Append (Container : in out Vector; New_Item : in Element_Type; Count : in Count_Type := 1) is begin if Count = 0 then return; end if; Insert (Container, Index_Type'Succ (Container.Last), New_Item, Count); end Append; procedure Insert (Container : in out Vector; Before : in Extended_Index; New_Item : in Element_Type; Count : in Count_Type := 1) is Old_Last_As_Int : constant Int := Int (Container.Last); N : constant Int := Int (Count); New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); Index : Index_Type; Dst_Last : Index_Type; Dst : Elements_Access; begin if Count = 0 then return; end if; declare subtype Before_Subtype is Index_Type'Base range Index_Type'First .. Index_Type'Succ (Container.Last); Old_First : constant Before_Subtype := Before; Old_First_As_Int : constant Int := Int (Old_First); New_First_As_Int : constant Int'Base := Old_First_As_Int + N; begin Index := Index_Type (New_First_As_Int); end; if Container.Elements = null then declare subtype Elements_Subtype is Elements_Type (Index_Type'First .. New_Last); begin Container.Elements := new Elements_Subtype; Container.Last := Index_Type'Pred (Index_Type'First); for I in Container.Elements'Range loop Container.Elements (I) := new Element_Type'(New_Item); Container.Last := I; end loop; end; return; end if; if New_Last <= Container.Elements'Last then declare E : Elements_Type renames Container.Elements.all; begin E (Index .. New_Last) := E (Before .. Container.Last); Container.Last := New_Last; -- NOTE: -- Now we do the allocation. If it fails, we can propagate the -- exception and invariants are more or less satisfied. The -- issue is that we have some slots still null, and the client -- has no way of detecting whether the slot is null (unless we -- give him a way). -- -- Another way is to allocate a subarray on the stack, do the -- allocation into that array, and if that success then do -- the insertion proper. The issue there is that you have to -- allocate the subarray on the stack, and that may fail if the -- subarray is long. -- -- Or we could try to roll-back the changes: deallocate the -- elements we have successfully deallocated, and then copy -- the elements ptrs back to their original posns. -- END NOTE. -- NOTE: I have written the loop manually here. I could -- have done it this way too: -- E (Before .. Index_Type'Pred (Index)) := -- (others => new Element_Type'New_Item); -- END NOTE. for I in Before .. Index_Type'Pred (Index) loop begin E (I) := new Element_Type'(New_Item); exception when others => E (I .. Index_Type'Pred (Index)) := (others => null); raise; end; end loop; end; return; end if; declare First : constant Int := Int (Index_Type'First); New_Size : constant Int'Base := New_Last_As_Int - First + 1; Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; Size, Dst_Last_As_Int : Int'Base; begin if New_Size >= Max_Size / 2 then Dst_Last := Index_Type'Last; else Size := Container.Elements'Length; if Size = 0 then Size := 1; end if; while Size < New_Size loop Size := 2 * Size; end loop; Dst_Last_As_Int := First + Size - 1; Dst_Last := Index_Type (Dst_Last_As_Int); end if; end; Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare Src : Elements_Type renames Container.Elements.all; begin Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); Dst (Index .. New_Last) := Src (Before .. Container.Last); end; declare X : Elements_Access := Container.Elements; begin Container.Elements := Dst; Container.Last := New_Last; Free (X); end; -- NOTE: -- Now do the allocation. If the allocation fails, -- then the worst thing is that we have a few null slots. -- Our invariants are otherwise satisfied. -- END NOTE. for I in Before .. Index_Type'Pred (Index) loop Dst (I) := new Element_Type'(New_Item); end loop; end Insert; procedure Insert_Space (Container : in out Vector; Before : in Extended_Index; Count : in Count_Type := 1) is Old_Last_As_Int : constant Int := Int (Container.Last); N : constant Int := Int (Count); New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); Index : Index_Type; Dst_Last : Index_Type; Dst : Elements_Access; begin if Count = 0 then return; end if; declare subtype Before_Subtype is Index_Type'Base range Index_Type'First .. Index_Type'Succ (Container.Last); Old_First : constant Before_Subtype := Before; Old_First_As_Int : constant Int := Int (Old_First); New_First_As_Int : constant Int'Base := Old_First_As_Int + N; begin Index := Index_Type (New_First_As_Int); end; if Container.Elements = null then declare subtype Elements_Subtype is Elements_Type (Index_Type'First .. New_Last); begin Container.Elements := new Elements_Subtype; Container.Last := New_Last; end; return; end if; if New_Last <= Container.Elements'Last then declare E : Elements_Type renames Container.Elements.all; begin E (Index .. New_Last) := E (Before .. Container.Last); E (Before .. Index_Type'Pred (Index)) := (others => null); Container.Last := New_Last; end; return; end if; declare First : constant Int := Int (Index_Type'First); New_Size : constant Int'Base := Int (New_Last_As_Int) - First + 1; Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; Size, Dst_Last_As_Int : Int'Base; begin if New_Size >= Max_Size / 2 then Dst_Last := Index_Type'Last; else Size := Container.Elements'Length; if Size = 0 then Size := 1; end if; while Size < New_Size loop Size := 2 * Size; end loop; Dst_Last_As_Int := First + Size - 1; Dst_Last := Index_Type (Dst_Last_As_Int); end if; end; Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare Src : Elements_Type renames Container.Elements.all; begin Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); Dst (Index .. New_Last) := Src (Before .. Container.Last); end; declare X : Elements_Access := Container.Elements; begin Container.Elements := Dst; Container.Last := New_Last; Free (X); end; end Insert_Space; procedure Delete_First (Container : in out Vector; Count : in Count_Type := 1) is begin if Count = 0 then return; end if; if Count >= Length (Container) then Clear (Container); return; end if; Delete (Container, Index_Type'First, Count); end Delete_First; procedure Delete_Last (Container : in out Vector; Count : in Count_Type := 1) is Index : Int'Base; begin if Count = 0 then return; end if; if Count >= Length (Container) then Clear (Container); return; end if; Index := Int'Base (Container.Last) - Int'Base (Count) + 1; Delete (Container, Index_Type'Base (Index), Count); end Delete_Last; procedure Delete (Container : in out Vector; Index : in Extended_Index; -- TODO: verify in Atlanta Count : in Count_Type := 1) is begin if Count = 0 then return; end if; declare subtype I_Subtype is Index_Type'Base range Index_Type'First .. Container.Last; I : constant I_Subtype := Index; I_As_Int : constant Int := Int (I); Old_Last_As_Int : constant Int := Int (Container.Last); Count1 : constant Int'Base := Int (Count); Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; N : constant Int'Base := Int'Min (Count1, Count2); J_As_Int : constant Int'Base := I_As_Int + N; J : constant Index_Type'Base := Index_Type'Base (J_As_Int); E : Elements_Type renames Container.Elements.all; New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); begin for K in I .. Index_Type'Pred (J) loop begin Free (E (K)); exception when others => E (K) := null; raise; end; end loop; E (I .. New_Last) := E (J .. Container.Last); Container.Last := New_Last; end; end Delete; function Capacity (Container : Vector) return Count_Type is begin if Container.Elements = null then return 0; end if; return Container.Elements'Length; end Capacity; procedure Reserve_Capacity (Container : in out Vector; Capacity : in Count_Type) is N : constant Count_Type := Length (Container); begin if Capacity = 0 then if N = 0 then declare X : Elements_Access := Container.Elements; begin Container.Elements := null; Free (X); end; elsif N < Container.Elements'Length then declare 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); X : Elements_Access := Container.Elements; begin Container.Elements := new Array_Subtype'(Src); Free (X); end; end if; return; end if; if Container.Elements = null then declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Capacity) - 1; 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; end; return; end if; if Capacity <= N then if N < Container.Elements'Length then declare 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); X : Elements_Access := Container.Elements; begin Container.Elements := new Array_Subtype'(Src); Free (X); end; end if; return; end if; if Capacity = Container.Elements'Length then return; end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Capacity) - 1; Last : constant Index_Type := Index_Type (Last_As_Int); subtype Array_Subtype is Elements_Type (Index_Type'First .. Last); X : Elements_Access := Container.Elements; begin Container.Elements := new Array_Subtype; declare Src : Elements_Type renames X (Index_Type'First .. Container.Last); Tgt : Elements_Type renames Container.Elements (Index_Type'First .. Container.Last); begin Tgt := Src; end; Free (X); end; end Reserve_Capacity; function First_Index (Container : Vector) return Index_Type is pragma Warnings (Off, Container); begin return Index_Type'First; end First_Index; function First_Element (Container : Vector) return Element_Type is begin return Element (Container, Index_Type'First); end First_Element; function Last_Index (Container : Vector) return Extended_Index is begin return Container.Last; end Last_Index; function Last_Element (Container : Vector) return Element_Type is begin return Element (Container, Container.Last); end Last_Element; function Element (Container : Vector; Index : Index_Type) return Element_Type is subtype T is Index_Type'Base range Index_Type'First .. Container.Last; begin return Container.Elements (T'(Index)).all; end Element; procedure Replace_Element (Container : in Vector; Index : in Index_Type; By : in Element_Type) is subtype T is Index_Type'Base range Index_Type'First .. Container.Last; X : Element_Access := Container.Elements (T'(Index)); begin Container.Elements (T'(Index)) := new Element_Type'(By); Free (X); end Replace_Element; procedure Generic_Sort (Container : in Vector) is function Is_Less (L, R : Element_Access) return Boolean; pragma Inline (Is_Less); function Is_Less (L, R : Element_Access) return Boolean is begin if L = null then return R /= null; elsif R = null then return False; else return L.all < R.all; end if; end Is_Less; procedure Sort is new Generic_Array_Sort (Index_Type, Element_Access, Elements_Type, "<" => Is_Less); begin if Container.Elements = null then return; end if; Sort (Container.Elements (Index_Type'First .. Container.Last)); end Generic_Sort; function Find_Index (Container : Vector; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is begin for I in Index .. Container.Last loop if Container.Elements (I) /= null and then Container.Elements (I).all = Item then return I; end if; end loop; return No_Index; end Find_Index; function Reverse_Find_Index (Container : Vector; Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is Last : Index_Type'Base; begin if Index > Container.Last then Last := Container.Last; else Last := Index; end if; for I in reverse Index_Type'First .. Last loop if Container.Elements (I) /= null and then Container.Elements (I).all = Item then return I; end if; end loop; return No_Index; end Reverse_Find_Index; function Contains (Container : Vector; Item : Element_Type) return Boolean is begin return Find_Index (Container, Item) /= No_Index; end Contains; procedure Assign (Target : in out Vector; Source : in Vector) is N : constant Count_Type := Length (Source); begin if Target'Address = Source'Address then return; end if; Clear (Target); if N = 0 then return; end if; if N > Capacity (Target) then Reserve_Capacity (Target, Capacity => N); end if; for I in Index_Type'First .. Source.Last loop declare EA : constant Element_Access := Source.Elements (I); begin if EA /= null then Target.Elements (I) := new Element_Type'(EA.all); end if; end; Target.Last := I; end loop; end Assign; procedure Move (Target : in out Vector; Source : in out Vector) is X : Elements_Access := Target.Elements; begin if Target'Address = Source'Address then return; end if; if Target.Last >= Index_Type'First then raise Constraint_Error; end if; Target.Elements := null; Free (X); -- shouldn't fail Target.Elements := Source.Elements; Target.Last := Source.Last; Source.Elements := null; Source.Last := Index_Type'Pred (Index_Type'First); end Move; procedure Query_Element (Container : in Vector; Index : in Index_Type; Process : not null access procedure (Element : in Element_Type)) is subtype T is Index_Type'Base range Index_Type'First .. Container.Last; begin Process (Container.Elements (T'(Index)).all); end Query_Element; procedure Update_Element (Container : in Vector; Index : in Index_Type; Process : not null access procedure (Element : in out Element_Type)) is subtype T is Index_Type'Base range Index_Type'First .. Container.Last; begin Process (Container.Elements (T'(Index)).all); end Update_Element; procedure Prepend (Container : in out Vector; New_Item : in Element_Type; Count : in Count_Type := 1) is begin Insert (Container, Index_Type'First, New_Item, Count); end Prepend; procedure Swap (Container : in Vector; I, J : in Index_Type) is subtype T is Index_Type'Base range Index_Type'First .. Container.Last; EI : constant Element_Access := Container.Elements (T'(I)); begin Container.Elements (T'(I)) := Container.Elements (T'(J)); Container.Elements (T'(J)) := EI; end Swap; function "&" (Left, Right : Vector) return Vector is LN : constant Count_Type := Length (Left); RN : constant Count_Type := Length (Right); begin if LN = 0 then if RN = 0 then return Empty_Vector; end if; declare RE : Elements_Type renames Right.Elements (Index_Type'First .. Right.Last); Elements : Elements_Access := new Elements_Type (RE'Range); begin for I in Elements'Range loop begin if RE (I) /= null then Elements (I) := new Element_Type'(RE (I).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; return (Controlled with Elements, Right.Last); end; end if; if RN = 0 then declare LE : Elements_Type renames Left.Elements (Index_Type'First .. Left.Last); Elements : Elements_Access := new Elements_Type (LE'Range); begin for I in Elements'Range loop begin if LE (I) /= null then Elements (I) := new Element_Type'(LE (I).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; return (Controlled with Elements, Left.Last); end; end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (LN) + Int (RN) - 1; Last : constant Index_Type := Index_Type (Last_As_Int); LE : Elements_Type renames Left.Elements (Index_Type'First .. Left.Last); RE : Elements_Type renames Right.Elements (Index_Type'First .. Right.Last); Elements : Elements_Access := new Elements_Type (Index_Type'First .. Last); I : Index_Type'Base := Index_Type'Pred (Index_Type'First); begin for LI in LE'Range loop I := Index_Type'Succ (I); begin if LE (LI) /= null then Elements (I) := new Element_Type'(LE (LI).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; for RI in RE'Range loop I := Index_Type'Succ (I); begin if RE (RI) /= null then Elements (I) := new Element_Type'(RE (RI).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; return (Controlled with Elements, Last); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is LN : constant Count_Type := Length (Left); begin if LN = 0 then declare Elements : Elements_Access := new Elements_Type (Index_Type'First .. Index_Type'First); begin begin Elements (Elements'First) := new Element_Type'(Right); exception when others => Free (Elements); raise; end; return (Controlled with Elements, Index_Type'First); end; end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (LN); Last : constant Index_Type := Index_Type (Last_As_Int); LE : Elements_Type renames Left.Elements (Index_Type'First .. Left.Last); Elements : Elements_Access := new Elements_Type (Index_Type'First .. Last); begin for I in LE'Range loop begin if LE (I) /= null then Elements (I) := new Element_Type'(LE (I).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; begin Elements (Elements'Last) := new Element_Type'(Right); exception when others => declare subtype J_Subtype is Index_Type'Base range Index_Type'First .. Index_Type'Pred (Elements'Last); begin for J in J_Subtype loop Free (Elements (J)); end loop; end; Free (Elements); raise; end; return (Controlled with Elements, Last); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is RN : constant Count_Type := Length (Right); begin if RN = 0 then declare Elements : Elements_Access := new Elements_Type (Index_Type'First .. Index_Type'First); begin begin Elements (Elements'First) := new Element_Type'(Left); exception when others => Free (Elements); raise; end; return (Controlled with Elements, Index_Type'First); end; end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (RN); Last : constant Index_Type := Index_Type (Last_As_Int); RE : Elements_Type renames Right.Elements (Index_Type'First .. Right.Last); Elements : Elements_Access := new Elements_Type (Index_Type'First .. Last); I : Index_Type'Base := Index_Type'First; begin begin Elements (I) := new Element_Type'(Left); exception when others => Free (Elements); raise; end; for RI in RE'Range loop I := Index_Type'Succ (I); begin if RE (RI) /= null then Elements (I) := new Element_Type'(RE (RI).all); end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop Free (Elements (J)); end loop; Free (Elements); raise; end; end loop; return (Controlled with Elements, Last); end; end "&"; function "&" (Left, Right : Element_Type) return Vector is subtype IT is Index_Type'Base range Index_Type'First .. Index_Type'Succ (Index_Type'First); Elements : Elements_Access := new Elements_Type (IT); begin begin Elements (Elements'First) := new Element_Type'(Left); exception when others => Free (Elements); raise; end; begin Elements (Elements'Last) := new Element_Type'(Right); exception when others => Free (Elements (Elements'First)); Free (Elements); raise; end; return (Controlled with Elements, Elements'Last); end "&"; function To_Cursor (Container : Vector; Index : Extended_Index) return Cursor is begin if Index not in Index_Type'First .. Container.Last then return No_Element; end if; return Cursor'(Container'Unchecked_Access, Index); end To_Cursor; function To_Index (Position : Cursor) return Extended_Index is begin if Position.Container = null then return No_Index; end if; if Position.Index <= Position.Container.Last then return Position.Index; end if; return No_Index; end To_Index; function Element (Position : Cursor) return Element_Type is begin return Element (Position.Container.all, Position.Index); end Element; function Next (Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; end if; if Position.Index < Position.Container.Last then return (Position.Container, Index_Type'Succ (Position.Index)); end if; return No_Element; end Next; function Previous (Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; end if; if Position.Index > Index_Type'First then return (Position.Container, Index_Type'Pred (Position.Index)); end if; return No_Element; end Previous; procedure Next (Position : in out Cursor) is begin if Position.Container = null then return; end if; if Position.Index < Position.Container.Last then Position.Index := Index_Type'Succ (Position.Index); else Position := No_Element; end if; end Next; procedure Previous (Position : in out Cursor) is begin if Position.Container = null then return; end if; if Position.Index > Index_Type'First then Position.Index := Index_Type'Pred (Position.Index); else Position := No_Element; end if; end Previous; function Has_Element (Position : Cursor) return Boolean is begin if Position.Container = null then return False; end if; return Position.Index <= Position.Container.Last; end Has_Element; procedure Iterate (Container : in Vector; Process : not null access procedure (Position : in Cursor)) is begin for I in Index_Type'First .. Container.Last loop Process (Cursor'(Container'Unchecked_Access, I)); end loop; end Iterate; procedure Reverse_Iterate (Container : in Vector; Process : not null access procedure (Position : in Cursor)) is begin for I in reverse Index_Type'First .. Container.Last loop Process (Cursor'(Container'Unchecked_Access, I)); end loop; end Reverse_Iterate; procedure Query_Element (Position : in Cursor; Process : not null access procedure (Element : in Element_Type)) is C : Vector renames Position.Container.all; E : Elements_Type renames C.Elements.all; subtype T is Index_Type'Base range Index_Type'First .. C.Last; begin Process (E (T'(Position.Index)).all); end Query_Element; procedure Update_Element (Position : in Cursor; Process : not null access procedure (Element : in out Element_Type)) is C : Vector renames Position.Container.all; E : Elements_Type renames C.Elements.all; subtype T is Index_Type'Base range Index_Type'First .. C.Last; begin Process (E (T'(Position.Index)).all); end Update_Element; procedure Replace_Element (Position : in Cursor; By : in Element_Type) is C : Vector renames Position.Container.all; E : Elements_Type renames C.Elements.all; subtype T is Index_Type'Base range Index_Type'First .. C.Last; X : Element_Access := E (T'(Position.Index)); begin E (T'(Position.Index)) := new Element_Type'(By); Free (X); end Replace_Element; procedure Insert (Container : in out Vector; Before : in Extended_Index; New_Item : in Vector) is N : constant Count_Type := Length (New_Item); begin if N = 0 then return; end if; Insert_Space (Container, Before, Count => N); if Container'Address = New_Item'Address then declare Dst_Last_As_Int : constant Int'Base := Int'Base (Before) + Int'Base (N) - 1; Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); Dst_Index : Index_Type'Base := Index_Type'Pred (Before); Dst : Elements_Type renames Container.Elements (Before .. Dst_Last); begin declare subtype Src_Index_Subtype is Index_Type'Base range Index_Type'First .. Index_Type'Pred (Before); Src : Elements_Type renames Container.Elements (Src_Index_Subtype); begin for Src_Index in Src'Range loop Dst_Index := Index_Type'Succ (Dst_Index); if Src (Src_Index) /= null then Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); end if; end loop; end; declare subtype Src_Index_Subtype is Index_Type'Base range Index_Type'Succ (Dst_Last) .. Container.Last; Src : Elements_Type renames Container.Elements (Src_Index_Subtype); begin for Src_Index in Src'Range loop Dst_Index := Index_Type'Succ (Dst_Index); if Src (Src_Index) /= null then Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); end if; end loop; end; end; else declare Dst_Last_As_Int : constant Int'Base := Int'Base (Before) + Int'Base (N) - 1; Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); Dst_Index : Index_Type'Base := Index_Type'Pred (Before); Src : Elements_Type renames New_Item.Elements (Index_Type'First .. New_Item.Last); Dst : Elements_Type renames Container.Elements (Before .. Dst_Last); begin for Src_Index in Src'Range loop Dst_Index := Index_Type'Succ (Dst_Index); if Src (Src_Index) /= null then Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); end if; end loop; end; end if; end Insert; procedure Insert (Container : in out Vector; Before : in Cursor; New_Item : in Vector) is Index : Index_Type'Base; begin if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Is_Empty (New_Item) then return; end if; if Before.Container = null or else Before.Index > Container.Last then Index := Index_Type'Succ (Container.Last); else Index := Before.Index; end if; Insert (Container, Index, New_Item); end Insert; procedure Insert (Container : in out Vector; Before : in Cursor; New_Item : in Vector; Position : out Cursor) is Index : Index_Type'Base; begin if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Is_Empty (New_Item) then if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unchecked_Access, Before.Index); end if; return; end if; if Before.Container = null or else Before.Index > Container.Last then Index := Index_Type'Succ (Container.Last); else Index := Before.Index; end if; Insert (Container, Index, New_Item); Position := (Container'Unchecked_Access, Index); end Insert; procedure Insert (Container : in out Vector; Before : in Cursor; New_Item : in Element_Type; Count : in Count_Type := 1) is Index : Index_Type'Base; begin if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Count = 0 then return; end if; if Before.Container = null or else Before.Index > Container.Last then Index := Index_Type'Succ (Container.Last); else Index := Before.Index; end if; Insert (Container, Index, New_Item, Count); end Insert; procedure Insert (Container : in out Vector; Before : in Cursor; New_Item : in Element_Type; Position : out Cursor; Count : in Count_Type := 1) is Index : Index_Type'Base; begin if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Count = 0 then if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unchecked_Access, Before.Index); end if; return; end if; if Before.Container = null or else Before.Index > Container.Last then Index := Index_Type'Succ (Container.Last); else Index := Before.Index; end if; Insert (Container, Index, New_Item, Count); Position := (Container'Unchecked_Access, Index); end Insert; procedure Prepend (Container : in out Vector; New_Item : in Vector) is begin Insert (Container, Index_Type'First, New_Item); end Prepend; procedure Append (Container : in out Vector; New_Item : in Vector) is begin if Is_Empty (New_Item) then return; end if; Insert (Container, Index_Type'Succ (Container.Last), New_Item); end Append; procedure Insert_Space (Container : in out Vector; Before : in Cursor; Position : out Cursor; Count : in Count_Type := 1) is Index : Index_Type'Base; begin if Before.Container /= null and then Before.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Count = 0 then if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unchecked_Access, Before.Index); end if; return; end if; if Before.Container = null or else Before.Index > Container.Last then Index := Index_Type'Succ (Container.Last); else Index := Before.Index; end if; Insert_Space (Container, Index, Count); Position := (Container'Unchecked_Access, Index); end Insert_Space; procedure Delete (Container : in out Vector; Position : in out Cursor; Count : in Count_Type := 1) is begin if Position.Container /= null and then Position.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Position.Container = null or else Position.Index > Container.Last then Position := No_Element; return; end if; Delete (Container, Position.Index, Count); if Position.Index <= Container.Last then Position := (Container'Unchecked_Access, Position.Index); else Position := No_Element; end if; end Delete; function First (Container : Vector) return Cursor is begin if Is_Empty (Container) then return No_Element; end if; return (Container'Unchecked_Access, Index_Type'First); end First; function Last (Container : Vector) return Cursor is begin if Is_Empty (Container) then return No_Element; end if; return (Container'Unchecked_Access, Container.Last); end Last; procedure Swap (I, J : in Cursor) is -- NOTE: I've liberalized the behavior here, to -- allow I and J to designate different containers. -- TODO: I think this is suppose to raise P_E. subtype TI is Index_Type'Base range Index_Type'First .. I.Container.Last; EI : Element_Access renames I.Container.Elements (TI'(I.Index)); EI_Copy : constant Element_Access := EI; subtype TJ is Index_Type'Base range Index_Type'First .. J.Container.Last; EJ : Element_Access renames J.Container.Elements (TJ'(J.Index)); begin EI := EJ; EJ := EI_Copy; end Swap; function Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor is begin if Position.Container /= null and then Position.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; for I in Position.Index .. Container.Last loop if Container.Elements (I) /= null and then Container.Elements (I).all = Item then return (Container'Unchecked_Access, I); end if; end loop; return No_Element; end Find; function Reverse_Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor is Last : Index_Type'Base; begin if Position.Container /= null and then Position.Container /= Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; if Position.Container = null or else Position.Index > Container.Last then Last := Container.Last; else Last := Position.Index; end if; for I in reverse Index_Type'First .. Last loop if Container.Elements (I) /= null and then Container.Elements (I).all = Item then return (Container'Unchecked_Access, I); end if; end loop; return No_Element; end Reverse_Find; end Ada.Containers.Indefinite_Vectors;