path: root/gcc/testsuite/ada/acats-4/support/f458a00.a

-- F458A00.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. These rights include rights to use, duplicate,
--     release or disclose the released technical data and computer software
--     in whole or in part, in any manner and for any purpose whatsoever, and
--     to have or permit others to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
--
-- FOUNDATION DESCRIPTION:
--     This foundation provides a number of arrays of reals with default
--     component values. We assume that the default values are necessary to
--     ensure an expected initial condition.

-- CHANGE HISTORY:
--     08 May 2022   BJM   Extended foundation for 4.5.8 tests.
--     29 Jun 2022   RLB   Copied foundation to follow naming conventions.
--     30 Jun 2022   RLB   Commented out Ada 2022 feature.

with Ada.Iterator_Interfaces;
with Ada.Strings.Unbounded; use Ada;

generic

   type Sparse_Array_Index is range <>;

   type Element_Type is private;

package F458A00_Sparse_Arrays is

   --  This package defines an iterable container that is a sparse array.
   --  A sparse array has elements that can have large gaps beteen each
   --  element. For instance an array from 1 .. 1000000 might only have a
   --  dozen real elements in the array. This sparse array implementation does
   --  not maintain elements in sorted order by index. Each element in the
   --  array actually has two indexes. One index is the "virtual" index
   --  specified by the Append cal, and the other is a storage index, which
   --  effectively is an index to the other index that represents the
   --  internal storage index where the element can be found. It is possible
   --  to iterate through the container using either index type.

   type Count_Type is range 0 .. 2 ** 31 - 1;
   subtype Storage_Index is Count_Type;
   --  Indicates the physical internal index of the element

   type Sparse_Array (Max_Elements : Count_Type) is tagged private
    with   Constant_Indexing => Constant_Reference,
           Variable_Indexing => Reference,
           Default_Iterator  => Iterate,
           Iterator_Element  => Element_Type;
           --Aggregate         => (Empty          => Empty,
           --                      Add_Named      => Append);

   function Empty (Max_Elements : Count_Type) return Sparse_Array
     with Post => Empty'Result.Length = 0;

   procedure Append
     (Container : in out Sparse_Array;
      Index     : Sparse_Array_Index;
      New_Item  : Element_Type) with
     Pre =>
       Container.Length < Container.Max_Elements and then
       not Has_Element (Container, Index) and then
       Index /= Sparse_Array_Index'Base'First,
       Post =>
         Container.Length = Container'Old.Length + 1 and then
         Container.Last_Element = New_Item; 
   --  Duplicate indexes are not allowed.

   function Length (Container : Sparse_Array) return Count_Type;
   --  Returns the number of real elements in the array

   type Cursor is private;

   No_Element : constant Cursor;
   --  No_Element represents a cursor that designates no element.
   
   No_Index   : constant Sparse_Array_Index'Base :=
     Sparse_Array_Index'Base'First;
   --  No_Index represents an index that designates no element

   function Has_Element (Position : Cursor) return Boolean;

   function Has_Element
     (Container : Sparse_Array;
      Index     : Sparse_Array_Index)
      return      Boolean;

   function Element (Container : Sparse_Array;
                     Index     : Storage_Index) return Element_Type;

   function Index_Of (Position : Cursor) return Sparse_Array_Index;
   --  Returns the array index assosiated with Position.
   
   function Storage_Index_Of (Position : Cursor) return Storage_Index;
   --  Returns the physical storage index associated with Position
      
   function Index_Of (Container : Sparse_Array;
                      Index     : Storage_Index) return Sparse_Array_Index;

   function Cursor_Of (Container : Sparse_Array;
                       Index : Sparse_Array_Index) return Cursor;

   function Cursor_Of (Container : Sparse_Array;
                       Index : Storage_Index) return Cursor;

   package Sparse_Array_Iterator_Interfaces is new Ada.Iterator_Interfaces (
      Cursor,
      Has_Element);

   function Iterate
     (Container : aliased Sparse_Array)
      return      Sparse_Array_Iterator_Interfaces.Reversible_Iterator'Class;

   type Constant_Reference_Type
     (Element : not null access constant Element_Type) is private
     with Implicit_Dereference => Element;

   type Reference_Type (Element : not null access Element_Type) is private
     with Implicit_Dereference => Element;

   function Constant_Reference
     (Container : aliased Sparse_Array;
      Position  : Cursor) return Constant_Reference_Type;

   function Reference
     (Container : aliased in out Sparse_Array;
      Position  : Cursor) return Reference_Type;

   function Constant_Reference
     (Container : aliased Sparse_Array;
      Index     : Sparse_Array_Index) return Constant_Reference_Type;

   function Reference
     (Container : aliased in out Sparse_Array;
      Index     : Sparse_Array_Index) return Reference_Type;

   function First_Index (Container : Sparse_Array)
                         return Sparse_Array_Index'Base;
   --  If Container is empty, First_Index returns No_Index. Otherwise, it
   --  returns an index that designates the first element in Container.

   function First (Container : Sparse_Array) return Cursor;
   --  If Container is empty, First returns No_Element. Otherwise, it returns a
   --  cursor that designates the first element in Container.

   function First_Element (Container : Sparse_Array) return Element_Type
     with Pre => Container.Length > 0;
   --  Equivalent to Element (Container, First_Index (Container)).

   function Last_Index (Container : Sparse_Array)
                        return Sparse_Array_Index'Base;
   --  If Container is empty, Last_Index returns No_Index. Otherwise, it
   --  returns the position of the last element in Container.

   function Last (Container : Sparse_Array) return Cursor;
   --  If Container is empty, Last returns No_Element. Otherwise, it returns a
   --  cursor that designates the last element in Container.

   function Last_Element (Container : Sparse_Array) return Element_Type
     with Pre => Container.Length > 0;
   --  Equivalent to Element (Container, Last_Index (Container)).

   function Next (Position : Cursor) return Cursor;
   --  If Position equals No_Element or designates the last element of the
   --  container, then Next returns the value No_Element. Otherwise, it returns
   --  a cursor that designates the element with index To_Index (Position) + 1
   --  in the same vector as Position.

   function Next_Index (Container : Sparse_Array;
                        Index     : Sparse_Array_Index)
                        return Sparse_Array_Index'Base;
   --  If Index equals No_Index or designates the last element of the
   --  container, then Next_Index returns the value No_Index. Otherwise, it
   --  returns an index that designates the element with index + 1
   --  in the same array as Index.

   function Previous (Position : Cursor) return Cursor;
   --  If Position equals No_Element or designates the first element of the
   --  container, then Previous returns the value No_Element. Otherwise, it
   --  returns a cursor that designates the element with index To_Index
   --  (Position) - 1 in the same array as Position.

   function Previous_Index (Container : Sparse_Array;
                            Index     : Sparse_Array_Index)
                            return Sparse_Array_Index'Base;
   --  If Index equals No_Index or designates the first element of the
   --  container, then Previous_Index returns the value No_Index. Otherwise, it
   --  returns an index that designates the element with storage index - 1 in
   --  the same array as Index.

   TC_Call_History : Strings.Unbounded.Unbounded_String;
   --
   --  A string capturing the call sequence to the above subprogams.
   --  The following gets appended to the history for the above calls;
   --      Iterate  => I
   --      First    => 1
   --      Next     => N( nn)        where nn is the physical index of the
   --                                   next element
   --      Last     => L
   --      Previous => P( nn)        where nn is the physical index of the
   --                                   next element
   --      Has_Element => H:{T|F}( nn)  H is the Has_Element function
   --                                     T means Has_Element returned True
   --                                     F means Has_Element returns False
   --                                      nn is the physical index

   TC_Constant_Indexing_Use_Count : Natural := 0;
   TC_Variable_Indexing_Use_Count : Natural := 0;

private

   type Sparse_Array_Element is
   record
      Index : Sparse_Array_Index;
      --  The real index associated with the value

      Value : aliased Element_Type;
   end record;

   type Data_Array is
     array (Count_Type range <>) of Sparse_Array_Element;

   type Sparse_Array (Max_Elements : Count_Type) is tagged
   record
      Data : Data_Array (1 .. Max_Elements) := (others => (Index => <>,
                                                           Value => <>));
      Count : Count_Type := 0;
   end record;

   function Length (Container : Sparse_Array) return Count_Type is
     (Container.Count);

   type Sparse_Array_Access is access constant Sparse_Array;
   for Sparse_Array_Access'Storage_Size use 0;

   type Cursor is
   record
      Index : Count_Type;
      Container : Sparse_Array_Access;
   end record;

   function Index_Of (Position : Cursor) return Sparse_Array_Index is
      (Position.Container.all.Data (Position.Index).Index);

   function Index_Of (Container : Sparse_Array;
                      Index : Storage_Index) return Sparse_Array_Index is
      (Container.Data (Index).Index);

   function Storage_Index_Of (Position : Cursor) return Storage_Index is
      (Position.Index);

   function Element (Container : Sparse_Array;
                     Index     : Storage_Index) return Element_Type is
      (Container.Data (Index).Value);

   function Cursor_Of (Container : Sparse_Array;
                       Index : Storage_Index) return Cursor is
     (Container => Container'Unchecked_Access,
      Index => Index);

   No_Element : constant Cursor := (Index => 0, Container => null);

   type Constant_Reference_Type
      (Element : not null access constant Element_Type) is null record;

   type Reference_Type (Element : not null access Element_Type)
     is null record;

end F458A00_Sparse_Arrays;


package body F458A00_Sparse_Arrays is

   Disable_History : Boolean := False;

   procedure Append
     (Container : in out Sparse_Array;
      Index     : Sparse_Array_Index;
      New_Item  : Element_Type)
   is
   begin
      Container.Count                  := Container.Count + 1;
      Container.Data (Container.Count) := (Index => Index, Value => New_Item);
   end Append;

   function Empty (Max_Elements : Count_Type) return Sparse_Array is
   begin
      return Empty_Array : Sparse_Array (Max_Elements);
   end Empty;

   function Has_Element (Position : Cursor) return Boolean is
      Found : constant Boolean :=
        (Position.Container /= null
        and then Position.Index > 0
        and then Position.Index <= Position.Container.all.Count);
   begin
      if not Disable_History then
         Ada.Strings.Unbounded.Append
           (Source   => TC_Call_History,
            New_Item => "H:" &
                        (if Found then "T(" else "F(") &
                        Count_Type'Image (Position.Index) &
                        ')');
      end if;

      return Found;
   end Has_Element;

   function Has_Element
     (Container : Sparse_Array;
      Index     : Sparse_Array_Index)
      return      Boolean
   is
   begin
      return (for some Item in Container.Data'Range =>
                   Container.Data (Item).Index = Index);
   end Has_Element;

   type Iterator is new
     Sparse_Array_Iterator_Interfaces.Reversible_Iterator with
      record
         Index     : Count_Type;
         Container : Sparse_Array_Access;
      end record;

   overriding function First
     (Object : Iterator) return Cursor;

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

   overriding function Last
     (Object : Iterator) return Cursor;

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

   overriding function First
     (Object : Iterator) return Cursor is
   begin
      Ada.Strings.Unbounded.Append (Source   => TC_Call_History,
                                    New_Item => '1');

      return (Index => 1,
              Container => Object.Container);
   end First;

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

      Ada.Strings.Unbounded.Append
        (Source   => TC_Call_History,
         New_Item => "N(" & Count_Type'Image (Position.Index + 1) & ')');

      return (Index => Position.Index + 1,
              Container => Object.Container);
   end Next;

   overriding function Last
     (Object : Iterator) return Cursor is
   begin
      Ada.Strings.Unbounded.Append (Source   => TC_Call_History,
                                    New_Item => 'L');

      return (Index => Object.Container.all.Count,
              Container => Object.Container);
   end Last;

   overriding function Previous
     (Object   : Iterator;
      Position : Cursor) return Cursor is
   begin
      Ada.Strings.Unbounded.Append
        (Source   => TC_Call_History,
         New_Item => "P(" & Count_Type'Image (Position.Index - 1) & ')');

      return (Index => Position.Index - 1,
              Container => Object.Container);
   end Previous;

   function Iterate
     (Container : aliased Sparse_Array)
      return
       Sparse_Array_Iterator_Interfaces.Reversible_Iterator'Class is
   begin
      Ada.Strings.Unbounded.Append (Source   => TC_Call_History,
                                    New_Item => 'I');
      return Iterator'(Index => 0,
                       Container => Container'Unchecked_Access);
   end Iterate;

   function Constant_Reference
     (Container : aliased Sparse_Array;
      Position  : Cursor) return Constant_Reference_Type is
   begin
      Disable_History := True;
      TC_Constant_Indexing_Use_Count := TC_Constant_Indexing_Use_Count + 1;

      if Position.Container = null then
         raise Constraint_Error with "Position is invalid";
      elsif not Position.Container.all'Overlaps_Storage (Container) then
         raise Program_Error with
         "Position denotes a different container";
      elsif Position.Index = 0 or else Position.Index > Container.Count then
         raise Constraint_Error with "Position is out of range";
      elsif not Has_Element (Position) then
         raise Constraint_Error with "Position does not exist";
      end if;

      Disable_History := False;

      return (Element => Container.Data (Position.Index).Value'Access);

   end Constant_Reference;

   function Constant_Reference
     (Container : aliased Sparse_Array;
      Index     : Sparse_Array_Index) return Constant_Reference_Type
   is
     (Container.Constant_Reference (Container.Cursor_Of (Index)));   

   function Cursor_Of (Container : Sparse_Array;
                       Index : Sparse_Array_Index) return Cursor is
   begin
   
      for I in 1 .. Container.Count loop
         if Container.Data (I).Index = Index then
            return Cursor'(Index     => I,
                           Container => Container'Unchecked_Access);
         end if;         
      end loop;
      
      return No_Element;
      
   end Cursor_Of;

   function Reference
     (Container : aliased in out Sparse_Array;
      Position  : Cursor) return Reference_Type is
   begin
      Disable_History := True;
      TC_Variable_Indexing_Use_Count := TC_Variable_Indexing_Use_Count + 1;

      if Position.Container = null then
         raise Constraint_Error with "Position is invalid";
      elsif not Position.Container.all'Overlaps_Storage (Container) then
         raise Program_Error with
           "Position denotes a different container";
      elsif not Has_Element (Position) then
         raise Constraint_Error with "Position does not exist";
      end if;

      Disable_History := False;

      return (Element => Container.Data (Position.Index).Value'Access);

   end Reference;

   function Reference
     (Container : aliased in out Sparse_Array;
      Index  : Sparse_Array_Index) return Reference_Type
   is
     (Container.Reference (Container.Cursor_Of (Index)));

   function First_Index (Container : Sparse_Array)
                         return Sparse_Array_Index'Base
     is (if Container.Count >= 1 then Container.Data (1).Index else No_Index);

   function First (Container : Sparse_Array) return Cursor is
     (if Container.Count >= 1 then
        (Index => 1,
         Container => Container'Unchecked_Access)
      else No_Element);

   function First_Element (Container : Sparse_Array) return Element_Type
     is (Container.Data (1).Value);
   --  Equivalent to Element (Container, First_Index (Container)).

   function Last_Index (Container : Sparse_Array)
                        return Sparse_Array_Index'Base
   is (if Container.Count >= 1 then
          Container.Data (Container.Count).Index else No_Index);
   --  If Container is empty, Last_Index returns No_Index. Otherwise, it
   --  returns the position of the last element in Container.

   function Last (Container : Sparse_Array) return Cursor is
     (if Container.Count >= 1 then
        (Index => Container.Count,
         Container => Container'Unchecked_Access)
      else No_Element);
   --  If Container is empty, Last returns No_Element. Otherwise, it returns a
   --  cursor that designates the last element in Container.

   function Last_Element (Container : Sparse_Array) return Element_Type is
      (Container.Data (Container.Count).Value);
   --  Equivalent to Element (Container, Last_Index (Container)).

   function Next (Position : Cursor) return Cursor is
     (if Position = No_Element
      or else Position.Index = Position.Container.Count
      then No_Element else (Position.Index + 1, Position.Container));
   --  If Position equals No_Element or designates the last element of the
   --  container, then Next returns the value No_Element. Otherwise, it returns
   --  a cursor that designates the element with index To_Index (Position) + 1
   --  in the same vector as Position.

   function Next_Index (Container : Sparse_Array;
                        Index : Sparse_Array_Index)
                        return Sparse_Array_Index'Base is
      Position : constant Cursor := Container.Cursor_Of (Index);
   begin
      return
         (if Position = No_Element or else Position.Index = Container.Count
          then No_Index else Container.Data (Position.Index + 1).Index);
   end Next_Index;
   

   function Previous (Position : Cursor) return Cursor is
      (if Position = No_Element
          or else Position.Index = 1
          then No_Element else (Position.Index - 1, Position.Container));


   function Previous_Index (Container : Sparse_Array;
                            Index : Sparse_Array_Index)
                            return Sparse_Array_Index'Base is
      Position : constant Cursor := Container.Cursor_Of (Index);
   begin
      return (if Position = No_Element or else Position.Index = 1
              then No_Index else Container.Data (Position.Index - 1).Index);
   end Previous_Index;
   
end F458A00_Sparse_Arrays;