URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-cofove.adb] - Rev 848
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010-2011, 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- -- -- ware Foundation; either version 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; with System; use type System.Address; package body Ada.Containers.Formal_Vectors is type Int is range System.Min_Int .. System.Max_Int; type UInt is mod System.Max_Binary_Modulus; function Get_Element (Container : Vector; Position : Count_Type) return Element_Type; --------- -- "&" -- --------- 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 E : constant Elements_Array (1 .. Length (Right)) := Right.Elements (1 .. RN); begin return (Length (Right), E, Last => Right.Last, others => <>); end; end if; if RN = 0 then declare E : constant Elements_Array (1 .. Length (Left)) := Left.Elements (1 .. LN); begin return (Length (Left), E, Last => Left.Last, others => <>); end; end if; declare N : constant Int'Base := Int (LN) + Int (RN); Last_As_Int : Int'Base; begin if Int (No_Index) > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; Last_As_Int := Int (No_Index) + N; if Last_As_Int > Int (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; -- TODO: should check whether length > max capacity (cnt_t'last) ??? declare Last : constant Index_Type := Index_Type (Last_As_Int); LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := Length (Left) + Length (Right); begin return (Capacity, LE & RE, Last => Last, others => <>); end; end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is LN : constant Count_Type := Length (Left); Last_As_Int : Int'Base; begin if LN = 0 then return (1, (1 .. 1 => Right), Index_Type'First, others => <>); end if; if Int (Index_Type'First) > Int'Last - Int (LN) then raise Constraint_Error with "new length is out of range"; end if; Last_As_Int := Int (Index_Type'First) + Int (LN); if Last_As_Int > Int (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; declare Last : constant Index_Type := Index_Type (Last_As_Int); LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); Capacity : constant Count_Type := Length (Left) + 1; begin return (Capacity, LE & Right, Last => Last, others => <>); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is RN : constant Count_Type := Length (Right); Last_As_Int : Int'Base; begin if RN = 0 then return (1, (1 .. 1 => Left), Index_Type'First, others => <>); end if; if Int (Index_Type'First) > Int'Last - Int (RN) then raise Constraint_Error with "new length is out of range"; end if; Last_As_Int := Int (Index_Type'First) + Int (RN); if Last_As_Int > Int (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; declare Last : constant Index_Type := Index_Type (Last_As_Int); RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := 1 + Length (Right); begin return (Capacity, Left & RE, Last => Last, others => <>); end; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; declare Last : constant Index_Type := Index_Type'First + 1; begin return (2, (Left, Right), Last => Last, others => <>); end; end "&"; --------- -- "=" -- --------- function "=" (Left, Right : Vector) return Boolean is begin if Left'Address = Right'Address then return True; end if; if Length (Left) /= Length (Right) then return False; end if; for J in Count_Type range 1 .. Length (Left) loop if Get_Element (Left, J) /= Get_Element (Right, J) then return False; end if; end loop; return True; end "="; ------------ -- Append -- ------------ procedure Append (Container : in out Vector; New_Item : Vector) is begin if Is_Empty (New_Item) then return; end if; if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Insert (Container, Container.Last + 1, New_Item); end Append; procedure Append (Container : in out Vector; New_Item : Element_Type; Count : Count_Type := 1) is begin if Count = 0 then return; end if; if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; -- TODO: should check whether length > max capacity (cnt_t'last) ??? Insert (Container, Container.Last + 1, New_Item, Count); end Append; ------------ -- Assign -- ------------ procedure Assign (Target : in out Vector; Source : Vector) is LS : constant Count_Type := Length (Source); begin if Target'Address = Source'Address then return; end if; if Target.Capacity < LS then raise Constraint_Error; end if; Target.Clear; Target.Elements (1 .. LS) := Source.Elements (1 .. LS); Target.Last := Source.Last; end Assign; -------------- -- Capacity -- -------------- function Capacity (Container : Vector) return Capacity_Subtype is begin return Container.Elements'Length; end Capacity; ----------- -- Clear -- ----------- procedure Clear (Container : in out Vector) is begin if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; Container.Last := No_Index; end Clear; -------------- -- Contains -- -------------- function Contains (Container : Vector; Item : Element_Type) return Boolean is begin return Find_Index (Container, Item) /= No_Index; end Contains; ---------- -- Copy -- ---------- function Copy (Source : Vector; Capacity : Capacity_Subtype := 0) return Vector is LS : constant Count_Type := Length (Source); C : Capacity_Subtype; begin if Capacity = 0 then C := LS; elsif Capacity >= LS then C := Capacity; else raise Constraint_Error; end if; return Target : Vector (C) do Target.Elements (1 .. LS) := Source.Elements (1 .. LS); Target.Last := Source.Last; end return; end Copy; ------------ -- Delete -- ------------ procedure Delete (Container : in out Vector; Index : Extended_Index; Count : Count_Type := 1) is begin if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; if Index > Container.Last then if Index > Container.Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; if Count = 0 then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; declare I_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); Count1 : constant Int'Base := Count_Type'Pos (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; begin if J_As_Int > Old_Last_As_Int then Container.Last := Index - 1; else declare EA : Elements_Array renames Container.Elements; II : constant Int'Base := I_As_Int - Int (No_Index); I : constant Count_Type := Count_Type (II); JJ : constant Int'Base := J_As_Int - Int (No_Index); J : constant Count_Type := Count_Type (JJ); New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; New_Last : constant Index_Type := Index_Type (New_Last_As_Int); KK : constant Int := New_Last_As_Int - Int (No_Index); K : constant Count_Type := Count_Type (KK); begin EA (I .. K) := EA (J .. Length (Container)); Container.Last := New_Last; end; end if; end; end Delete; procedure Delete (Container : in out Vector; Position : in out Cursor; Count : Count_Type := 1) is begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; Delete (Container, Position.Index, Count); Position := No_Element; end Delete; ------------------ -- Delete_First -- ------------------ procedure Delete_First (Container : in out Vector; Count : 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; ----------------- -- Delete_Last -- ----------------- procedure Delete_Last (Container : in out Vector; Count : Count_Type := 1) is Index : Int'Base; begin if Count = 0 then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; Index := Int'Base (Container.Last) - Int'Base (Count); if Index < Index_Type'Pos (Index_Type'First) then Container.Last := No_Index; else Container.Last := Index_Type (Index); end if; end Delete_Last; ------------- -- Element -- ------------- function Element (Container : Vector; Index : Index_Type) return Element_Type is begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin return Get_Element (Container, I); end; end Element; function Element (Container : Vector; Position : Cursor) return Element_Type is Lst : constant Index_Type := Last_Index (Container); begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; if Position.Index > Lst then raise Constraint_Error with "Position cursor is out of range"; end if; declare II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin return Get_Element (Container, I); end; end Element; ---------- -- Find -- ---------- function Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor is K : Count_Type; Last : constant Index_Type := Last_Index (Container); begin if Position.Valid then if Position.Index > Last_Index (Container) then raise Program_Error with "Position index is out of range"; end if; end if; K := Count_Type (Int (Position.Index) - Int (No_Index)); for J in Position.Index .. Last loop if Get_Element (Container, K) = Item then return Cursor'(Index => J, others => <>); end if; K := K + 1; end loop; return No_Element; end Find; ---------------- -- Find_Index -- ---------------- function Find_Index (Container : Vector; Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is K : Count_Type; Last : constant Index_Type := Last_Index (Container); begin K := Count_Type (Int (Index) - Int (No_Index)); for Indx in Index .. Last loop if Get_Element (Container, K) = Item then return Indx; end if; K := K + 1; end loop; return No_Index; end Find_Index; ----------- -- First -- ----------- function First (Container : Vector) return Cursor is begin if Is_Empty (Container) then return No_Element; end if; return (True, Index_Type'First); end First; ------------------- -- First_Element -- ------------------- function First_Element (Container : Vector) return Element_Type is begin if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; end if; return Get_Element (Container, 1); end First_Element; ----------------- -- First_Index -- ----------------- function First_Index (Container : Vector) return Index_Type is pragma Unreferenced (Container); begin return Index_Type'First; end First_Index; --------------------- -- Generic_Sorting -- --------------------- package body Generic_Sorting is --------------- -- Is_Sorted -- --------------- function Is_Sorted (Container : Vector) return Boolean is Last : constant Index_Type := Last_Index (Container); begin if Container.Last <= Last then return True; end if; declare L : constant Capacity_Subtype := Length (Container); begin for J in Count_Type range 1 .. L - 1 loop if Get_Element (Container, J + 1) < Get_Element (Container, J) then return False; end if; end loop; end; return True; end Is_Sorted; ----------- -- Merge -- ----------- procedure Merge (Target, Source : in out Vector) is begin declare TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; I, J : Count_Type; begin -- ??? -- if Target.Last < Index_Type'First then -- Move (Target => Target, Source => Source); -- return; -- end if; if Target'Address = Source'Address then return; end if; if Source.Last < Index_Type'First then return; end if; -- I think we're missing this check in a-convec.adb... ??? if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; I := Length (Target); Target.Set_Length (I + Length (Source)); J := Length (Target); while not Source.Is_Empty loop pragma Assert (Length (Source) <= 1 or else not (SA (Length (Source)) < SA (Length (Source) - 1))); if I = 0 then TA (1 .. J) := SA (1 .. Length (Source)); Source.Last := No_Index; return; end if; pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1))); if SA (Length (Source)) < TA (I) then TA (J) := TA (I); I := I - 1; else TA (J) := SA (Length (Source)); Source.Last := Source.Last - 1; end if; J := J - 1; end loop; end; end Merge; ---------- -- Sort -- ---------- procedure Sort (Container : in out Vector) is procedure Sort is new Generic_Array_Sort (Index_Type => Count_Type, Element_Type => Element_Type, Array_Type => Elements_Array, "<" => "<"); begin if Container.Last <= Index_Type'First then return; end if; if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; Sort (Container.Elements (1 .. Length (Container))); end Sort; end Generic_Sorting; ----------------- -- Get_Element -- ----------------- function Get_Element (Container : Vector; Position : Count_Type) return Element_Type is begin return Container.Elements (Position); end Get_Element; ----------------- -- Has_Element -- ----------------- function Has_Element (Container : Vector; Position : Cursor) return Boolean is begin if not Position.Valid then return False; else return Position.Index <= Last_Index (Container); end if; end Has_Element; ------------ -- Insert -- ------------ procedure Insert (Container : in out Vector; Before : Extended_Index; New_Item : Element_Type; Count : Count_Type := 1) is N : constant Int := Count_Type'Pos (Count); First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; New_Length : UInt; Max_Length : constant UInt := UInt (Container.Capacity); begin if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; if Count = 0 then return; end if; declare Old_Last_As_Int : constant Int := Int (Container.Last); begin if Old_Last_As_Int > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; New_Last_As_Int := Old_Last_As_Int + N; if New_Last_As_Int > Int (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; New_Length := UInt (New_Last_As_Int - First + Int'(1)); if New_Length > Max_Length then raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); -- Resolve issue of capacity vs. max index ??? end; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; declare EA : Elements_Array renames Container.Elements; BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); LL : constant Int'Base := New_Last_As_Int - Int (No_Index); L : constant Count_Type := Count_Type (LL); begin if Before <= Container.Last then declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); begin EA (I .. L) := EA (B .. Length (Container)); EA (B .. I - 1) := (others => New_Item); end; else EA (B .. L) := (others => New_Item); end if; end; Container.Last := New_Last; end Insert; procedure Insert (Container : in out Vector; Before : Extended_Index; New_Item : Vector) is N : constant Count_Type := Length (New_Item); begin if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; if N = 0 then return; end if; Insert_Space (Container, Before, Count => N); declare Dst_Last_As_Int : constant Int'Base := Int (Before) + Int (N) - 1 - Int (No_Index); Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int); BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); begin if Container'Address /= New_Item'Address then Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N); return; end if; declare Src : Elements_Array renames Container.Elements (1 .. B - 1); Index_As_Int : constant Int'Base := BB + Src'Length - 1; Index : constant Count_Type := Count_Type (Index_As_Int); Dst : Elements_Array renames Container.Elements (B .. Index); begin Dst := Src; end; if Dst_Last = Length (Container) then return; end if; declare Src : Elements_Array renames Container.Elements (Dst_Last + 1 .. Length (Container)); Index_As_Int : constant Int'Base := Dst_Last_As_Int - Src'Length + 1; Index : constant Count_Type := Count_Type (Index_As_Int); Dst : Elements_Array renames Container.Elements (Index .. Dst_Last); begin Dst := Src; end; end; end Insert; procedure Insert (Container : in out Vector; Before : Cursor; New_Item : Vector) is Index : Index_Type'Base; begin if Is_Empty (New_Item) then return; end if; if not Before.Valid or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Index := Container.Last + 1; else Index := Before.Index; end if; Insert (Container, Index, New_Item); end Insert; procedure Insert (Container : in out Vector; Before : Cursor; New_Item : Vector; Position : out Cursor) is Index : Index_Type'Base; begin if Is_Empty (New_Item) then if not Before.Valid or else Before.Index > Container.Last then Position := No_Element; else Position := (True, Before.Index); end if; return; end if; if not Before.Valid or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Index := Container.Last + 1; else Index := Before.Index; end if; Insert (Container, Index, New_Item); Position := Cursor'(True, Index); end Insert; procedure Insert (Container : in out Vector; Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1) is Index : Index_Type'Base; begin if Count = 0 then return; end if; if not Before.Valid or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Index := Container.Last + 1; else Index := Before.Index; end if; Insert (Container, Index, New_Item, Count); end Insert; procedure Insert (Container : in out Vector; Before : Cursor; New_Item : Element_Type; Position : out Cursor; Count : Count_Type := 1) is Index : Index_Type'Base; begin if Count = 0 then if not Before.Valid or else Before.Index > Container.Last then Position := No_Element; else Position := (True, Before.Index); end if; return; end if; if not Before.Valid or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Index := Container.Last + 1; else Index := Before.Index; end if; Insert (Container, Index, New_Item, Count); Position := Cursor'(True, Index); end Insert; procedure Insert (Container : in out Vector; Before : Extended_Index; Count : Count_Type := 1) is New_Item : Element_Type; -- Default-initialized value pragma Warnings (Off, New_Item); begin Insert (Container, Before, New_Item, Count); end Insert; procedure Insert (Container : in out Vector; Before : Cursor; Position : out Cursor; Count : Count_Type := 1) is New_Item : Element_Type; -- Default-initialized value pragma Warnings (Off, New_Item); begin Insert (Container, Before, New_Item, Position, Count); end Insert; ------------------ -- Insert_Space -- ------------------ procedure Insert_Space (Container : in out Vector; Before : Extended_Index; Count : Count_Type := 1) is N : constant Int := Count_Type'Pos (Count); First : constant Int := Int (Index_Type'First); New_Last_As_Int : Int'Base; New_Last : Index_Type; New_Length : UInt; Max_Length : constant UInt := UInt (Count_Type'Last); begin if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; if Count = 0 then return; end if; declare Old_Last_As_Int : constant Int := Int (Container.Last); begin if Old_Last_As_Int > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; New_Last_As_Int := Old_Last_As_Int + N; if New_Last_As_Int > Int (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; New_Length := UInt (New_Last_As_Int - First + Int'(1)); if New_Length > Max_Length then raise Constraint_Error with "new length is out of range"; end if; New_Last := Index_Type (New_Last_As_Int); -- Resolve issue of capacity vs. max index ??? end; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; declare EA : Elements_Array renames Container.Elements; BB : constant Int'Base := Int (Before) - Int (No_Index); B : constant Count_Type := Count_Type (BB); LL : constant Int'Base := New_Last_As_Int - Int (No_Index); L : constant Count_Type := Count_Type (LL); begin if Before <= Container.Last then declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); begin EA (I .. L) := EA (B .. Length (Container)); end; end if; end; Container.Last := New_Last; end Insert_Space; procedure Insert_Space (Container : in out Vector; Before : Cursor; Position : out Cursor; Count : Count_Type := 1) is Index : Index_Type'Base; begin if Count = 0 then if not Before.Valid or else Before.Index > Container.Last then Position := No_Element; else Position := (True, Before.Index); end if; return; end if; if not Before.Valid or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; Index := Container.Last + 1; else Index := Before.Index; end if; Insert_Space (Container, Index, Count => Count); Position := Cursor'(True, Index); end Insert_Space; -------------- -- Is_Empty -- -------------- function Is_Empty (Container : Vector) return Boolean is begin return Last_Index (Container) < Index_Type'First; end Is_Empty; ------------- -- Iterate -- ------------- procedure Iterate (Container : Vector; Process : not null access procedure (Container : Vector; Position : Cursor)) is V : Vector renames Container'Unrestricted_Access.all; B : Natural renames V.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Last_Index (Container) loop Process (Container, Cursor'(True, Indx)); end loop; exception when others => B := B - 1; raise; end; B := B - 1; end Iterate; ---------- -- Last -- ---------- function Last (Container : Vector) return Cursor is begin if Is_Empty (Container) then return No_Element; end if; return (True, Last_Index (Container)); end Last; ------------------ -- Last_Element -- ------------------ function Last_Element (Container : Vector) return Element_Type is begin if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; end if; return Get_Element (Container, Length (Container)); end Last_Element; ---------------- -- Last_Index -- ---------------- function Last_Index (Container : Vector) return Extended_Index is begin return Container.Last; end Last_Index; ------------ -- Length -- ------------ function Length (Container : Vector) return Capacity_Subtype is L : constant Int := Int (Last_Index (Container)); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; begin return Capacity_Subtype (N); end Length; ---------- -- Left -- ---------- function Left (Container : Vector; Position : Cursor) return Vector is C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); begin if Position = No_Element then return C; end if; if not Has_Element (Container, Position) then raise Constraint_Error; end if; while C.Last /= Position.Index - 1 loop Delete_Last (C); end loop; return C; end Left; ---------- -- Move -- ---------- procedure Move (Target : in out Vector; Source : in out Vector) is N : constant Count_Type := Length (Source); begin if Target'Address = Source'Address then return; end if; if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (Target is busy)"; end if; if Source.Busy > 0 then raise Program_Error with "attempt to tamper with elements (Source is busy)"; end if; if N > Target.Capacity then raise Constraint_Error with -- correct exception here??? "length of Source is greater than capacity of Target"; end if; -- We could also write this as a loop, and incrementally -- copy elements from source to target. Target.Last := No_Index; -- in case array assignment files Target.Elements (1 .. N) := Source.Elements (1 .. N); Target.Last := Source.Last; Source.Last := No_Index; end Move; ---------- -- Next -- ---------- function Next (Container : Vector; Position : Cursor) return Cursor is begin if not Position.Valid then return No_Element; end if; if Position.Index < Last_Index (Container) then return (True, Position.Index + 1); end if; return No_Element; end Next; ---------- -- Next -- ---------- procedure Next (Container : Vector; Position : in out Cursor) is begin if not Position.Valid then return; end if; if Position.Index < Last_Index (Container) then Position.Index := Position.Index + 1; else Position := No_Element; end if; end Next; ------------- -- Prepend -- ------------- procedure Prepend (Container : in out Vector; New_Item : Vector) is begin Insert (Container, Index_Type'First, New_Item); end Prepend; procedure Prepend (Container : in out Vector; New_Item : Element_Type; Count : Count_Type := 1) is begin Insert (Container, Index_Type'First, New_Item, Count); end Prepend; -------------- -- Previous -- -------------- procedure Previous (Container : Vector; Position : in out Cursor) is begin if not Position.Valid then return; end if; if Position.Index > Index_Type'First and Position.Index <= Last_Index (Container) then Position.Index := Position.Index - 1; else Position := No_Element; end if; end Previous; function Previous (Container : Vector; Position : Cursor) return Cursor is begin if not Position.Valid then return No_Element; end if; if Position.Index > Index_Type'First and Position.Index <= Last_Index (Container) then return (True, Position.Index - 1); end if; return No_Element; end Previous; ------------------- -- Query_Element -- ------------------- procedure Query_Element (Container : Vector; Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is V : Vector renames Container'Unrestricted_Access.all; B : Natural renames V.Busy; L : Natural renames V.Lock; begin if Index > Last_Index (Container) then raise Constraint_Error with "Index is out of range"; end if; B := B + 1; L := L + 1; declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin Process (Get_Element (V, I)); exception when others => L := L - 1; B := B - 1; raise; end; L := L - 1; B := B - 1; end Query_Element; procedure Query_Element (Container : Vector; Position : Cursor; Process : not null access procedure (Element : Element_Type)) is begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; Query_Element (Container, Position.Index, Process); end Query_Element; ---------- -- Read -- ---------- procedure Read (Stream : not null access Root_Stream_Type'Class; Container : out Vector) is Length : Count_Type'Base; Last : Index_Type'Base := No_Index; begin Clear (Container); Count_Type'Base'Read (Stream, Length); if Length < 0 then raise Program_Error with "stream appears to be corrupt"; end if; if Length > Container.Capacity then raise Storage_Error with "not enough capacity"; -- ??? end if; for J in Count_Type range 1 .. Length loop Last := Last + 1; Element_Type'Read (Stream, Container.Elements (J)); Container.Last := Last; end loop; end Read; procedure Read (Stream : not null access Root_Stream_Type'Class; Position : out Cursor) is begin raise Program_Error with "attempt to stream vector cursor"; end Read; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Container : in out Vector; Index : Index_Type; New_Item : Element_Type) is begin if Index > Container.Last then raise Constraint_Error with "Index 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 II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin Container.Elements (I) := New_Item; end; end Replace_Element; procedure Replace_Element (Container : in out Vector; Position : Cursor; New_Item : Element_Type) is begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; 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 II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin Container.Elements (I) := New_Item; end; end Replace_Element; ---------------------- -- Reserve_Capacity -- ---------------------- procedure Reserve_Capacity (Container : in out Vector; Capacity : Capacity_Subtype) is begin if Capacity > Container.Capacity then raise Constraint_Error; -- ??? end if; end Reserve_Capacity; ---------------------- -- Reverse_Elements -- ---------------------- procedure Reverse_Elements (Container : in out Vector) is begin if Length (Container) <= 1 then return; end if; if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; declare I, J : Count_Type; E : Elements_Array renames Container.Elements; begin I := 1; J := Length (Container); while I < J loop declare EI : constant Element_Type := E (I); begin E (I) := E (J); E (J) := EI; end; I := I + 1; J := J - 1; end loop; end; end Reverse_Elements; ------------------ -- Reverse_Find -- ------------------ function Reverse_Find (Container : Vector; Item : Element_Type; Position : Cursor := No_Element) return Cursor is Last : Index_Type'Base; K : Count_Type; begin if not Position.Valid or else Position.Index > Last_Index (Container) then Last := Last_Index (Container); else Last := Position.Index; end if; K := Count_Type (Int (Last) - Int (No_Index)); for Indx in reverse Index_Type'First .. Last loop if Get_Element (Container, K) = Item then return (True, Indx); end if; K := K - 1; end loop; return No_Element; end Reverse_Find; ------------------------ -- Reverse_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; K : Count_Type; begin if Index > Last_Index (Container) then Last := Last_Index (Container); else Last := Index; end if; K := Count_Type (Int (Last) - Int (No_Index)); for Indx in reverse Index_Type'First .. Last loop if Get_Element (Container, K) = Item then return Indx; end if; K := K - 1; end loop; return No_Index; end Reverse_Find_Index; --------------------- -- Reverse_Iterate -- --------------------- procedure Reverse_Iterate (Container : Vector; Process : not null access procedure (Container : Vector; Position : Cursor)) is V : Vector renames Container'Unrestricted_Access.all; B : Natural renames V.Busy; begin B := B + 1; begin for Indx in reverse Index_Type'First .. Last_Index (Container) loop Process (Container, Cursor'(True, Indx)); end loop; exception when others => B := B - 1; raise; end; B := B - 1; end Reverse_Iterate; ----------- -- Right -- ----------- function Right (Container : Vector; Position : Cursor) return Vector is C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); begin if Position = No_Element then Clear (C); return C; end if; if not Has_Element (Container, Position) then raise Constraint_Error; end if; while C.Last /= Container.Last - Position.Index + 1 loop Delete_First (C); end loop; return C; end Right; ---------------- -- Set_Length -- ---------------- procedure Set_Length (Container : in out Vector; Length : Capacity_Subtype) is begin if Length = Formal_Vectors.Length (Container) then return; end if; if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; if Length > Container.Capacity then raise Constraint_Error; -- ??? end if; declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Length) - 1; begin Container.Last := Index_Type'Base (Last_As_Int); end; end Set_Length; ---------- -- Swap -- ---------- procedure Swap (Container : in out Vector; I, J : Index_Type) is begin if I > Container.Last then raise Constraint_Error with "I index is out of range"; end if; if J > Container.Last then raise Constraint_Error with "J index is out of range"; end if; if I = J then return; end if; if Container.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (vector is locked)"; end if; declare II : constant Int'Base := Int (I) - Int (No_Index); JJ : constant Int'Base := Int (J) - Int (No_Index); EI : Element_Type renames Container.Elements (Count_Type (II)); EJ : Element_Type renames Container.Elements (Count_Type (JJ)); EI_Copy : constant Element_Type := EI; begin EI := EJ; EJ := EI_Copy; end; end Swap; procedure Swap (Container : in out Vector; I, J : Cursor) is begin if not I.Valid then raise Constraint_Error with "I cursor has no element"; end if; if not J.Valid then raise Constraint_Error with "J cursor has no element"; end if; Swap (Container, I.Index, J.Index); end Swap; --------------- -- To_Cursor -- --------------- function To_Cursor (Container : Vector; Index : Extended_Index) return Cursor is begin if Index not in Index_Type'First .. Last_Index (Container) then return No_Element; end if; return Cursor'(True, Index); end To_Cursor; -------------- -- To_Index -- -------------- function To_Index (Position : Cursor) return Extended_Index is begin if not Position.Valid then return No_Index; end if; return Position.Index; end To_Index; --------------- -- To_Vector -- --------------- function To_Vector (Length : Capacity_Subtype) 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 : Index_Type; begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; -- ??? end if; Last := Index_Type (Last_As_Int); return (Length, (others => <>), Last => Last, others => <>); end; end To_Vector; function To_Vector (New_Item : Element_Type; Length : Capacity_Subtype) 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 : Index_Type; begin if Last_As_Int > Index_Type'Pos (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; -- ??? end if; Last := Index_Type (Last_As_Int); return (Length, (others => New_Item), Last => Last, others => <>); end; end To_Vector; -------------------- -- Update_Element -- -------------------- procedure Update_Element (Container : in out Vector; Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is B : Natural renames Container.Busy; L : Natural renames Container.Lock; begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; B := B + 1; L := L + 1; declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); begin Process (Container.Elements (I)); exception when others => L := L - 1; B := B - 1; raise; end; L := L - 1; B := B - 1; end Update_Element; procedure Update_Element (Container : in out Vector; Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; Update_Element (Container, Position.Index, Process); end Update_Element; ----------- -- Write -- ----------- procedure Write (Stream : not null access Root_Stream_Type'Class; Container : Vector) is begin Count_Type'Base'Write (Stream, Length (Container)); for J in 1 .. Length (Container) loop Element_Type'Write (Stream, Container.Elements (J)); end loop; end Write; procedure Write (Stream : not null access Root_Stream_Type'Class; Position : Cursor) is begin raise Program_Error with "attempt to stream vector cursor"; end Write; end Ada.Containers.Formal_Vectors;
Go to most recent revision | Compare with Previous | Blame | View Log