1-- { dg-do run } 2 3procedure 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); 83begin 84 null; 85end; 86