gcc/testsuite/gnat.dg/array33.adb

--  { dg-do run }

procedure Array33 is
  generic
    type Item_T is private; -- The type of which the interval is made of.
    type Bound_T is private;
    None_Bound : Bound_T;
    Bounds_Are_Static : Boolean := False;
    type Value_T is private;
    type Base_Index_T is range <>;
  package General_Interval_Partition_G is
    subtype Length_T is Base_Index_T range 0 .. Base_Index_T'Last;
    subtype Index_T  is Base_Index_T range 1 .. Base_Index_T'Last;
    type T is private;
    function Single (First, Last : Bound_T; Value : Value_T) return T;
    function Single1 (First, Last : Bound_T; Value : Value_T) return T;
  private
    type Bounds_Array_T is array (Length_T range <>) of Bound_T;
    type Values_Array_T is array (Index_T  range <>) of Value_T;

    First_Bounds_Index : constant Length_T
        := 2 * Boolean'Pos (Bounds_Are_Static);
    -- See below explanation on indexing the bounds.


    type Obj_T (Length : Length_T) is
      record
        Bounds : Bounds_Array_T (First_Bounds_Index .. Length)
           := (others => None_Bound);
        -- This is tricky. If Bounds_Are_Static is true, the array does not
        --  store the lower or upper bound.
        -- This lowers memory requirements for the data structure at the cost
        --  of slightly more complex indexing.
        --
        -- Bounds as seen internally depending on the parameter:
        --
        -- Bounds_Are_Static | Lower_Bound | Inbetween Bounds (if any) | Upper_Bound
        --     True         => Max_First   & Bounds (2 .. Length)      & Min_Last
        --     False        => Bounds (0)  & Bounds (1 .. Length - 1)  & Bounds (Length)
        --
        Values : Values_Array_T (1 .. Length);
      end record;

    type T is access Obj_T;
    --@@ if ccf:defined(debug_pool) then
    --@@! for T'Storage_Pool use Pool_Selection_T'Storage_Pool;
    --@@ end if

  end General_Interval_Partition_G;

  package body General_Interval_Partition_G is

    function Single (First, Last : Bound_T; Value : Value_T) return T is
    begin
      return new Obj_T'(Length => 1,
                        Bounds => (if Bounds_Are_Static
                                   then (2 .. 0 => None_Bound) 
                --  Now raises constraint error here
                                   else (0 => First, 1 => Last)),
                        Values => (1 => Value));
    end Single;
    function Single1 (First, Last : Bound_T; Value : Value_T) return T is
    begin
      return new Obj_T'( 1,
                         (if Bounds_Are_Static
                                   then (2 .. 0 => None_Bound) 
                --  Now raises constraint error here
                                   else (0 => First, 1 => Last)),
                        (1 => Value));
    end Single1;
  end General_Interval_Partition_G;

  type T is new Integer;

  package Partition is new General_Interval_Partition_G (Item_T            => T,
                                                         Bound_T           => T,
                                                         None_Bound        => 0,
                                                         Bounds_Are_Static => True,
                                                         Value_T           => T,
                                                         Base_Index_T      => Natural);
  X : constant Partition.T := Partition.Single (1,1,1);
  Z : constant Partition.T := Partition.Single1 (1,1,1);
begin
  null;
end;