-- Check that list is sorted, lacks null intervals, and has gaps
-- between intervals.
+ function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
+ -- Given an element of a Discrete_Choices list, a
+ -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
+ -- list (but not an N_Others_Choice node) return the corresponding
+ -- interval. If an element that does not represent a single
+ -- contiguous interval due to a static predicate (or which
+ -- represents a single contiguous interval whose bounds depend on
+ -- a static predicate) is encountered, then that is an error on the
+ -- part of whoever built the list in question.
+
function In_Interval
(Value : Uint; Interval : Discrete_Interval) return Boolean;
-- Does the given value lie within the given interval?
Intervals : Discrete_Interval_List (1 .. Max_I);
Num_I : Nat := 0;
+ -- Start of processing for Aggregate_Intervals
+
begin
-- No action needed if there are no intervals
end;
end Aggregate_Intervals;
- -----------------
- -- In_Interval --
- -----------------
- function In_Interval
- (Value : Uint; Interval : Discrete_Interval) return Boolean is
- begin
- return Value >= Interval.Low and then Value <= Interval.High;
- end In_Interval;
-
------------------------
-- Check_Consistency --
------------------------
+
procedure Check_Consistency (Intervals : Discrete_Interval_List) is
begin
if Serious_Errors_Detected > 0 then
end loop;
end Check_Consistency;
- function Chosen_Interval (Choice : Node_Id) return Discrete_Interval;
- -- Given an element of a Discrete_Choices list, a
- -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
- -- list (but not an N_Others_Choice node) return the corresponding
- -- interval. If an element that does not represent a single
- -- contiguous interval due to a static predicate (or which
- -- represents a single contiguous interval whose bounds depend on
- -- a static predicate) is encountered, then that is an error on the
- -- part of whoever built the list in question.
+ ---------------------------
+ -- Choice_List_Intervals --
+ ---------------------------
+
+ function Choice_List_Intervals
+ (Discrete_Choices : List_Id) return Discrete_Interval_List
+ is
+ function Unmerged_Choice_Count return Nat;
+ -- The number of intervals before adjacent intervals are merged.
+
+ ---------------------------
+ -- Unmerged_Choice_Count --
+ ---------------------------
+
+ function Unmerged_Choice_Count return Nat is
+ Choice : Node_Id := First (Discrete_Choices);
+ Count : Nat := 0;
+ begin
+ while Present (Choice) loop
+ -- Non-contiguous choices involving static predicates
+ -- have already been normalized away.
+
+ if Nkind (Choice) = N_Others_Choice then
+ Count :=
+ Count + List_Length (Others_Discrete_Choices (Choice));
+ else
+ Count := Count + 1; -- an ordinary expression or range
+ end if;
+
+ Next (Choice);
+ end loop;
+ return Count;
+ end Unmerged_Choice_Count;
+
+ -- Local variables
+
+ Choice : Node_Id := First (Discrete_Choices);
+ Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
+ Count : Nat := 0;
+
+ -- Start of processing for Choice_List_Intervals
+
+ begin
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ declare
+ Others_Choice : Node_Id
+ := First (Others_Discrete_Choices (Choice));
+ begin
+ while Present (Others_Choice) loop
+ Count := Count + 1;
+ Result (Count) := Chosen_Interval (Others_Choice);
+ Next (Others_Choice);
+ end loop;
+ end;
+ else
+ Count := Count + 1;
+ Result (Count) := Chosen_Interval (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ pragma Assert (Count = Result'Last);
+ Normalize_Interval_List (Result, Count);
+ Check_Consistency (Result (1 .. Count));
+ return Result (1 .. Count);
+ end Choice_List_Intervals;
---------------------
-- Chosen_Interval --
---------------------
+
function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is
begin
case Nkind (Choice) is
end case;
end Chosen_Interval;
- --------------------
- -- Type_Intervals --
- --------------------
- function Type_Intervals
- (Typ : Entity_Id) return Discrete_Interval_List
+ -----------------
+ -- In_Interval --
+ -----------------
+
+ function In_Interval
+ (Value : Uint; Interval : Discrete_Interval) return Boolean is
+ begin
+ return Value >= Interval.Low and then Value <= Interval.High;
+ end In_Interval;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Subset, Of_Set : Discrete_Interval_List) return Boolean
is
+ -- Returns True iff for each interval of Subset we can find
+ -- a single interval of Of_Set which contains the Subset interval.
begin
- if Has_Static_Predicate (Typ) then
- declare
- -- No sorting or merging needed
- SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
- Range_Or_Expr : Node_Id := First (SDP_List);
- Result :
- Discrete_Interval_List (1 .. List_Length (SDP_List));
- begin
- for Idx in Result'Range loop
- Result (Idx) := Chosen_Interval (Range_Or_Expr);
- Next (Range_Or_Expr);
+ if Of_Set'Length = 0 then
+ return Subset'Length = 0;
+ end if;
+
+ declare
+ Set_Index : Pos range Of_Set'Range := Of_Set'First;
+
+ begin
+ for Ss_Idx in Subset'Range loop
+ while not In_Interval
+ (Value => Subset (Ss_Idx).Low,
+ Interval => Of_Set (Set_Index))
+ loop
+ if Set_Index = Of_Set'Last then
+ return False;
+ end if;
+
+ Set_Index := Set_Index + 1;
end loop;
- pragma Assert (not Present (Range_Or_Expr));
- Check_Consistency (Result);
- return Result;
- end;
- else
- declare
- Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
- High : constant Uint := Expr_Value (Type_High_Bound (Typ));
- begin
- if Low > High then
- declare
- Null_Array : Discrete_Interval_List (1 .. 0);
- begin
- return Null_Array;
- end;
- else
- return (1 => (Low => Low, High => High));
+
+ if not In_Interval
+ (Value => Subset (Ss_Idx).High,
+ Interval => Of_Set (Set_Index))
+ then
+ return False;
end if;
- end;
- end if;
- end Type_Intervals;
+ end loop;
+ end;
+
+ return True;
+ end Is_Subset;
-----------------------------
-- Normalize_Interval_List --
-----------------------------
+
procedure Normalize_Interval_List
- (List : in out Discrete_Interval_List; Last : out Nat) is
+ (List : in out Discrete_Interval_List; Last : out Nat)
+ is
+ Temp_0 : Discrete_Interval := (others => Uint_0);
+ -- Cope with Heap_Sort_G idiosyncrasies.
- procedure Move_Interval (From, To : Natural);
- -- Copy interval from one location to another
+ function Is_Null (Idx : Pos) return Boolean;
+ -- True iff List (Idx) defines a null range
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean;
-- Compare two list elements
- Temp_0 : Discrete_Interval := (others => Uint_0);
- -- cope with Heap_Sort_G idiosyncrasies.
+ procedure Merge_Intervals (Null_Interval_Count : out Nat);
+ -- Merge contiguous ranges by replacing one with merged range and
+ -- the other with a null value. Return a count of the null intervals,
+ -- both preexisting and those introduced by merging.
+
+ procedure Move_Interval (From, To : Natural);
+ -- Copy interval from one location to another
function Read_Interval (From : Natural) return Discrete_Interval;
-- Normal array indexing unless From = 0
- -------------------
- -- Read_Interval --
- -------------------
- function Read_Interval (From : Natural) return Discrete_Interval is
- begin
- if From = 0 then
- return Temp_0;
- else
- return List (Pos (From));
- end if;
- end Read_Interval;
+ ----------------------
+ -- Interval_Sorting --
+ ----------------------
- -------------------
- -- Move_Interval --
- -------------------
- procedure Move_Interval (From, To : Natural) is
- Rhs : constant Discrete_Interval := Read_Interval (From);
+ package Interval_Sorting is
+ new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
+
+ -------------
+ -- Is_Null --
+ -------------
+
+ function Is_Null (Idx : Pos) return Boolean is
begin
- if To = 0 then
- Temp_0 := Rhs;
- else
- List (Pos (To)) := Rhs;
- end if;
- end Move_Interval;
+ return List (Idx).Low > List (Idx).High;
+ end Is_Null;
-----------------
-- Lt_Interval --
-----------------
+
function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is
Elem1 : constant Discrete_Interval := Read_Interval (Idx1);
Elem2 : constant Discrete_Interval := Read_Interval (Idx2);
if Null_1 /= Null_2 then
-- So that sorting moves null intervals to high end
return Null_2;
+
elsif Elem1.Low /= Elem2.Low then
return Elem1.Low < Elem2.Low;
+
else
return Elem1.High < Elem2.High;
end if;
end Lt_Interval;
- package Interval_Sorting is
- new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval);
-
- function Is_Null (Idx : Pos) return Boolean;
- -- True iff List (Idx) defines a null range
-
- function Is_Null (Idx : Pos) return Boolean is
- begin
- return List (Idx).Low > List (Idx).High;
- end Is_Null;
-
- procedure Merge_Intervals (Null_Interval_Count : out Nat);
- -- Merge contiguous ranges by replacing one with merged range
- -- and the other with a null value. Return a count of the
- -- null intervals, both preexisting and those introduced by
- -- merging.
-
---------------------
-- Merge_Intervals --
---------------------
+
procedure Merge_Intervals (Null_Interval_Count : out Nat) is
Not_Null : Pos range List'Range;
-- Index of the most recently examined non-null interval
Null_Interval_Count := 0;
Not_Null := List'First;
+
for Idx in List'First + 1 .. List'Last loop
if Is_Null (Idx) then
+
-- all remaining elements are null
+
Null_Interval_Count :=
Null_Interval_Count + List (Idx .. List'Last)'Length;
return;
+
elsif List (Idx).Low = List (Not_Null).High + 1 then
+
-- Merge the two intervals into one; discard the other
+
List (Not_Null).High := List (Idx).High;
List (Idx) := Null_Interval;
Null_Interval_Count := Null_Interval_Count + 1;
+
else
if List (Idx).Low <= List (Not_Null).High then
raise Intervals_Error;
end if;
end loop;
end Merge_Intervals;
+
+ -------------------
+ -- Move_Interval --
+ -------------------
+
+ procedure Move_Interval (From, To : Natural) is
+ Rhs : constant Discrete_Interval := Read_Interval (From);
+ begin
+ if To = 0 then
+ Temp_0 := Rhs;
+ else
+ List (Pos (To)) := Rhs;
+ end if;
+ end Move_Interval;
+
+ -------------------
+ -- Read_Interval --
+ -------------------
+
+ function Read_Interval (From : Natural) return Discrete_Interval is
+ begin
+ if From = 0 then
+ return Temp_0;
+ else
+ return List (Pos (From));
+ end if;
+ end Read_Interval;
+
+ -- Start of processing for Normalize_Interval_Lists
+
begin
Interval_Sorting.Sort (Natural (List'Last));
+
declare
Null_Interval_Count : Nat;
+
begin
Merge_Intervals (Null_Interval_Count);
Last := List'Last - Null_Interval_Count;
+
if Null_Interval_Count /= 0 then
-- Move null intervals introduced during merging to high end
Interval_Sorting.Sort (Natural (List'Last));
end;
end Normalize_Interval_List;
- ---------------------------
- -- Choice_List_Intervals --
- ---------------------------
- function Choice_List_Intervals
- (Discrete_Choices : List_Id) return Discrete_Interval_List
- is
- function Unmerged_Choice_Count return Nat;
- -- The number of intervals before adjacent intervals are merged.
-
- ---------------------------
- -- Unmerged_Choice_Count --
- ---------------------------
- function Unmerged_Choice_Count return Nat is
- Choice : Node_Id := First (Discrete_Choices);
- Count : Nat := 0;
- begin
- while Present (Choice) loop
- -- Non-contiguous choices involving static predicates
- -- have already been normalized away.
-
- if Nkind (Choice) = N_Others_Choice then
- Count :=
- Count + List_Length (Others_Discrete_Choices (Choice));
- else
- Count := Count + 1; -- an ordinary expression or range
- end if;
-
- Next (Choice);
- end loop;
- return Count;
- end Unmerged_Choice_Count;
-
- Choice : Node_Id := First (Discrete_Choices);
- Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count);
- Count : Nat := 0;
- begin
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- declare
- Others_Choice : Node_Id
- := First (Others_Discrete_Choices (Choice));
- begin
- while Present (Others_Choice) loop
- Count := Count + 1;
- Result (Count) := Chosen_Interval (Others_Choice);
- Next (Others_Choice);
- end loop;
- end;
- else
- Count := Count + 1;
- Result (Count) := Chosen_Interval (Choice);
- end if;
- Next (Choice);
- end loop;
- pragma Assert (Count = Result'Last);
- Normalize_Interval_List (Result, Count);
- Check_Consistency (Result (1 .. Count));
- return Result (1 .. Count);
- end Choice_List_Intervals;
+ --------------------
+ -- Type_Intervals --
+ --------------------
- ---------------
- -- Is_Subset --
- ---------------
- function Is_Subset
- (Subset, Of_Set : Discrete_Interval_List) return Boolean
+ function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List
is
- -- Returns True iff for each interval of Subset we can find
- -- a single interval of Of_Set which contains the Subset interval.
begin
- if Of_Set'Length = 0 then
- return Subset'Length = 0;
- end if;
+ if Has_Static_Predicate (Typ) then
+ declare
+ -- No sorting or merging needed
+ SDP_List : constant List_Id := Static_Discrete_Predicate (Typ);
+ Range_Or_Expr : Node_Id := First (SDP_List);
+ Result : Discrete_Interval_List (1 .. List_Length (SDP_List));
- declare
- Set_Index : Pos range Of_Set'Range := Of_Set'First;
- begin
- for Ss_Idx in Subset'Range loop
- while not In_Interval
- (Value => Subset (Ss_Idx).Low,
- Interval => Of_Set (Set_Index))
- loop
- if Set_Index = Of_Set'Last then
- return False;
- end if;
- Set_Index := Set_Index + 1;
+ begin
+ for Idx in Result'Range loop
+ Result (Idx) := Chosen_Interval (Range_Or_Expr);
+ Next (Range_Or_Expr);
end loop;
- if not In_Interval
- (Value => Subset (Ss_Idx).High,
- Interval => Of_Set (Set_Index))
- then
- return False;
+ pragma Assert (not Present (Range_Or_Expr));
+ Check_Consistency (Result);
+ return Result;
+ end;
+ else
+ declare
+ Low : constant Uint := Expr_Value (Type_Low_Bound (Typ));
+ High : constant Uint := Expr_Value (Type_High_Bound (Typ));
+ begin
+ if Low > High then
+ declare
+ Null_Array : Discrete_Interval_List (1 .. 0);
+ begin
+ return Null_Array;
+ end;
+ else
+ return (1 => (Low => Low, High => High));
end if;
- end loop;
- end;
-
- return True;
- end Is_Subset;
+ end;
+ end if;
+ end Type_Intervals;
end Interval_Lists;
projects / gcc.git / commitdiff