gcc/testsuite/gnat.dg/array33.adb

   1 --  { dg-do run }
   2
   3 procedure Array33 is
   4   generic
   5     type Item_T is private; -- The type of which the interval is made of.
   6     type Bound_T is private;
   7     None_Bound : Bound_T;
   8     Bounds_Are_Static : Boolean := False;
   9     type Value_T is private;
  10     type Base_Index_T is range <>;
  11   package General_Interval_Partition_G is
  12     subtype Length_T is Base_Index_T range 0 .. Base_Index_T'Last;
  13     subtype Index_T  is Base_Index_T range 1 .. Base_Index_T'Last;
  14     type T is private;
  15     function Single (First, Last : Bound_T; Value : Value_T) return T;
  16     function Single1 (First, Last : Bound_T; Value : Value_T) return T;
  17   private
  18     type Bounds_Array_T is array (Length_T range <>) of Bound_T;
  19     type Values_Array_T is array (Index_T  range <>) of Value_T;
  20
  21     First_Bounds_Index : constant Length_T
  22         := 2 * Boolean'Pos (Bounds_Are_Static);
  23     -- See below explanation on indexing the bounds.
  24
  25
  26     type Obj_T (Length : Length_T) is
  27       record
  28         Bounds : Bounds_Array_T (First_Bounds_Index .. Length)
  29            := (others => None_Bound);
  30         -- This is tricky. If Bounds_Are_Static is true, the array does not
  31         --  store the lower or upper bound.
  32         -- This lowers memory requirements for the data structure at the cost
  33         --  of slightly more complex indexing.
  34         --
  35         -- Bounds as seen internally depending on the parameter:
  36         --
  37         -- Bounds_Are_Static | Lower_Bound | Inbetween Bounds (if any) | Upper_Bound
  38         --     True         => Max_First   & Bounds (2 .. Length)      & Min_Last
  39         --     False        => Bounds (0)  & Bounds (1 .. Length - 1)  & Bounds (Length)
  40         --
  41         Values : Values_Array_T (1 .. Length);
  42       end record;
  43
  44     type T is access Obj_T;
  45     --@@ if ccf:defined(debug_pool) then
  46     --@@! for T'Storage_Pool use Pool_Selection_T'Storage_Pool;
  47     --@@ end if
  48
  49   end General_Interval_Partition_G;
  50
  51   package body General_Interval_Partition_G is
  52
  53     function Single (First, Last : Bound_T; Value : Value_T) return T is
  54     begin
  55       return new Obj_T'(Length => 1,
  56                         Bounds => (if Bounds_Are_Static
  57                                    then (2 .. 0 => None_Bound)
  58                 --  Now raises constraint error here
  59                                    else (0 => First, 1 => Last)),
  60                         Values => (1 => Value));
  61     end Single;
  62     function Single1 (First, Last : Bound_T; Value : Value_T) return T is
  63     begin
  64       return new Obj_T'( 1,
  65                          (if Bounds_Are_Static
  66                                    then (2 .. 0 => None_Bound)
  67                 --  Now raises constraint error here
  68                                    else (0 => First, 1 => Last)),
  69                         (1 => Value));
  70     end Single1;
  71   end General_Interval_Partition_G;
  72
  73   type T is new Integer;
  74
  75   package Partition is new General_Interval_Partition_G (Item_T            => T,
  76                                                          Bound_T           => T,
  77                                                          None_Bound        => 0,
  78                                                          Bounds_Are_Static => True,
  79                                                          Value_T           => T,
  80                                                          Base_Index_T      => Natural);
  81   X : constant Partition.T := Partition.Single (1,1,1);
  82   Z : constant Partition.T := Partition.Single1 (1,1,1);
  83 begin
  84   null;
  85 end;