--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2010, 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/>. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+with Ada.Containers.Generic_Array_Sort;
+with System; use type System.Address;
+
+package body Ada.Containers.Bounded_Vectors is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&" (Left, Right : Vector) return Vector is
+ LN : constant Count_Type := Length (Left);
+ RN : constant Count_Type := Length (Right);
+ N : Count_Type'Base; -- length of result
+ J : Count_Type'Base; -- for computing intermediate index values
+ Last : Index_Type'Base; -- Last index of result
+
+ begin
+ -- We decide that the capacity of the result is the sum of the lengths
+ -- of the vector parameters. We could decide to make it larger, but we
+ -- have no basis for knowing how much larger, so we just allocate the
+ -- minimum amount of storage.
+
+ -- Here we handle the easy cases first, when one of the vector
+ -- parameters is empty. (We say "easy" because there's nothing to
+ -- compute, that can potentially overflow.)
+
+ if LN = 0 then
+ if RN = 0 then
+ return Empty_Vector;
+ end if;
+
+ return Vector'(Capacity => RN,
+ Elements => Right.Elements (1 .. RN),
+ Last => Right.Last,
+ others => <>);
+ end if;
+
+ if RN = 0 then
+ return Vector'(Capacity => LN,
+ Elements => Left.Elements (1 .. LN),
+ Last => Left.Last,
+ others => <>);
+ end if;
+
+ -- Neither of the vector parameters is empty, so must compute the length
+ -- of the result vector and its last index. (This is the harder case,
+ -- because our computations must avoid overflow.)
+
+ -- There are two constraints we need to satisfy. The first constraint is
+ -- that a container cannot have more than Count_Type'Last elements, so
+ -- we must check the sum of the combined lengths. Note that we cannot
+ -- simply add the lengths, because of the possibilty of overflow.
+
+ if LN > Count_Type'Last - RN then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ -- It is now safe compute the length of the new vector, without fear of
+ -- overflow.
+
+ N := LN + RN;
+
+ -- The second constraint is that the new Last index value cannot
+ -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
+ -- Count_Type'Base as the type for intermediate values.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ -- We perform a two-part test. First we determine whether the
+ -- computed Last value lies in the base range of the type, and then
+ -- determine whether it lies in the range of the index (sub)type.
+
+ -- Last must satisfy this relation:
+ -- First + Length - 1 <= Last
+ -- We regroup terms:
+ -- First - 1 <= Last - Length
+ -- Which can rewrite as:
+ -- No_Index <= Last - Length
+
+ if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ -- We now know that the computed value of Last is within the base
+ -- range of the type, so it is safe to compute its value:
+
+ Last := No_Index + Index_Type'Base (N);
+
+ -- Finally we test whether the value is within the range of the
+ -- generic actual index subtype:
+
+ if Last > Index_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ elsif Index_Type'First <= 0 then
+ -- Here we can compute Last directly, in the normal way. We know that
+ -- No_Index is less than 0, so there is no danger of overflow when
+ -- adding the (positive) value of length.
+
+ J := Count_Type'Base (No_Index) + N; -- Last
+
+ if J > Count_Type'Base (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ -- We know that the computed value (having type Count_Type) of Last
+ -- is within the range of the generic actual index subtype, so it is
+ -- safe to convert to Index_Type:
+
+ Last := Index_Type'Base (J);
+
+ else
+ -- Here Index_Type'First (and Index_Type'Last) is positive, so we
+ -- must test the length indirectly (by working backwards from the
+ -- largest possible value of Last), in order to prevent overflow.
+
+ J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
+
+ if J < Count_Type'Base (No_Index) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ -- We have determined that the result length would not create a Last
+ -- index value outside of the range of Index_Type, so we can now
+ -- safely compute its value.
+
+ Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
+ end if;
+
+ declare
+ LE : Elements_Array renames Left.Elements (1 .. LN);
+ RE : Elements_Array renames Right.Elements (1 .. RN);
+
+ begin
+ return Vector'(Capacity => N,
+ Elements => LE & RE,
+ Last => Last,
+ others => <>);
+ end;
+ end "&";
+
+ function "&" (Left : Vector; Right : Element_Type) return Vector is
+ LN : constant Count_Type := Length (Left);
+
+ begin
+ -- We decide that the capacity of the result is the sum of the lengths
+ -- of the parameters. We could decide to make it larger, but we have no
+ -- basis for knowing how much larger, so we just allocate the minimum
+ -- amount of storage.
+
+ -- We must compute the length of the result vector and its last index,
+ -- but in such a way that overflow is avoided. We must satisfy two
+ -- constraints: the new length cannot exceed Count_Type'Last, and the
+ -- new Last index cannot exceed Index_Type'Last.
+
+ if LN = Count_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ if Left.Last >= Index_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ return Vector'(Capacity => LN + 1,
+ Elements => Left.Elements (1 .. LN) & Right,
+ Last => Left.Last + 1,
+ others => <>);
+ end "&";
+
+ function "&" (Left : Element_Type; Right : Vector) return Vector is
+ RN : constant Count_Type := Length (Right);
+
+ begin
+ -- We decide that the capacity of the result is the sum of the lengths
+ -- of the parameters. We could decide to make it larger, but we have no
+ -- basis for knowing how much larger, so we just allocate the minimum
+ -- amount of storage.
+
+ -- We compute the length of the result vector and its last index, but in
+ -- such a way that overflow is avoided. We must satisfy two constraints:
+ -- the new length cannot exceed Count_Type'Last, and the new Last index
+ -- cannot exceed Index_Type'Last.
+
+ if RN = Count_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ if Right.Last >= Index_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ return Vector'(Capacity => 1 + RN,
+ Elements => Left & Right.Elements (1 .. RN),
+ Last => Right.Last + 1,
+ others => <>);
+ end "&";
+
+ function "&" (Left, Right : Element_Type) return Vector is
+ begin
+ -- We decide that the capacity of the result is the sum of the lengths
+ -- of the parameters. We could decide to make it larger, but we have no
+ -- basis for knowing how much larger, so we just allocate the minimum
+ -- amount of storage.
+
+ -- We must compute the length of the result vector and its last index,
+ -- but in such a way that overflow is avoided. We must satisfy two
+ -- constraints: the new length cannot exceed Count_Type'Last (here, we
+ -- know that that condition is satisfied), and the new Last index cannot
+ -- exceed Index_Type'Last.
+
+ if Index_Type'First >= Index_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ return Vector'(Capacity => 2,
+ Elements => (Left, Right),
+ Last => Index_Type'First + 1,
+ others => <>);
+ end "&";
+
+ ---------
+ -- "=" --
+ ---------
+
+ overriding 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 J in Count_Type range 1 .. Left.Length loop
+ if Left.Elements (J) /= Right.Elements (J) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end "=";
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Vector; Source : Vector) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error -- ???
+ with "Target capacity is less than Source length";
+ end if;
+
+ Target.Clear;
+
+ Target.Elements (1 .. Source.Length) :=
+ Source.Elements (1 .. Source.Length);
+
+ Target.Last := Source.Last;
+ end Assign;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (Container : in out Vector; New_Item : Vector) is
+ begin
+ if New_Item.Is_Empty then
+ return;
+ end if;
+
+ if Container.Last >= Index_Type'Last then
+ raise Constraint_Error with "vector is already at its maximum length";
+ end if;
+
+ Container.Insert (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;
+
+ Container.Insert (Container.Last + 1, New_Item, Count);
+ end Append;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Vector) return Count_Type 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 cursors (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 : Count_Type := 0) return Vector
+ is
+ C : Count_Type;
+
+ begin
+ if Capacity = 0 then
+ C := Source.Length;
+
+ elsif Capacity >= Source.Length then
+ C := Capacity;
+
+ else
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
+
+ return Target : Vector (C) do
+ Target.Elements (1 .. Source.Length) :=
+ Source.Elements (1 .. Source.Length);
+
+ Target.Last := Source.Last;
+ end return;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ Old_Last : constant Index_Type'Base := Container.Last;
+ Old_Len : constant Count_Type := Container.Length;
+ New_Last : Index_Type'Base;
+ Count2 : Count_Type'Base; -- count of items from Index to Old_Last
+ Off : Count_Type'Base; -- Index expressed as offset from IT'First
+
+ begin
+ -- Delete removes items from the vector, the number of which is the
+ -- minimum of the specified Count and the items (if any) that exist from
+ -- Index to Container.Last. There are no constraints on the specified
+ -- value of Count (it can be larger than what's available at this
+ -- position in the vector, for example), but there are constraints on
+ -- the allowed values of the Index.
+
+ -- As a precondition on the generic actual Index_Type, the base type
+ -- must include Index_Type'Pred (Index_Type'First); this is the value
+ -- that Container.Last assumes when the vector is empty. However, we do
+ -- not allow that as the value for Index when specifying which items
+ -- should be deleted, so we must manually check. (That the user is
+ -- allowed to specify the value at all here is a consequence of the
+ -- declaration of the Extended_Index subtype, which includes the values
+ -- in the base range that immediately precede and immediately follow the
+ -- values in the Index_Type.)
+
+ if Index < Index_Type'First then
+ raise Constraint_Error with "Index is out of range (too small)";
+ end if;
+
+ -- We do allow a value greater than Container.Last to be specified as
+ -- the Index, but only if it's immediately greater. This allows the
+ -- corner case of deleting no items from the back end of the vector to
+ -- be treated as a no-op. (It is assumed that specifying an index value
+ -- greater than Last + 1 indicates some deeper flaw in the caller's
+ -- algorithm, so that case is treated as a proper error.)
+
+ if Index > Old_Last then
+ if Index > Old_Last + 1 then
+ raise Constraint_Error with "Index is out of range (too large)";
+ end if;
+
+ return;
+ end if;
+
+ -- Here and elsewhere we treat deleting 0 items from the container as a
+ -- no-op, even when the container is busy, so we simply return.
+
+ if Count = 0 then
+ return;
+ end if;
+
+ -- The tampering bits exist to prevent an item from being deleted (or
+ -- otherwise harmfully manipulated) while it is being visited. Query,
+ -- Update, and Iterate increment the busy count on entry, and decrement
+ -- the count on exit. Delete checks the count to determine whether it is
+ -- being called while the associated callback procedure is executing.
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is busy)";
+ end if;
+
+ -- We first calculate what's available for deletion starting at
+ -- Index. Here and elsewhere we use the wider of Index_Type'Base and
+ -- Count_Type'Base as the type for intermediate values. (See function
+ -- Length for more information.)
+
+ if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
+ Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
+
+ else
+ Count2 := Count_Type'Base (Old_Last - Index + 1);
+ end if;
+
+ -- If more elements are requested (Count) for deletion than are
+ -- available (Count2) for deletion beginning at Index, then everything
+ -- from Index is deleted. There are no elements to slide down, and so
+ -- all we need to do is set the value of Container.Last.
+
+ if Count >= Count2 then
+ Container.Last := Index - 1;
+ return;
+ end if;
+
+ -- There are some elements aren't being deleted (the requested count was
+ -- less than the available count), so we must slide them down to
+ -- Index. We first calculate the index values of the respective array
+ -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
+ -- type for intermediate calculations.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ Off := Count_Type'Base (Index - Index_Type'First);
+ New_Last := Old_Last - Index_Type'Base (Count);
+
+ else
+ Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
+ New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
+ end if;
+
+ -- The array index values for each slice have already been determined,
+ -- so we just slide down to Index the elements that weren't deleted.
+
+ declare
+ EA : Elements_Array renames Container.Elements;
+ Idx : constant Count_Type := EA'First + Off;
+
+ begin
+ EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
+ Container.Last := New_Last;
+ end;
+ end Delete;
+
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ pragma Warnings (Off, Position);
+
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor denotes wrong container";
+ 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
+ begin
+ -- It is not permitted to delete items while the container is busy (for
+ -- example, we're in the middle of a passive iteration). However, we
+ -- always treat deleting 0 items as a no-op, even when we're busy, so we
+ -- simply return without checking.
+
+ if Count = 0 then
+ return;
+ end if;
+
+ -- The tampering bits exist to prevent an item from being deleted (or
+ -- otherwise harmfully manipulated) while it is being visited. Query,
+ -- Update, and Iterate increment the busy count on entry, and decrement
+ -- the count on exit. Delete_Last checks the count to determine whether
+ -- it is being called while the associated callback procedure is
+ -- executing.
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is busy)";
+ end if;
+
+ -- There is no restriction on how large Count can be when deleting
+ -- items. If it is equal or greater than the current length, then this
+ -- is equivalent to clearing the vector. (In particular, there's no need
+ -- for us to actually calculate the new value for Last.)
+
+ -- If the requested count is less than the current length, then we must
+ -- calculate the new value for Last. For the type we use the widest of
+ -- Index_Type'Base and Count_Type'Base for the intermediate values of
+ -- our calculation. (See the comments in Length for more information.)
+
+ if Count >= Container.Length then
+ Container.Last := No_Index;
+
+ elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ Container.Last := Container.Last - Index_Type'Base (Count);
+
+ else
+ Container.Last :=
+ Index_Type'Base (Count_Type'Base (Container.Last) - Count);
+ 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;
+
+ return Container.Elements (To_Array_Index (Index));
+ end Element;
+
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return Position.Container.Element (Position.Index);
+ end Element;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ begin
+ if Position.Container /= null then
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor denotes wrong container";
+ end if;
+
+ if Position.Index > Container.Last then
+ raise Program_Error with "Position index is out of range";
+ end if;
+ end if;
+
+ for J in Position.Index .. Container.Last loop
+ if Container.Elements (To_Array_Index (J)) = Item then
+ return (Container'Unrestricted_Access, J);
+ end if;
+ 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
+ begin
+ for Indx in Index .. Container.Last loop
+ if Container.Elements (To_Array_Index (Indx)) = Item then
+ return Indx;
+ end if;
+ 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 (Container'Unrestricted_Access, Index_Type'First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Vector) return Element_Type is
+ begin
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Container.Elements (To_Array_Index (Index_Type'First));
+ 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
+ begin
+ if Container.Last <= Index_Type'First then
+ return True;
+ end if;
+
+ declare
+ EA : Elements_Array renames Container.Elements;
+ begin
+ for J in 1 .. Container.Length - 1 loop
+ if EA (J + 1) < EA (J) then
+ return False;
+ end if;
+ end loop;
+ end;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
+
+ procedure Merge (Target, Source : in out Vector) is
+ I, J : Count_Type;
+
+ begin
+ if Target.Is_Empty then
+ Target.Assign (Source);
+ return;
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Is_Empty then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is busy)";
+ end if;
+
+ I := Target.Length;
+ Target.Set_Length (I + Source.Length);
+
+ declare
+ TA : Elements_Array renames Target.Elements;
+ SA : Elements_Array renames Source.Elements;
+
+ begin
+ J := Target.Length;
+ while not Source.Is_Empty loop
+ pragma Assert (Source.Length <= 1
+ or else not (SA (Source.Length) <
+ SA (Source.Length - 1)));
+
+ if I = 0 then
+ TA (1 .. J) := SA (1 .. Source.Length);
+ Source.Last := No_Index;
+ return;
+ end if;
+
+ pragma Assert (I <= 1
+ or else not (TA (I) < TA (I - 1)));
+
+ if SA (Source.Length) < TA (I) then
+ TA (J) := TA (I);
+ I := I - 1;
+
+ else
+ TA (J) := SA (Source.Length);
+ 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 elements (vector is locked)";
+ end if;
+
+ Sort (Container.Elements (1 .. Container.Length));
+ end Sort;
+
+ end Generic_Sorting;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ 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;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ EA : Elements_Array renames Container.Elements;
+ Old_Length : constant Count_Type := Container.Length;
+
+ Max_Length : Count_Type'Base; -- determined from range of Index_Type
+ New_Length : Count_Type'Base; -- sum of current length and Count
+
+ Index : Index_Type'Base; -- scratch for intermediate values
+ J : Count_Type'Base; -- scratch
+
+ begin
+ -- As a precondition on the generic actual Index_Type, the base type
+ -- must include Index_Type'Pred (Index_Type'First); this is the value
+ -- that Container.Last assumes when the vector is empty. However, we do
+ -- not allow that as the value for Index when specifying where the new
+ -- items should be inserted, so we must manually check. (That the user
+ -- is allowed to specify the value at all here is a consequence of the
+ -- declaration of the Extended_Index subtype, which includes the values
+ -- in the base range that immediately precede and immediately follow the
+ -- values in the Index_Type.)
+
+ if Before < Index_Type'First then
+ raise Constraint_Error with
+ "Before index is out of range (too small)";
+ end if;
+
+ -- We do allow a value greater than Container.Last to be specified as
+ -- the Index, but only if it's immediately greater. This allows for the
+ -- case of appending items to the back end of the vector. (It is assumed
+ -- that specifying an index value greater than Last + 1 indicates some
+ -- deeper flaw in the caller's algorithm, so that case is treated as a
+ -- proper error.)
+
+ 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;
+
+ -- We treat inserting 0 items into the container as a no-op, even when
+ -- the container is busy, so we simply return.
+
+ if Count = 0 then
+ return;
+ end if;
+
+ -- There are two constraints we need to satisfy. The first constraint is
+ -- that a container cannot have more than Count_Type'Last elements, so
+ -- we must check the sum of the current length and the insertion
+ -- count. Note that we cannot simply add these values, because of the
+ -- possibilty of overflow.
+
+ if Old_Length > Count_Type'Last - Count then
+ raise Constraint_Error with "Count is out of range";
+ end if;
+
+ -- It is now safe compute the length of the new vector, without fear of
+ -- overflow.
+
+ New_Length := Old_Length + Count;
+
+ -- The second constraint is that the new Last index value cannot exceed
+ -- Index_Type'Last. In each branch below, we calculate the maximum
+ -- length (computed from the range of values in Index_Type), and then
+ -- compare the new length to the maximum length. If the new length is
+ -- acceptable, then we compute the new last index from that.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ -- We have to handle the case when there might be more values in the
+ -- range of Index_Type than in the range of Count_Type.
+
+ if Index_Type'First <= 0 then
+ -- We know that No_Index (the same as Index_Type'First - 1) is
+ -- less than 0, so it is safe to compute the following sum without
+ -- fear of overflow.
+
+ Index := No_Index + Index_Type'Base (Count_Type'Last);
+
+ if Index <= Index_Type'Last then
+ -- We have determined that range of Index_Type has at least as
+ -- many values as in Count_Type, so Count_Type'Last is the
+ -- maximum number of items that are allowed.
+
+ Max_Length := Count_Type'Last;
+
+ else
+ -- The range of Index_Type has fewer values than in Count_Type,
+ -- so the maximum number of items is computed from the range of
+ -- the Index_Type.
+
+ Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
+ end if;
+
+ else
+ -- No_Index is equal or greater than 0, so we can safely compute
+ -- the difference without fear of overflow (which we would have to
+ -- worry about if No_Index were less than 0, but that case is
+ -- handled above).
+
+ Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
+ end if;
+
+ elsif Index_Type'First <= 0 then
+ -- We know that No_Index (the same as Index_Type'First - 1) is less
+ -- than 0, so it is safe to compute the following sum without fear of
+ -- overflow.
+
+ J := Count_Type'Base (No_Index) + Count_Type'Last;
+
+ if J <= Count_Type'Base (Index_Type'Last) then
+ -- We have determined that range of Index_Type has at least as
+ -- many values as in Count_Type, so Count_Type'Last is the maximum
+ -- number of items that are allowed.
+
+ Max_Length := Count_Type'Last;
+
+ else
+ -- The range of Index_Type has fewer values than Count_Type does,
+ -- so the maximum number of items is computed from the range of
+ -- the Index_Type.
+
+ Max_Length :=
+ Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
+ end if;
+
+ else
+ -- No_Index is equal or greater than 0, so we can safely compute the
+ -- difference without fear of overflow (which we would have to worry
+ -- about if No_Index were less than 0, but that case is handled
+ -- above).
+
+ Max_Length :=
+ Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
+ end if;
+
+ -- We have just computed the maximum length (number of items). We must
+ -- now compare the requested length to the maximum length, as we do not
+ -- allow a vector expand beyond the maximum (because that would create
+ -- an internal array with a last index value greater than
+ -- Index_Type'Last, with no way to index those elements).
+
+ if New_Length > Max_Length then
+ raise Constraint_Error with "Count is out of range";
+ end if;
+
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is busy)";
+ end if;
+
+ if New_Length > Container.Capacity then
+ raise Capacity_Error with "New length is larger than capacity";
+ end if;
+
+ J := To_Array_Index (Before);
+
+ if Before > Container.Last then
+ -- The new items are being appended to the vector, so no
+ -- sliding of existing elements is required.
+
+ EA (J .. New_Length) := (others => New_Item);
+
+ else
+ -- The new items are being inserted before some existing
+ -- elements, so we must slide the existing elements up to their
+ -- new home.
+
+ EA (J + Count .. New_Length) := EA (J .. Old_Length);
+ EA (J .. J + Count - 1) := (others => New_Item);
+ end if;
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ Container.Last := No_Index + Index_Type'Base (New_Length);
+
+ else
+ Container.Last :=
+ Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
+ end if;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector)
+ is
+ N : constant Count_Type := Length (New_Item);
+ B : Count_Type; -- index Before converted to Count_Type
+
+ begin
+ -- Use Insert_Space to create the "hole" (the destination slice) into
+ -- which we copy the source items.
+
+ Insert_Space (Container, Before, Count => N);
+
+ if N = 0 then
+ -- There's nothing else to do here (vetting of parameters was
+ -- performed already in Insert_Space), so we simply return.
+
+ return;
+ end if;
+
+ B := To_Array_Index (Before);
+
+ if Container'Address /= New_Item'Address then
+ -- This is the simple case. New_Item denotes an object different
+ -- from Container, so there's nothing special we need to do to copy
+ -- the source items to their destination, because all of the source
+ -- items are contiguous.
+
+ Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
+ return;
+ end if;
+
+ -- We refer to array index value Before + N - 1 as J. This is the last
+ -- index value of the destination slice.
+
+ -- New_Item denotes the same object as Container, so an insertion has
+ -- potentially split the source items. The destination is always the
+ -- range [Before, J], but the source is [Index_Type'First, Before) and
+ -- (J, Container.Last]. We perform the copy in two steps, using each of
+ -- the two slices of the source items.
+
+ declare
+ subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1;
+
+ Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
+
+ begin
+ -- We first copy the source items that precede the space we
+ -- inserted. (If Before equals Index_Type'First, then this first
+ -- source slice will be empty, which is harmless.)
+
+ Container.Elements (B .. B + Src'Length - 1) := Src;
+ end;
+
+ declare
+ subtype Src_Index_Subtype is Count_Type'Base range
+ B + N .. Container.Length;
+
+ Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
+
+ begin
+ -- We next copy the source items that follow the space we inserted.
+
+ Container.Elements (B + N - Src'Length .. B + N - 1) := Src;
+ end;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector)
+ is
+ Index : Index_Type'Base;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= Container'Unchecked_Access
+ then
+ raise Program_Error with "Before cursor denotes wrong container";
+ end if;
+
+ if Is_Empty (New_Item) then
+ return;
+ end if;
+
+ if Before.Container = null
+ 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 Before.Container /= null
+ and then Before.Container /= Container'Unchecked_Access
+ then
+ raise Program_Error with "Before cursor denotes wrong container";
+ 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
+ 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'(Container'Unchecked_Access, 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 Before.Container /= null
+ and then Before.Container /= Container'Unchecked_Access
+ then
+ raise Program_Error with "Before cursor denotes wrong container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Before.Container = null
+ 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 Before.Container /= null
+ and then Before.Container /= Container'Unchecked_Access
+ then
+ raise Program_Error with "Before cursor denotes wrong container";
+ 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
+ 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'(Container'Unchecked_Access, Index);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ New_Item : Element_Type; -- Default-initialized value
+ pragma Warnings (Off, New_Item);
+
+ begin
+ Insert (Container, Before, New_Item, Count);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ New_Item : Element_Type; -- Default-initialized value
+ pragma Warnings (Off, New_Item);
+
+ begin
+ Insert (Container, Before, New_Item, Position, Count);
+ end Insert;
+
+ ------------------
+ -- Insert_Space --
+ ------------------
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ EA : Elements_Array renames Container.Elements;
+ Old_Length : constant Count_Type := Container.Length;
+
+ Max_Length : Count_Type'Base; -- determined from range of Index_Type
+ New_Length : Count_Type'Base; -- sum of current length and Count
+
+ Index : Index_Type'Base; -- scratch for intermediate values
+ J : Count_Type'Base; -- scratch
+
+ begin
+ -- As a precondition on the generic actual Index_Type, the base type
+ -- must include Index_Type'Pred (Index_Type'First); this is the value
+ -- that Container.Last assumes when the vector is empty. However, we do
+ -- not allow that as the value for Index when specifying where the new
+ -- items should be inserted, so we must manually check. (That the user
+ -- is allowed to specify the value at all here is a consequence of the
+ -- declaration of the Extended_Index subtype, which includes the values
+ -- in the base range that immediately precede and immediately follow the
+ -- values in the Index_Type.)
+
+ if Before < Index_Type'First then
+ raise Constraint_Error with
+ "Before index is out of range (too small)";
+ end if;
+
+ -- We do allow a value greater than Container.Last to be specified as
+ -- the Index, but only if it's immediately greater. This allows for the
+ -- case of appending items to the back end of the vector. (It is assumed
+ -- that specifying an index value greater than Last + 1 indicates some
+ -- deeper flaw in the caller's algorithm, so that case is treated as a
+ -- proper error.)
+
+ 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;
+
+ -- We treat inserting 0 items into the container as a no-op, even when
+ -- the container is busy, so we simply return.
+
+ if Count = 0 then
+ return;
+ end if;
+
+ -- There are two constraints we need to satisfy. The first constraint is
+ -- that a container cannot have more than Count_Type'Last elements, so
+ -- we must check the sum of the current length and the insertion
+ -- count. Note that we cannot simply add these values, because of the
+ -- possibilty of overflow.
+
+ if Old_Length > Count_Type'Last - Count then
+ raise Constraint_Error with "Count is out of range";
+ end if;
+
+ -- It is now safe compute the length of the new vector, without fear of
+ -- overflow.
+
+ New_Length := Old_Length + Count;
+
+ -- The second constraint is that the new Last index value cannot exceed
+ -- Index_Type'Last. In each branch below, we calculate the maximum
+ -- length (computed from the range of values in Index_Type), and then
+ -- compare the new length to the maximum length. If the new length is
+ -- acceptable, then we compute the new last index from that.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ -- We have to handle the case when there might be more values in the
+ -- range of Index_Type than in the range of Count_Type.
+
+ if Index_Type'First <= 0 then
+ -- We know that No_Index (the same as Index_Type'First - 1) is
+ -- less than 0, so it is safe to compute the following sum without
+ -- fear of overflow.
+
+ Index := No_Index + Index_Type'Base (Count_Type'Last);
+
+ if Index <= Index_Type'Last then
+ -- We have determined that range of Index_Type has at least as
+ -- many values as in Count_Type, so Count_Type'Last is the
+ -- maximum number of items that are allowed.
+
+ Max_Length := Count_Type'Last;
+
+ else
+ -- The range of Index_Type has fewer values than in Count_Type,
+ -- so the maximum number of items is computed from the range of
+ -- the Index_Type.
+
+ Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
+ end if;
+
+ else
+ -- No_Index is equal or greater than 0, so we can safely compute
+ -- the difference without fear of overflow (which we would have to
+ -- worry about if No_Index were less than 0, but that case is
+ -- handled above).
+
+ Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
+ end if;
+
+ elsif Index_Type'First <= 0 then
+ -- We know that No_Index (the same as Index_Type'First - 1) is less
+ -- than 0, so it is safe to compute the following sum without fear of
+ -- overflow.
+
+ J := Count_Type'Base (No_Index) + Count_Type'Last;
+
+ if J <= Count_Type'Base (Index_Type'Last) then
+ -- We have determined that range of Index_Type has at least as
+ -- many values as in Count_Type, so Count_Type'Last is the maximum
+ -- number of items that are allowed.
+
+ Max_Length := Count_Type'Last;
+
+ else
+ -- The range of Index_Type has fewer values than Count_Type does,
+ -- so the maximum number of items is computed from the range of
+ -- the Index_Type.
+
+ Max_Length :=
+ Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
+ end if;
+
+ else
+ -- No_Index is equal or greater than 0, so we can safely compute the
+ -- difference without fear of overflow (which we would have to worry
+ -- about if No_Index were less than 0, but that case is handled
+ -- above).
+
+ Max_Length :=
+ Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
+ end if;
+
+ -- We have just computed the maximum length (number of items). We must
+ -- now compare the requested length to the maximum length, as we do not
+ -- allow a vector expand beyond the maximum (because that would create
+ -- an internal array with a last index value greater than
+ -- Index_Type'Last, with no way to index those elements).
+
+ if New_Length > Max_Length then
+ raise Constraint_Error with "Count is out of range";
+ end if;
+
+ -- The tampering bits exist to prevent an item from being harmfully
+ -- manipulated while it is being visited. Query, Update, and Iterate
+ -- increment the busy count on entry, and decrement the count on
+ -- exit. Insert checks the count to determine whether it is being called
+ -- while the associated callback procedure is executing.
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is busy)";
+ end if;
+
+ -- An internal array has already been allocated, so we need to check
+ -- whether there is enough unused storage for the new items.
+
+ if New_Length > Container.Capacity then
+ raise Capacity_Error with "New length is larger than capacity";
+ end if;
+
+ -- In this case, we're inserting space into a vector that has already
+ -- allocated an internal array, and the existing array has enough
+ -- unused storage for the new items.
+
+ if Before <= Container.Last then
+ -- The space is being inserted before some existing elements,
+ -- so we must slide the existing elements up to their new home.
+
+ J := To_Array_Index (Before);
+ EA (J + Count .. New_Length) := EA (J .. Old_Length);
+ end if;
+
+ -- New_Last is the last index value of the items in the container after
+ -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
+ -- compute its value from the New_Length.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ Container.Last := No_Index + Index_Type'Base (New_Length);
+
+ else
+ Container.Last :=
+ Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
+ end if;
+ 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 Before.Container /= null
+ and then Before.Container /= Container'Unchecked_Access
+ then
+ raise Program_Error with "Before cursor denotes wrong container";
+ 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
+ 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'(Container'Unchecked_Access, Index);
+ end Insert_Space;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Vector) return Boolean is
+ begin
+ return Container.Last < Index_Type'First;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Vector;
+ Process : not null access procedure (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 .. Container.Last loop
+ Process (Cursor'(Container'Unrestricted_Access, 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 (Container'Unrestricted_Access, Container.Last);
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Vector) return Element_Type is
+ begin
+ if Container.Last = No_Index then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Container.Elements (Container.Length);
+ 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 Count_Type is
+ L : constant Index_Type'Base := Container.Last;
+ F : constant Index_Type := Index_Type'First;
+
+ begin
+ -- The base range of the index type (Index_Type'Base) might not include
+ -- all values for length (Count_Type). Contrariwise, the index type
+ -- might include values outside the range of length. Hence we use
+ -- whatever type is wider for intermediate values when calculating
+ -- length. Note that no matter what the index type is, the maximum
+ -- length to which a vector is allowed to grow is always the minimum
+ -- of Count_Type'Last and (IT'Last - IT'First + 1).
+
+ -- For example, an Index_Type with range -127 .. 127 is only guaranteed
+ -- to have a base range of -128 .. 127, but the corresponding vector
+ -- would have lengths in the range 0 .. 255. In this case we would need
+ -- to use Count_Type'Base for intermediate values.
+
+ -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
+ -- vector would have a maximum length of 10, but the index values lie
+ -- outside the range of Count_Type (which is only 32 bits). In this
+ -- case we would need to use Index_Type'Base for intermediate values.
+
+ if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
+ return Count_Type'Base (L) - Count_Type'Base (F) + 1;
+ else
+ return Count_Type (L - F + 1);
+ end if;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Vector;
+ Source : in out Vector)
+ is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Source.Length then
+ raise Capacity_Error -- ???
+ with "Target capacity is less than Source length";
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (Target is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (Source is busy)";
+ end if;
+
+ -- Clear Target now, in case element assignment fails.
+ Target.Last := No_Index;
+
+ Target.Elements (1 .. Source.Length) :=
+ Source.Elements (1 .. Source.Length);
+
+ Target.Last := Source.Last;
+ Source.Last := No_Index;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ 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, Position.Index + 1);
+ end if;
+
+ return No_Element;
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ 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 := 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 (Position : in out Cursor) is
+ begin
+ if Position.Container = null then
+ return;
+ end if;
+
+ if Position.Index > Index_Type'First then
+ Position.Index := Position.Index - 1;
+ else
+ Position := No_Element;
+ end if;
+ end Previous;
+
+ 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, 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 > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (V.Elements (To_Array_Index (Index)));
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end Query_Element;
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ Query_Element (Position.Container.all, 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);
+
+ Reserve_Capacity (Container, Capacity => Length);
+
+ for Idx in Count_Type range 1 .. Length loop
+ Last := Last + 1;
+ Element_Type'Read (Stream, Container.Elements (Idx));
+ 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 elements (vector is locked)";
+ end if;
+
+ Container.Elements (To_Array_Index (Index)) := New_Item;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor denotes wrong container";
+ 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 elements (vector is locked)";
+ end if;
+
+ Container.Elements (To_Array_Index (Position.Index)) := New_Item;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Count_Type)
+ is
+ begin
+ if Capacity > Container.Capacity then
+ raise Constraint_Error with "Capacity is out of range";
+ end if;
+ end Reserve_Capacity;
+
+ ----------------------
+ -- Reverse_Elements --
+ ----------------------
+
+ procedure Reverse_Elements (Container : in out Vector) is
+ E : Elements_Array renames Container.Elements;
+ Idx, Jdx : Count_Type;
+
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is locked)";
+ end if;
+
+ Idx := 1;
+ Jdx := Container.Length;
+ while Idx < Jdx loop
+ declare
+ EI : constant Element_Type := E (Idx);
+
+ begin
+ E (Idx) := E (Jdx);
+ E (Jdx) := EI;
+ end;
+
+ Idx := Idx + 1;
+ Jdx := Jdx - 1;
+ end loop;
+ end Reverse_Elements;
+
+ ------------------
+ -- Reverse_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 /= Container'Unrestricted_Access
+ then
+ raise Program_Error with "Position cursor denotes wrong container";
+ end if;
+
+ Last :=
+ (if Position.Container = null or else Position.Index > Container.Last
+ then Container.Last
+ else Position.Index);
+
+ for Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (To_Array_Index (Indx)) = Item then
+ return (Container'Unrestricted_Access, Indx);
+ end if;
+ 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 : constant Index_Type'Base :=
+ Index_Type'Min (Container.Last, Index);
+
+ begin
+ for Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (To_Array_Index (Indx)) = Item then
+ return Indx;
+ end if;
+ end loop;
+
+ return No_Index;
+ end Reverse_Find_Index;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process : not null access procedure (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 .. Container.Last loop
+ Process (Cursor'(Container'Unrestricted_Access, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ ----------------
+ -- Set_Length --
+ ----------------
+
+ procedure Set_Length (Container : in out Vector; Length : Count_Type) is
+ Count : constant Count_Type'Base := Container.Length - Length;
+
+ begin
+ -- Set_Length allows the user to set the length explicitly, instead of
+ -- implicitly as a side-effect of deletion or insertion. If the
+ -- requested length is less then the current length, this is equivalent
+ -- to deleting items from the back end of the vector. If the requested
+ -- length is greater than the current length, then this is equivalent to
+ -- inserting "space" (nonce items) at the end.
+
+ if Count >= 0 then
+ Container.Delete_Last (Count);
+
+ elsif Container.Last >= Index_Type'Last then
+ raise Constraint_Error with "vector is already at its maximum length";
+
+ else
+ Container.Insert_Space (Container.Last + 1, -Count);
+ end if;
+ end Set_Length;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (Container : in out Vector; I, J : Index_Type) is
+ E : Elements_Array renames Container.Elements;
+
+ 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 elements (vector is locked)";
+ end if;
+
+ declare
+ EI_Copy : constant Element_Type := E (To_Array_Index (I));
+ begin
+ E (To_Array_Index (I)) := E (To_Array_Index (J));
+ E (To_Array_Index (J)) := EI_Copy;
+ end;
+ end Swap;
+
+ procedure Swap (Container : in out Vector; I, J : Cursor) is
+ begin
+ if I.Container = null then
+ raise Constraint_Error with "I cursor has no element";
+ end if;
+
+ if J.Container = null then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "I cursor denotes wrong container";
+ end if;
+
+ if J.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "J cursor denotes wrong container";
+ end if;
+
+ Swap (Container, I.Index, J.Index);
+ end Swap;
+
+ --------------------
+ -- To_Array_Index --
+ --------------------
+
+ function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
+ Offset : Count_Type'Base;
+
+ begin
+ -- We know that
+ -- Index >= Index_Type'First
+ -- hence we also know that
+ -- Index - Index_Type'First >= 0
+ --
+ -- The issue is that even though 0 is guaranteed to be a value
+ -- in the type Index_Type'Base, there's no guarantee that the
+ -- difference is a value in that type. To prevent overflow we
+ -- use the wider of Count_Type'Base and Index_Type'Base to
+ -- perform intermediate calculations.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ Offset := Count_Type'Base (Index - Index_Type'First);
+
+ else
+ Offset := Count_Type'Base (Index) -
+ Count_Type'Base (Index_Type'First);
+ end if;
+
+ -- The array index subtype for all container element arrays
+ -- always starts with 1.
+
+ return 1 + Offset;
+ end To_Array_Index;
+
+ ---------------
+ -- To_Cursor --
+ ---------------
+
+ 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'Unrestricted_Access, Index);
+ end To_Cursor;
+
+ --------------
+ -- To_Index --
+ --------------
+
+ 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;
+
+ ---------------
+ -- To_Vector --
+ ---------------
+
+ function To_Vector (Length : Count_Type) return Vector is
+ Index : Count_Type'Base;
+ Last : Index_Type'Base;
+
+ begin
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
+
+ -- We create a vector object with a capacity that matches the specified
+ -- Length, but we do not allow the vector capacity (the length of the
+ -- internal array) to exceed the number of values in Index_Type'Range
+ -- (otherwise, there would be no way to refer to those components via an
+ -- index). We must therefore check whether the specified Length would
+ -- create a Last index value greater than Index_Type'Last.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ -- We perform a two-part test. First we determine whether the
+ -- computed Last value lies in the base range of the type, and then
+ -- determine whether it lies in the range of the index (sub)type.
+
+ -- Last must satisfy this relation:
+ -- First + Length - 1 <= Last
+ -- We regroup terms:
+ -- First - 1 <= Last - Length
+ -- Which can rewrite as:
+ -- No_Index <= Last - Length
+
+ if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We now know that the computed value of Last is within the base
+ -- range of the type, so it is safe to compute its value:
+
+ Last := No_Index + Index_Type'Base (Length);
+
+ -- Finally we test whether the value is within the range of the
+ -- generic actual index subtype:
+
+ if Last > Index_Type'Last then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ elsif Index_Type'First <= 0 then
+ -- Here we can compute Last directly, in the normal way. We know that
+ -- No_Index is less than 0, so there is no danger of overflow when
+ -- adding the (positive) value of Length.
+
+ Index := Count_Type'Base (No_Index) + Length; -- Last
+
+ if Index > Count_Type'Base (Index_Type'Last) then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We know that the computed value (having type Count_Type) of Last
+ -- is within the range of the generic actual index subtype, so it is
+ -- safe to convert to Index_Type:
+
+ Last := Index_Type'Base (Index);
+
+ else
+ -- Here Index_Type'First (and Index_Type'Last) is positive, so we
+ -- must test the length indirectly (by working backwards from the
+ -- largest possible value of Last), in order to prevent overflow.
+
+ Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
+
+ if Index < Count_Type'Base (No_Index) then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We have determined that the value of Length would not create a
+ -- Last index value outside of the range of Index_Type, so we can now
+ -- safely compute its value.
+
+ Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
+ end if;
+
+ return V : Vector (Capacity => Length) do
+ V.Last := Last;
+ end return;
+ end To_Vector;
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Count_Type) return Vector
+ is
+ Index : Count_Type'Base;
+ Last : Index_Type'Base;
+
+ begin
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
+
+ -- We create a vector object with a capacity that matches the specified
+ -- Length, but we do not allow the vector capacity (the length of the
+ -- internal array) to exceed the number of values in Index_Type'Range
+ -- (otherwise, there would be no way to refer to those components via an
+ -- index). We must therefore check whether the specified Length would
+ -- create a Last index value greater than Index_Type'Last.
+
+ if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+ -- We perform a two-part test. First we determine whether the
+ -- computed Last value lies in the base range of the type, and then
+ -- determine whether it lies in the range of the index (sub)type.
+
+ -- Last must satisfy this relation:
+ -- First + Length - 1 <= Last
+ -- We regroup terms:
+ -- First - 1 <= Last - Length
+ -- Which can rewrite as:
+ -- No_Index <= Last - Length
+
+ if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We now know that the computed value of Last is within the base
+ -- range of the type, so it is safe to compute its value:
+
+ Last := No_Index + Index_Type'Base (Length);
+
+ -- Finally we test whether the value is within the range of the
+ -- generic actual index subtype:
+
+ if Last > Index_Type'Last then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ elsif Index_Type'First <= 0 then
+ -- Here we can compute Last directly, in the normal way. We know that
+ -- No_Index is less than 0, so there is no danger of overflow when
+ -- adding the (positive) value of Length.
+
+ Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
+
+ if Index > Count_Type'Base (Index_Type'Last) then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We know that the computed value (having type Count_Type) of Last
+ -- is within the range of the generic actual index subtype, so it is
+ -- safe to convert to Index_Type:
+
+ Last := Index_Type'Base (Index);
+
+ else
+ -- Here Index_Type'First (and Index_Type'Last) is positive, so we
+ -- must test the length indirectly (by working backwards from the
+ -- largest possible value of Last), in order to prevent overflow.
+
+ Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
+
+ if Index < Count_Type'Base (No_Index) then
+ raise Constraint_Error with "Length is out of range";
+ end if;
+
+ -- We have determined that the value of Length would not create a
+ -- Last index value outside of the range of Index_Type, so we can now
+ -- safely compute its value.
+
+ Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
+ end if;
+
+ return V : Vector (Capacity => Length) do
+ V.Elements := (others => New_Item);
+ V.Last := Last;
+ end return;
+ 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;
+
+ begin
+ Process (Container.Elements (To_Array_Index (Index)));
+ 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 Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor denotes wrong container";
+ 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
+ N : Count_Type;
+
+ begin
+ N := Container.Length;
+ Count_Type'Base'Write (Stream, N);
+
+ for J in 1 .. N 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.Bounded_Vectors;
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
- -----------------------
- -- Local Subprograms --
- -----------------------
-
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
-- and setting Predicate_Procedure for Typ. In some error situations no
-- procedure is built, in which case PDecl/PBody are empty on return.
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id);
+ -- Given a predicated type Typ, whose predicate expression is Expr, tests
+ -- if Expr is a static predicate, and if so, builds the predicate range
+ -- list. Nam is the name of the argument to the predicate function.
+ -- Occurrences of the type name in the predicate expression have been
+ -- replaced by identifer references to this name, which is unique, so any
+ -- identifier with Chars matching Nam must be a reference to the type. If
+ -- the predicate is non-static, this procedure returns doing nothing. If
+ -- the predicate is static, then the corresponding predicate list is stored
+ -- in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized
+ -- membership operation.
+
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
- procedure Build_Static_Predicate;
- -- This function is called to process a static predicate, and put it in
- -- canonical form and store it in Static_Predicate (Typ).
-
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of Predicate procedure
end loop;
end Add_Predicates;
- ----------------------------
- -- Build_Static_Predicate --
- ----------------------------
+ -- Start of processing for Build_Predicate_Function
- procedure Build_Static_Predicate is
- Exp : Node_Id;
- Alt : Node_Id;
+ begin
+ -- Initialize for construction of statement list
+
+ Expr := Empty;
+ FDecl := Empty;
+ FBody := Empty;
+
+ -- Return if already built or if type does not have predicates
+
+ if not Has_Predicates (Typ)
+ or else Present (Predicate_Function (Typ))
+ then
+ return;
+ end if;
+
+ -- Add Predicates for the current type
+
+ Add_Predicates;
+
+ -- Add predicates for ancestor if present
+
+ declare
+ Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ begin
+ if Present (Atyp) then
+ Add_Call (Atyp);
+ end if;
+ end;
+
+ -- If we have predicates, build the function
+
+ if Present (Expr) then
+
+ -- Deal with static predicate case
+
+ Build_Static_Predicate (Typ, Expr, Object_Name);
+
+ -- Build function declaration
+
+ pragma Assert (Has_Predicates (Typ));
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Set_Has_Predicates (SId);
+ Set_Predicate_Function (Typ, SId);
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars => Object_Name),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
+
+ -- Build function body
+
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars => Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- Non_Static : Boolean := False;
- -- Set True if something non-static is found
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
+ end if;
+ end Build_Predicate_Function;
- Plist : List_Id := No_List;
- -- The entries in Plist are either static expressions which represent
- -- a possible value, or ranges of values. Subtype marks don't appear,
- -- since we expand them out.
+ ----------------------------
+ -- Build_Static_Predicate --
+ ----------------------------
+
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Non_Static : exception;
+ -- Raised if something non-static is found
+
+ TLo, THi : Uint;
+ -- Low bound and high bound values of static subtype of Typ
+
+ type REnt is record
Lo, Hi : Uint;
- -- Low bound and high bound values of static subtype of Typ
+ end record;
+ -- One entry in a Rlist value, a single REnt (range entry) value
+ -- denotes one range from Lo to Hi. To represent a single value
+ -- range Lo = Hi = value.
+
+ type RList is array (Nat range <>) of REnt;
+ -- A list of ranges. The ranges are sorted in increasing order,
+ -- and are disjoint (there is a gap of at least one value between
+ -- each range in the table).
+
+ Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+ True_Range : RList renames Null_Range;
+ -- Constant representing null list of ranges, used to represent a
+ -- predicate of True, since there are no ranges to be satisfied.
+
+ False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0));
+ -- Range representing false
+
+ function "and" (Left, Right : RList) return RList;
+ -- And's together two range lists, returning a range list. This is
+ -- a set intersection operation.
+
+ function "or" (Left, Right : RList) return RList;
+ -- Or's together two range lists, returning a range list. This is a
+ -- set union operation.
+
+ function "not" (Right : RList) return RList;
+ -- Returns complement of a given range list, i.e. a range list
+ -- representing all the values in TLo .. THi that are not in the
+ -- input operand Right.
+
+ function Build_Val (V : Uint) return Node_Id;
+ -- Return an analyzed N_Identifier node referencing this value, suitable
+ -- for use as an entry in the Static_Predicate list.
+
+ function Build_Range (Lo, Hi : Uint) return Node_Id;
+ -- Return an analyzed N_Range node referencing this range, suitable
+ -- for use as an entry in the Static_Predicate list.
+
+ function Get_RList (Exp : Node_Id) return RList;
+ -- This is a recursive routine that converts the given expression into
+ -- a list of ranges, suitable for use in building the static predicate.
+
+ function Is_Type_Ref (N : Node_Id) return Boolean;
+ pragma Inline (Is_Type_Ref);
+ -- Returns if True if N is a reference to the type for the predicate in
+ -- the expression (i.e. if it is an identifier whose Chars field matches
+ -- the Nam given in the call).
+
+ function Lo_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value or low bound of range.
+
+ function Hi_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value of high bound of range.
+
+ function Membership_Entry (N : Node_Id) return RList;
+ -- Given a single membership entry (range, value, or subtype), returns
+ -- the corresponding range list. Raises Static_Error if not static.
+
+ function Membership_Entries (N : Node_Id) return RList;
+ -- Given an element on an alternatives list of a membership operation,
+ -- returns the range list corresponding to this entry and all following
+ -- entries (i.e. returns the "or" of this list of values).
+
+ function Stat_Pred (Typ : Entity_Id) return RList;
+ -- Given a type, if it has a static predicate, then return the predicate
+ -- as a range list, otherwise raise Non_Static.
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and" (Left, Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
- procedure Process_Entry (N : Node_Id);
- -- Process one entry (range or value or subtype mark)
+ begin
+ -- If either range is True, return the other
- -------------------
- -- Process_Entry --
- -------------------
+ if Left = True_Range then
+ return Right;
+ elsif Right = True_Range then
+ return Left;
+ end if;
- procedure Process_Entry (N : Node_Id) is
- SLo, SHi : Uint;
- -- Low and high bounds of range in list
+ -- If either range is False, return False
- P : Node_Id;
+ if Left = False_Range or else Right = False_Range then
+ return False_Range;
+ end if;
- function Build_Val (V : Uint) return Node_Id;
- -- Return an analyzed N_Identifier node referencing this value
+ -- If either range is empty, return False
- function Build_Range (Lo, Hi : Uint) return Node_Id;
- -- Return an analyzed N_Range node referencing this range
+ if Left'Length = 0 or else Right'Length = 0 then
+ return False_Range;
+ end if;
- function Lo_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- or low bound of range.
+ -- Loop to remove entries at start that are disjoint, and thus
+ -- just get discarded from the result entirely.
- function Hi_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- of high bound of range.
+ loop
+ -- If no operands left in either operand, result is false
- -----------------
- -- Build_Range --
- -----------------
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return False_Range;
- function Build_Range (Lo, Hi : Uint) return Node_Id is
- Result : Node_Id;
- begin
- if Lo = Hi then
- return Build_Val (Hi);
- else
- Result :=
- Make_Range (Sloc (N),
- Low_Bound => Build_Val (Lo),
- High_Bound => Build_Val (Hi));
- Set_Etype (Result, Typ);
- Set_Analyzed (Result);
- return Result;
- end if;
- end Build_Range;
+ -- Discard first left operand entry if disjoint with right
- ---------------
- -- Build_Val --
- ---------------
+ elsif Left (SLeft).Hi < Right (SRight).Lo then
+ SLeft := SLeft + 1;
- function Build_Val (V : Uint) return Node_Id is
- Result : Node_Id;
+ -- Discard first right operand entry if disjoint with left
- begin
- if Is_Enumeration_Type (Typ) then
- Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N));
- else
- Result := Make_Integer_Literal (Sloc (N), Intval => V);
- end if;
+ elsif Right (SRight).Hi < Left (SLeft).Lo then
+ SRight := SRight + 1;
- Set_Etype (Result, Typ);
- Set_Is_Static_Expression (Result);
- Set_Analyzed (Result);
- return Result;
- end Build_Val;
+ -- Otherwise we have an overlapping entry
- ------------
- -- Hi_Val --
- ------------
+ else
+ exit;
+ end if;
+ end loop;
- function Hi_Val (N : Node_Id) return Uint is
- begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
- else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (High_Bound (N));
- end if;
- end Hi_Val;
+ -- Now we have two non-null operands, and first entries overlap.
+ -- The first entry in the result will be the overlapping part of
+ -- these two entries.
- ------------
- -- Lo_Val --
- ------------
+ FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
+ Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
- function Lo_Val (N : Node_Id) return Uint is
- begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
- else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (Low_Bound (N));
- end if;
- end Lo_Val;
+ -- Now we can remove the entry that ended at a lower value, since
+ -- its contribution is entirely contained in Fent.
+
+ if Left (SLeft).Hi <= Right (SRight).Hi then
+ SLeft := SLeft + 1;
+ else
+ SRight := SRight + 1;
+ end if;
+
+ -- If either operand is empty, that's the only entry
+
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return RList'(1 => FEnt);
+
+ -- Else compute and of remaining entries and concatenate
+
+ else
+ return
+ FEnt &
+ (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
+ end if;
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not" (Right : RList) return RList is
+ begin
+ -- Return True if False range
+
+ if Right = False_Range then
+ return True_Range;
+ end if;
+
+ -- Return False if True range
- -- Start of processing for Process_Entry
+ if Right'Length = 0 then
+ return False_Range;
+ end if;
+
+ -- Here if not trivial case
+
+ declare
+ Result : RList (1 .. Right'Length + 1);
+ -- May need one more entry for gap at beginning and end
+
+ Count : Nat := 0;
+ -- Number of entries stored in Result
begin
- -- Range case
+ -- Gap at start
- if Nkind (N) = N_Range then
- if not Is_Static_Expression (Low_Bound (N))
- or else
- not Is_Static_Expression (High_Bound (N))
+ if Right (Right'First).Lo > TLo then
+ Count := Count + 1;
+ Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
+ end if;
+
+ -- Gaps between ranges
+
+ for J in Right'First .. Right'Last - 1 loop
+ Count := Count + 1;
+ Result (Count) :=
+ REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
+ end loop;
+
+ -- Gap at end
+
+ if Right (Right'Last).Hi < THi then
+ Count := Count + 1;
+ Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
+ end if;
+
+ return Result (1 .. Count);
+ end;
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or" (Left, Right : RList) return RList is
+ begin
+ -- If either range is True, return True
+
+ if Left = True_Range or else Right = True_Range then
+ return True_Range;
+ end if;
+
+ -- If either range is False, return the other
+
+ if Left = False_Range then
+ return Right;
+ elsif Right = False_Range then
+ return Left;
+ end if;
+
+ -- If either operand is null, return the other one
+
+ if Left'Length = 0 then
+ return Right;
+ elsif Right'Length = 0 then
+ return Left;
+ end if;
+
+ -- Now we have two non-null ranges
+
+ declare
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
+
+ begin
+ -- Initialize result first entry from left or right operand
+ -- depending on which starts with the lower range.
+
+ if Left (SLeft).Lo < Right (SRight).Lo then
+ FEnt := Left (SLeft);
+ SLeft := SLeft + 1;
+ else
+ FEnt := Right (SRight);
+ SRight := SRight + 1;
+ end if;
+
+ -- This loop eats ranges from left and right operands that
+ -- are contiguous with the first range we are gathering.
+
+ loop
+ -- Eat first entry in left operand if contiguous or
+ -- overlapped by gathered first operand of result.
+
+ if SLeft <= Left'Last
+ and then Left (SLeft).Lo <= FEnt.Hi + 1
then
- Non_Static := True;
- return;
+ FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
+ SLeft := SLeft + 1;
+
+ -- Eat first entry in right operand if contiguous or
+ -- overlapped by gathered right operand of result.
+
+ elsif SRight <= Right'Last
+ and then Right (SRight).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+ SRight := SRight + 1;
+
+ -- All done if no more entries to eat!
+
else
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ exit;
end if;
+ end loop;
- -- Static expression case
+ -- If left operand now empty, concatenate our new entry to right
- elsif Is_Static_Expression (N) then
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ if SLeft > Left'Last then
+ return FEnt & Right (SRight .. Right'Last);
- -- Identifier (other than static expression) case
+ -- If right operand now empty, concatenate our new entry to left
- else pragma Assert (Nkind (N) = N_Identifier);
+ elsif SRight > Right'Last then
+ return FEnt & Left (SLeft .. Left'Last);
- -- Type case
+ -- Otherwise, compute or of what is left and concatenate
- if Is_Type (Entity (N)) then
+ else
+ return
+ FEnt &
+ (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+ end if;
+ end;
+ end "or";
- -- If type has static predicates, process them recursively
+ -----------------
+ -- Build_Range --
+ -----------------
- if Present (Static_Predicate (Entity (N))) then
- P := First (Static_Predicate (Entity (N)));
- while Present (P) loop
- Process_Entry (P);
+ function Build_Range (Lo, Hi : Uint) return Node_Id is
+ Result : Node_Id;
+ begin
+ if Lo = Hi then
+ return Build_Val (Hi);
+ else
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Lo),
+ High_Bound => Build_Val (Hi));
+ Set_Etype (Result, Typ);
+ Set_Analyzed (Result);
+ return Result;
+ end if;
+ end Build_Range;
- if Non_Static then
- return;
- else
- Next (P);
- end if;
- end loop;
+ ---------------
+ -- Build_Val --
+ ---------------
- return;
+ function Build_Val (V : Uint) return Node_Id is
+ Result : Node_Id;
- -- For static subtype without predicates, get range
+ begin
+ if Is_Enumeration_Type (Typ) then
+ Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
+ else
+ Result := Make_Integer_Literal (Loc, Intval => V);
+ end if;
- elsif Is_Static_Subtype (Entity (N))
- and then not Has_Predicates (Entity (N))
- then
- SLo := Expr_Value (Type_Low_Bound (Entity (N)));
- SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ Set_Etype (Result, Typ);
+ Set_Is_Static_Expression (Result);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Val;
- -- Any other type makes us non-static
+ ---------------
+ -- Get_RList --
+ ---------------
- else
- Non_Static := True;
- return;
- end if;
+ function Get_RList (Exp : Node_Id) return RList is
+ Op : Node_Kind;
+ Val : Uint;
+
+ begin
+ -- Static expression can only be true or false
+
+ if Is_OK_Static_Expression (Exp) then
+
+ -- For False, return impossible range, which will always fail
+
+ if Expr_Value (Exp) = 0 then
+ return False_Range;
+
+ -- For True, null range
+
+ else
+ return Null_Range;
+ end if;
+ end if;
+
+ -- Otherwise test node type
+
+ Op := Nkind (Exp);
+
+ case Op is
+
+ -- And
+
+ when N_Op_And | N_And_Then =>
+ return Get_RList (Left_Opnd (Exp))
+ and
+ Get_RList (Right_Opnd (Exp));
+
+ -- Or
+
+ when N_Op_Or | N_Or_Else =>
+ return Get_RList (Left_Opnd (Exp))
+ or
+ Get_RList (Right_Opnd (Exp));
+
+ -- Not
+
+ when N_Op_Not =>
+ return not Get_RList (Right_Opnd (Exp));
+
+ -- Comparisons of type with static value
+
+ when N_Op_Compare =>
+ -- Type is left operand
+
+ if Is_Type_Ref (Left_Opnd (Exp))
+ and then Is_OK_Static_Expression (Right_Opnd (Exp))
+ then
+ Val := Expr_Value (Right_Opnd (Exp));
- -- Any other kind of identifier in predicate (e.g. a non-static
- -- expression value) means this is not a static predicate.
+ -- Typ is right operand
+
+ elsif Is_Type_Ref (Right_Opnd (Exp))
+ and then Is_OK_Static_Expression (Left_Opnd (Exp))
+ then
+ Val := Expr_Value (Left_Opnd (Exp));
+
+ -- Invert sense of comparison
+
+ case Op is
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Ge;
+ when others => null;
+ end case;
+
+ -- Other cases are non-static
else
- Non_Static := True;
- return;
+ raise Non_Static;
end if;
- end if;
- -- Here with SLo and SHi set for (possibly single element) range
- -- of entry to insert in Plist. Non-static if out of range.
+ -- Construct range according to comparison operation
- if SLo < Lo or else SHi > Hi then
- Non_Static := True;
- return;
- end if;
+ case Op is
+ when N_Op_Eq =>
+ return RList'(1 => REnt'(Val, Val));
- -- If no Plist currently, create it
+ when N_Op_Ge =>
+ return RList'(1 => REnt'(Val, THi));
- if No (Plist) then
- Plist := New_List (Build_Range (SLo, SHi));
- return;
+ when N_Op_Gt =>
+ return RList'(1 => REnt'(Val + 1, THi));
- -- Otherwise search Plist for insertion point
+ when N_Op_Le =>
+ return RList'(1 => REnt'(TLo, Val));
- else
- P := First (Plist);
- loop
- -- Case of inserting before current entry
+ when N_Op_Lt =>
+ return RList'(1 => REnt'(TLo, Val - 1));
- if SHi < Lo_Val (P) - 1 then
- Insert_Before (P, Build_Range (SLo, SHi));
- exit;
+ when N_Op_Ne =>
+ return RList'(REnt'(TLo, Val - 1),
+ REnt'(Val + 1, THi));
- -- Case of belongs past current entry
+ when others =>
+ raise Program_Error;
+ end case;
- elsif SLo > Hi_Val (P) + 1 then
+ -- Membership (IN)
- -- End of list case
+ when N_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
- if No (Next (P)) then
- Append_To (Plist, Build_Range (SLo, SHi));
- exit;
+ if Present (Right_Opnd (Exp)) then
+ return Membership_Entry (Right_Opnd (Exp));
+ else
+ return Membership_Entries (First (Alternatives (Exp)));
+ end if;
- -- Else just move to next item on list
+ -- Negative membership (NOT IN)
- else
- Next (P);
+ when N_Not_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
+
+ if Present (Right_Opnd (Exp)) then
+ return not Membership_Entry (Right_Opnd (Exp));
+ else
+ return not Membership_Entries (First (Alternatives (Exp)));
+ end if;
+
+ -- Function call, may be call to static predicate
+
+ when N_Function_Call =>
+ if Is_Entity_Name (Name (Exp)) then
+ declare
+ Ent : constant Entity_Id := Entity (Name (Exp));
+ begin
+ if Has_Predicates (Ent) then
+ return Stat_Pred (Etype (First_Formal (Ent)));
end if;
+ end;
+ end if;
- -- Case of extending current entyr, and in overlap cases
- -- may also eat up entries past this one.
+ -- Other function call cases are non-static
- else
- declare
- New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo);
- New_Hi : Uint := UI_Max (Hi_Val (P), SHi);
+ raise Non_Static;
- begin
- -- See if there are entries past us that we eat up
+ -- Qualified expression, dig out the expression
- while Present (Next (P))
- and then Lo_Val (Next (P)) <= New_Hi + 1
- loop
- New_Hi := Hi_Val (Next (P));
- Remove (Next (P));
- end loop;
+ when N_Qualified_Expression =>
+ return Get_RList (Expression (Exp));
- -- We now need to replace the current node P with
- -- a new entry New_Lo .. New_Hi.
+ -- Any other node type is non-static
- Insert_After (P, Build_Range (New_Lo, New_Hi));
- Remove (P);
- exit;
- end;
- end if;
- end loop;
- end if;
- end Process_Entry;
+ when others =>
+ raise Non_Static;
+ end case;
+ end Get_RList;
- -- Start of processing for Build_Static_Predicate
+ ------------
+ -- Hi_Val --
+ ------------
+ function Hi_Val (N : Node_Id) return Uint is
begin
- -- Immediately non-static if our subtype is non static, or we
- -- do not have an appropriate discrete subtype in the first place.
-
- if not Ekind_In (Typ, E_Enumeration_Subtype,
- E_Modular_Integer_Subtype,
- E_Signed_Integer_Subtype)
- or else not Is_Static_Subtype (Typ)
- then
- return;
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (High_Bound (N));
end if;
+ end Hi_Val;
- Lo := Expr_Value (Type_Low_Bound (Typ));
- Hi := Expr_Value (Type_High_Bound (Typ));
-
- -- Check if we have membership predicate
+ -----------------
+ -- Is_Type_Ref --
+ -----------------
- if Nkind (Expr) = N_In then
- Exp := Expr;
+ function Is_Type_Ref (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Identifier and then Chars (N) = Nam;
+ end Is_Type_Ref;
- -- Allow qualified expression with membership predicate inside
+ ------------
+ -- Lo_Val --
+ ------------
- elsif Nkind (Expr) = N_Qualified_Expression
- and then Nkind (Expression (Expr)) = N_In
- then
- Exp := Expression (Expr);
+ function Lo_Val (N : Node_Id) return Uint is
+ begin
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (Low_Bound (N));
+ end if;
+ end Lo_Val;
- -- Anything else cannot be a static predicate
+ ------------------------
+ -- Membership_Entries --
+ ------------------------
+ function Membership_Entries (N : Node_Id) return RList is
+ begin
+ if No (Next (N)) then
+ return Membership_Entry (N);
else
- return;
+ return Membership_Entry (N) or Membership_Entries (Next (N));
end if;
+ end Membership_Entries;
- -- We have a membership operation, so we have a potentially static
- -- predicate, collect and canonicalize the entries in the list.
+ ----------------------
+ -- Membership_Entry --
+ ----------------------
- if Present (Right_Opnd (Exp)) then
- Process_Entry (Right_Opnd (Exp));
+ function Membership_Entry (N : Node_Id) return RList is
+ Val : Uint;
+ SLo : Uint;
+ SHi : Uint;
- if Non_Static then
- return;
+ begin
+ -- Range case
+
+ if Nkind (N) = N_Range then
+ if not Is_Static_Expression (Low_Bound (N))
+ or else
+ not Is_Static_Expression (High_Bound (N))
+ then
+ raise Non_Static;
+ else
+ SLo := Expr_Value (Low_Bound (N));
+ SHi := Expr_Value (High_Bound (N));
+ return RList'(1 => REnt'(SLo, SHi));
end if;
- else
- Alt := First (Alternatives (Exp));
- while Present (Alt) loop
- Process_Entry (Alt);
+ -- Static expression case
- if Non_Static then
- return;
- end if;
+ elsif Is_Static_Expression (N) then
+ Val := Expr_Value (N);
+ return RList'(1 => REnt'(Val, Val));
- Next (Alt);
- end loop;
- end if;
+ -- Identifier (other than static expression) case
- -- Processing was successful and all entries were static, so
- -- now we can store the result as the predicate list.
+ else pragma Assert (Nkind (N) = N_Identifier);
- Set_Static_Predicate (Typ, Plist);
+ -- Type case
- -- The processing for static predicates coalesced ranges and also
- -- eliminated duplicates. We might as well replace the alternatives
- -- list of the right operand of the membership test with the static
- -- predicate list, which will be more efficient.
+ if Is_Type (Entity (N)) then
- declare
- New_Alts : constant List_Id := New_List;
- Old_Node : Node_Id;
- New_Node : Node_Id;
+ -- If type has predicates, process them
- begin
- Old_Node := First (Plist);
- while Present (Old_Node) loop
- New_Node := New_Copy (Old_Node);
+ if Has_Predicates (Entity (N)) then
+ return Stat_Pred (Entity (N));
- if Nkind (New_Node) = N_Range then
- Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
- Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
- end if;
+ -- For static subtype without predicates, get range
- Append_To (New_Alts, New_Node);
- Next (Old_Node);
- end loop;
+ elsif Is_Static_Subtype (Entity (N)) then
+ SLo := Expr_Value (Type_Low_Bound (Entity (N)));
+ SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ return RList'(1 => REnt'(SLo, SHi));
+
+ -- Any other type makes us non-static
- -- Now update the membership test node
+ else
+ raise Non_Static;
+ end if;
- pragma Assert (Nkind (Expr) = N_In);
+ -- Any other kind of identifier in predicate (e.g. a non-static
+ -- expression value) means this is not a static predicate.
- if List_Length (New_Alts) = 1 then
- Set_Right_Opnd (Expr, First (New_Alts));
- Set_Alternatives (Expr, No_List);
else
- Set_Alternatives (Expr, New_Alts);
- Set_Right_Opnd (Expr, Empty);
+ raise Non_Static;
end if;
- end;
- end Build_Static_Predicate;
+ end if;
+ end Membership_Entry;
- -- Start of processing for Build_Predicate_Function
+ ---------------
+ -- Stat_Pred --
+ ---------------
- begin
- -- Initialize for construction of statement list
+ function Stat_Pred (Typ : Entity_Id) return RList is
+ begin
+ -- Not static if type does not have static predicates
- Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
+ if not Has_Predicates (Typ)
+ or else No (Static_Predicate (Typ))
+ then
+ raise Non_Static;
+ end if;
- -- Return if already built or if type does not have predicates
+ -- Otherwise we convert the predicate list to a range list
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
+ declare
+ Result : RList (1 .. List_Length (Static_Predicate (Typ)));
+ P : Node_Id;
+
+ begin
+ P := First (Static_Predicate (Typ));
+ for J in Result'Range loop
+ Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
+ Next (P);
+ end loop;
+
+ return Result;
+ end;
+ end Stat_Pred;
+
+ -- Start of processing for Build_Static_Predicate
+
+ begin
+ -- Immediately non-static if our subtype is non static, or we
+ -- do not have an appropriate discrete subtype in the first place.
+
+ if not Ekind_In (Typ, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ or else not Is_Static_Subtype (Typ)
then
return;
end if;
- -- Add Predicates for the current type
+ -- Get bounds of the type
- Add_Predicates;
+ TLo := Expr_Value (Type_Low_Bound (Typ));
+ THi := Expr_Value (Type_High_Bound (Typ));
- -- Add predicates for ancestor if present
+ -- Now analyze the expression to see if it is a static predicate
declare
- Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ Ranges : constant RList := Get_RList (Expr);
+ -- Range list from expression if it is static
+
+ Plist : List_Id;
+
begin
- if Present (Atyp) then
- Add_Call (Atyp);
- end if;
- end;
+ -- Convert range list into a form for the static predicate. In the
+ -- Ranges array, we just have raw ranges, these must be converted
+ -- to properly typed and analyzed static expressions or range nodes.
- -- If we have predicates, build the function
+ Plist := New_List;
- if Present (Expr) then
+ for J in Ranges'Range loop
+ declare
+ Lo : constant Uint := Ranges (J).Lo;
+ Hi : constant Uint := Ranges (J).Hi;
- -- Deal with static predicate case
+ begin
+ if Lo = Hi then
+ Append_To (Plist, Build_Val (Lo));
+ else
+ Append_To (Plist, Build_Range (Lo, Hi));
+ end if;
+ end;
+ end loop;
- Build_Static_Predicate;
+ -- Processing was successful and all entries were static, so now we
+ -- can store the result as the predicate list.
- -- Build function declaration
+ Set_Static_Predicate (Typ, Plist);
- pragma Assert (Has_Predicates (Typ));
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Predicate_Function (Typ, SId);
+ -- The processing for static predicates put the expression into
+ -- canonical form as a series of ranges. It also eliminated
+ -- duplicates and collapsed and combined ranges. We might as well
+ -- replace the alternatives list of the right operand of the
+ -- membership test with the static predicate list, which will
+ -- usually be more efficient.
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ declare
+ New_Alts : constant List_Id := New_List;
+ Old_Node : Node_Id;
+ New_Node : Node_Id;
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ begin
+ Old_Node := First (Plist);
+ while Present (Old_Node) loop
+ New_Node := New_Copy (Old_Node);
- -- Build function body
+ if Nkind (New_Node) = N_Range then
+ Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
+ Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
+ end if;
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Append_To (New_Alts, New_Node);
+ Next (Old_Node);
+ end loop;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ -- If empty list, replace by True
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
- end if;
- end Build_Predicate_Function;
+ if Is_Empty_List (New_Alts) then
+ Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc));
+
+ -- If singleton list, replace by simple membership test
+
+ elsif List_Length (New_Alts) = 1 then
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Relocate_Node (First (New_Alts)),
+ Alternatives => No_List));
+
+ -- If more than one range, replace by set membership test
+
+ else
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Empty,
+ Alternatives => New_Alts));
+ end if;
+ end;
+ end;
+
+ -- If non-static, return doing nothing
+
+ exception
+ when Non_Static =>
+ return;
+ end Build_Static_Predicate;
-----------------------------------
-- Check_Constant_Address_Clause --
projects / platform / upstream / linaro-gcc.git / commitdiff