libadalang_tools_24.0.0_d864b5a8/testsuite/tests/pp/S225-027/in/utils-fast_vectors.adb

------------------------------------------------------------------------------
--                                                                          --
--                            GNAT2XML COMPONENTS                           --
--                                                                          --
--                               V E C T O R S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2013-2017, AdaCore                     --
--                                                                          --
-- Gnat2xml is free software; you can redistribute it and/or modify it      --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. Gnat2xml is distributed  in the hope  that it will be useful,   --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER-      --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License distributed with GNAT; see file COPYING. If   --
-- not, write to the Free Software Foundation, 59 Temple Place Suite 330,   --
-- Boston, MA 02111-1307, USA.                                              --
-- The gnat2xml tool was derived from the Avatox sources.                   --
------------------------------------------------------------------------------

with Ada.Containers.Generic_Array_Sort;
with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;

with System;
use type System.Address;

package body Utils.Fast_Vectors is

   pragma Suppress (All_Checks);

   procedure Free is new Ada.Unchecked_Deallocation (Elements_Type,
                                                     Elements_Access);

   type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with
   record
      Container : Vector_Access;
      Index     : Index_Type'Base;
   end record;

   overriding function First (Object : Iterator) return Cursor;
   overriding function Last (Object : Iterator) return Cursor;

   overriding function Next
     (Object : Iterator; Position : Cursor) return Cursor;

   overriding function Previous
     (Object : Iterator; Position : Cursor) return Cursor;

   ---------
   -- "=" --
   ---------

   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 Index_Type range Index_Type'First .. Left.Last loop
         if Left.Elements.EA (J) /= Right.Elements.EA (J) then
            return False;
         end if;
      end loop;

      return True;
   end "=";

   ------------
   -- Adjust --
   ------------

   procedure Adjust (Container : in out Vector) is
   begin
      if Container.Last = No_Index then
         Container.Elements := Empty_Elements'Access;
         return;
      end if;

      declare
         L  : constant Index_Type := Container.Last;
         EA : Elements_Array renames
           Container.Elements.EA (Index_Type'First .. L);

      begin
         Container.Elements := Empty_Elements'Access;

         --  Note: it may seem that the following assignment to Container.Last
         --  is useless, since we assign it to L below. However this code is
         --  used in case 'new Elements_Type' below raises an exception, to
         --  keep Container in a consistent state.

         Container.Last     := No_Index;
         Container.Elements := new Elements_Type'(L, EA);
         Container.Last     := L;
      end;
   end Adjust;

   procedure Append (Container : in out Vector; New_Item : Element_Type) is
   begin
      Append (Container).all := New_Item;
   end Append;

   function Append (Container : in out Vector) return Element_Access is
      pragma Assert (Index_Type'First = 1);
      New_Last : constant Index_Type'Base := Container.Last + 1;
      New_Elts : Elements_Access;
   begin
      if Container.Last = Container.Elements.Last then
         if Container.Last = 0 then
            pragma Assert (Container.Elements = Empty_Elements'Access);
            New_Elts := new Elements_Type (Last => 2**10);
         else
            New_Elts := new Elements_Type (Last => 2 * Container.Last);
            New_Elts.EA (1 .. Container.Last) := Container.Elements.EA;
            Free (Container.Elements);
         end if;
         Container.Elements := New_Elts;
      end if;

      Container.Last := New_Last;
      return Container.Elements.EA (New_Last)'Unrestricted_Access;
   end Append;

   -----------
   -- Clear --
   -----------

   procedure Clear (Container : in out Vector) is
   begin
      Container.Last := No_Index;
   end Clear;

   ------------------------
   -- Constant_Reference --
   ------------------------

   function Constant_Reference
     (Container : aliased Vector; Position : Cursor)
      return Constant_Reference_Type
   is
   begin
      return R : constant Constant_Reference_Type :=
        (Element =>
           Container.Elements.EA (Position.Index)'Unrestricted_Access);
   end Constant_Reference;

   function Constant_Reference
     (Container : aliased Vector; Index : Index_Type)
      return Constant_Reference_Type
   is
   begin
      pragma Assert (Index in 1 .. Last_Index (Container));
      return R : constant Constant_Reference_Type :=
        (Element => Container.Elements.EA (Index)'Unrestricted_Access);
   end Constant_Reference;

   -----------------
   -- Delete_Last --
   -----------------

   procedure Delete_Last (Container : in out Vector) is
   begin
      Container.Last := Container.Last - 1;
   end Delete_Last;

   -------------
   -- Element --
   -------------

   function Element
     (Container : Vector; Index : Index_Type) return Element_Type
   is
   begin

      return Container.Elements.EA (Index);
   end Element;

   function Element (Position : Cursor) return Element_Type is
   begin
      return Position.Container.Elements.EA (Position.Index);
   end Element;

   --------------
   -- Elements --
   --------------

   function Elems (Container : Vector) return Big_Ptr is
      function Cast is new Ada.Unchecked_Conversion (System.Address, Big_Ptr);
   begin
      return Cast (Container.Elements.EA'Address);
   end Elems;

   ------------------
   -- Elems_Var --
   ------------------

   function Elems_Var (Container : Vector) return Big_Ptr_Var is
      function Cast is new Ada.Unchecked_Conversion (System.Address,
                                                     Big_Ptr_Var);
   begin
      return Cast (Container.Elements.EA'Address);
   end Elems_Var;

   -----------
   -- First --
   -----------

   function First (Container : Vector) return Cursor is
   begin
      if Is_Empty (Container) then
         return No_Element;
      else
         return (Container'Unrestricted_Access, Index_Type'First);
      end if;
   end First;

   function First (Object : Iterator) return Cursor is
   begin
      --  The value of the iterator object's Index component influences the
      --  behavior of the First (and Last) selector function.

      --  When the Index component is No_Index, this means the iterator
      --  object was constructed without a start expression, in which case the
      --  (forward) iteration starts from the (logical) beginning of the entire
      --  sequence of items (corresponding to Container.First, for a forward
      --  iterator).

      --  Otherwise, this is iteration over a partial sequence of items.
      --  When the Index component isn't No_Index, the iterator object was
      --  constructed with a start expression, that specifies the position
      --  from which the (forward) partial iteration begins.

      if Object.Index = No_Index then
         return First (Object.Container.all);
      else
         return Cursor'(Object.Container, Object.Index);
      end if;
   end First;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Container : in out Vector) is
   begin
      if Container.Elements = Empty_Elements'Access then
         pragma Assert (Container.Last = No_Index);
      else
         Free (Container.Elements);
         Container.Elements := Empty_Elements'Access;
         Container.Last     := No_Index;
      end if;
   end Finalize;

   ----------
   -- Free --
   ----------

   procedure Free (Container : in out Vector) is
   begin
      Finalize (Container);
   end Free;

   ---------------------
   -- 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.EA;
         begin
            for J in Index_Type'First .. Container.Last - 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 : Index_Type'Base := Target.Last;
         J : Index_Type'Base;

      begin
         --  The semantics of Merge changed slightly per AI05-0021. It was
         --  originally the case that if Target and Source denoted the same
         --  container object, then the GNAT implementation of Merge did
         --  nothing. However, it was argued that RM05 did not precisely
         --  specify the semantics for this corner case. The decision of
         --  the ARG was that if Target and Source denote the same non-empty
         --  container object, then Program_Error is raised.

         if Source.Last < Index_Type'First then  -- Source is empty
            return;
         end if;

         if Target.Last < Index_Type'First then  -- Target is empty
            Move (Target => Target, Source => Source);
            return;
         end if;

         Target.Set_Length (Length (Target) + Length (Source));

         declare
            TA : Elements_Array renames Target.Elements.EA;
            SA : Elements_Array renames Source.Elements.EA;

         begin
            J := Target.Last;
            while Source.Last >= Index_Type'First loop
               pragma Assert
                 (Source.Last <= Index_Type'First
                  or else not (SA (Source.Last) < SA (Source.Last - 1)));

               if I < Index_Type'First then
                  TA (Index_Type'First .. J) :=
                    SA (Index_Type'First .. Source.Last);

                  Source.Last := No_Index;
                  return;
               end if;

               pragma Assert
                 (I <= Index_Type'First or else not (TA (I) < TA (I - 1)));

               if SA (Source.Last) < TA (I) then
                  TA (J) := TA (I);
                  I      := I - 1;

               else
                  TA (J)      := SA (Source.Last);
                  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   => Index_Type,
                                                   Element_Type => Element_Type, Array_Type => Elements_Array,
                                                   "<"          => "<");

      begin
         if Container.Last <= Index_Type'First then
            return;
         end if;

         --  The exception behavior for the vector container must match that
         --  for the list container, so we check for cursor tampering here
         --  (which will catch more things) instead of for element tampering
         --  (which will catch fewer things). It's true that the elements of
         --  this vector container could be safely moved around while (say)
         --  an iteration is taking place (iteration only increments the busy
         --  counter), and so technically all we would need here is a test for
         --  element tampering (indicated by the lock counter), that's simply
         --  an artifact of our array-based implementation. Logically Sort
         --  requires a check for cursor tampering.

         Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
      end Sort;

   end Generic_Sorting;

   -----------------
   -- Has_Element --
   -----------------

   function Has_Element (Position : Cursor) return Boolean is
   begin
      return Position /= No_Element;
   end Has_Element;

   --------------
   -- 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
   begin
      for Indx in Index_Type'First .. Container.Last loop
         Process (Cursor'(Container'Unrestricted_Access, Indx));
      end loop;
   end Iterate;

   function Iterate
     (Container : Vector)
      return Vector_Iterator_Interfaces.Reversible_Iterator'Class
   is
      V : constant Vector_Access := Container'Unrestricted_Access;
   begin
      --  The value of its Index component influences the behavior of the First
      --  and Last selector functions of the iterator object. When the Index
      --  component is No_Index (as is the case here), this means the iterator
      --  object was constructed without a start expression. This is a complete
      --  iterator, meaning that the iteration starts from the (logical)
      --  beginning of the sequence of items.

      --  Note: For a forward iterator, Container.First is the beginning, and
      --  for a reverse iterator, Container.Last is the beginning.

      return It : constant Iterator := (Container => V, Index => No_Index) do
         null;
      end return;
   end Iterate;

   function Iterate
     (Container : Vector; Start : Cursor)
      return Vector_Iterator_Interfaces.Reversible_Iterator'Class
   is
      V : constant Vector_Access := Container'Unrestricted_Access;
   begin
      --  It was formerly the case that when Start = No_Element, the partial
      --  iterator was defined to behave the same as for a complete iterator,
      --  and iterate over the entire sequence of items. However, those
      --  semantics were unintuitive and arguably error-prone (it is too easy
      --  to accidentally create an endless loop), and so they were changed,
      --  per the ARG meeting in Denver on 2011/11. However, there was no
      --  consensus about what positive meaning this corner case should have,
      --  and so it was decided to simply raise an exception. This does imply,
      --  however, that it is not possible to use a partial iterator to specify
      --  an empty sequence of items.

      --  The value of its Index component influences the behavior of the First
      --  and Last selector functions of the iterator object. When the Index
      --  component is not No_Index (as is the case here), it means that this
      --  is a partial iteration, over a subset of the complete sequence of
      --  items. The iterator object was constructed with a start expression,
      --  indicating the position from which the iteration begins. Note that
      --  the start position has the same value irrespective of whether this
      --  is a forward or reverse iteration.

      return
        It : constant Iterator := (Container => V, Index => Start.Index) do
         null;
      end return;
   end Iterate;

   ----------
   -- Last --
   ----------

   function Last_Ptr (Container : in out Vector) return Element_Access is
   begin
      return Container.Elements.EA (Container.Last)'Unrestricted_Access;
   end Last_Ptr;

   function Last (Container : Vector) return Cursor is
   begin
      if Is_Empty (Container) then
         return No_Element;
      else
         return (Container'Unrestricted_Access, Container.Last);
      end if;
   end Last;

   function Last (Object : Iterator) return Cursor is
   begin
      --  The value of the iterator object's Index component influences the
      --  behavior of the Last (and First) selector function.

      --  When the Index component is No_Index, this means the iterator
      --  object was constructed without a start expression, in which case the
      --  (reverse) iteration starts from the (logical) beginning of the entire
      --  sequence (corresponding to Container.Last, for a reverse iterator).

      --  Otherwise, this is iteration over a partial sequence of items.
      --  When the Index component is not No_Index, the iterator object was
      --  constructed with a start expression, that specifies the position
      --  from which the (reverse) partial iteration begins.

      if Object.Index = No_Index then
         return Last (Object.Container.all);
      else
         return Cursor'(Object.Container, Object.Index);
      end if;
   end Last;

   ------------------
   -- Last_Element --
   ------------------

   function Last_Element (Container : Vector) return Element_Type is
   begin
      return Container.Elements.EA (Container.Last);
   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
   begin
      pragma Assert (Index_Type'First = 1);
      return Count_Type (Container.Last);
   end Length;

   ----------
   -- Move --
   ----------

   procedure Move (Target : in out Vector; Source : in out Vector) is
   begin
      if Target'Address = Source'Address then
         return;
      end if;

      declare
         Target_Elements : constant Elements_Access := Target.Elements;
      begin
         Target.Elements := Source.Elements;
         Source.Elements := Target_Elements;
      end;

      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;
      elsif Position.Index < Position.Container.Last then
         return (Position.Container, Position.Index + 1);
      else
         return No_Element;
      end if;
   end Next;

   function Next (Object : Iterator; Position : Cursor) return Cursor is
      pragma Unreferenced (Object);
   begin
      if Position.Container = null then
         return No_Element;
      end if;

      return Next (Position);
   end Next;

   procedure Next (Position : in out Cursor) is
   begin
      if Position.Container = null then
         return;
      elsif Position.Index < Position.Container.Last then
         Position.Index := Position.Index + 1;
      else
         Position := No_Element;
      end if;
   end Next;

   --------------
   -- Previous --
   --------------

   function Previous (Position : Cursor) return Cursor is
   begin
      if Position.Container = null then
         return No_Element;
      elsif Position.Index > Index_Type'First then
         return (Position.Container, Position.Index - 1);
      else
         return No_Element;
      end if;
   end Previous;

   function Previous (Object : Iterator; Position : Cursor) return Cursor is
      pragma Unreferenced (Object);
   begin
      if Position.Container = null then
         return No_Element;
      end if;

      return Previous (Position);
   end Previous;

   procedure Previous (Position : in out Cursor) is
   begin
      if Position.Container = null then
         return;
      elsif Position.Index > Index_Type'First then
         Position.Index := Position.Index - 1;
      else
         Position := No_Element;
      end if;
   end Previous;

   ---------------
   -- Reference --
   ---------------

   function Reference
     (Container : aliased in out Vector; Position : Cursor)
      return Reference_Type
   is
   begin
      return R : constant Reference_Type :=
        (Element =>
           Container.Elements.EA (Position.Index)'Unrestricted_Access);
   end Reference;

   function Reference
     (Container : aliased in out Vector; Index : Index_Type)
      return Reference_Type
   is
   begin
      pragma Assert (Index in 1 .. Last_Index (Container));
      return R : constant Reference_Type :=
        (Element => Container.Elements.EA (Index)'Unrestricted_Access);
   end Reference;

   ---------------------
   -- Reverse_Iterate --
   ---------------------

   procedure Reverse_Iterate
     (Container : Vector;
      Process   : not null access procedure (Position : Cursor))
   is
   begin
      for Indx in reverse Index_Type'First .. Container.Last loop
         Process (Cursor'(Container'Unrestricted_Access, Indx));
      end loop;
   end Reverse_Iterate;

   ----------------
   -- Set_Length --
   ----------------

   procedure Set_Length (Container : in out Vector; Length : Count_Type) is
      New_Last : constant Index_Type := Index_Type (Length);
      pragma Assert (Index_Type'First = 1);
      New_Elts : Elements_Access;
   begin
      if Container.Elements = Empty_Elements'Access then
         pragma Assert (Container.Last = 0);
         New_Elts           := new Elements_Type (Last => New_Last);
         Container.Elements := New_Elts;
      elsif New_Last > Container.Elements.Last then
         New_Elts := new Elements_Type (Last => New_Last);
         New_Elts.EA (1 .. Container.Last) :=
           Container.Elements.EA (1 .. Container.Last);
         Free (Container.Elements);
         Container.Elements := New_Elts;
      end if;

      Container.Last := New_Last;
   end Set_Length;

   ---------------
   -- 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;
      else
         return (Container'Unrestricted_Access, Index);
      end if;
   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;

   --  Extra operations not in Ada.Containers.Vectors:

   function Slice
     (Container : Vector; First : Index_Type; Last : Extended_Index)
      return Elements_Array
   is

      Jj : Extended_Index          := Index_Type'First;
      L  : constant Extended_Index :=
        (if Last < First then Jj - 1 else Last - First + Index_Type'First);
   --  Handle super-null slices properly

   begin
      return Result : Elements_Array (Index_Type'First .. L) do
         for J in First .. Last loop
            Result (Jj) := Elems (Container) (J);
            Jj          := Jj + 1;
         end loop;
         pragma Assert (Jj = Result'Last + 1);
      end return;
   end Slice;

   function To_Array (Container : Vector) return Elements_Array is
   begin
      return Elems (Container) (1 .. Container.Last);
   end To_Array;

   procedure Append (Container : in out Vector; New_Items : Elements_Array) is
      --  Straightforward code would be:
      --     for X of A loop
      --        Append (Container, X);
      --     end loop;
      --  The following is for efficiency.

      New_Last : constant Index_Type := Container.Last + New_Items'Length;
      pragma Assert (Index_Type'First = 1);
      New_Elts : Elements_Access;
   begin
      if Container.Elements = Empty_Elements'Access then
         pragma Assert (Container.Last = 0);
         New_Elts           :=
           new Elements_Type (Last => Index_Type'Max (New_Last, 2**10));
         Container.Elements := New_Elts;
      elsif New_Last > Container.Elements.Last then
         New_Elts                          :=
           new Elements_Type
             (Last => Index_Type'Max (New_Last, 2 * Container.Last));
         New_Elts.EA (1 .. Container.Last) := Container.Elements.EA;
         Free (Container.Elements);
         Container.Elements := New_Elts;
      end if;

      Container.Elements.EA (Container.Last + 1 .. New_Last) := New_Items;
      Container.Last                                         := New_Last;
   end Append;

   procedure Put
     (Container   : Vector;
      Put         : not null access procedure (Item : Element_Type);
      Put_Between : not null access procedure)
   is
      First_Time : Boolean := True;
   begin
      for X of Container loop
         if First_Time then
            First_Time := False;
            Put_Between.all;
         end if;

         Put (X);
      end loop;
   end Put;

end Utils.Fast_Vectors;