===================================================================
@@ -77,10 +77,6 @@ package body Sem_Ch13 is
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
- -----------------------
- -- Local Subprograms --
- -----------------------
-
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
@@ -94,6 +90,21 @@ package body Sem_Ch13 is
-- and setting Predicate_Procedure for Typ. In some error situations no
-- procedure is built, in which case PDecl/PBody are empty on return.
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id);
+ -- Given a predicated type Typ, whose predicate expression is Expr, tests
+ -- if Expr is a static predicate, and if so, builds the predicate range
+ -- list. Nam is the name of the argument to the predicate function.
+ -- Occurrences of the type name in the predicate expression have been
+ -- replaced by identifer references to this name, which is unique, so any
+ -- identifier with Chars matching Nam must be a reference to the type. If
+ -- the predicate is non-static, this procedure returns doing nothing. If
+ -- the predicate is static, then the corresponding predicate list is stored
+ -- in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized
+ -- membership operation.
+
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
@@ -3851,10 +3862,6 @@ package body Sem_Ch13 is
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
- procedure Build_Static_Predicate;
- -- This function is called to process a static predicate, and put it in
- -- canonical form and store it in Static_Predicate (Typ).
-
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of Predicate procedure
@@ -4001,455 +4008,895 @@ package body Sem_Ch13 is
end loop;
end Add_Predicates;
- ----------------------------
- -- Build_Static_Predicate --
- ----------------------------
+ -- Start of processing for Build_Predicate_Function
+
+ begin
+ -- Initialize for construction of statement list
- procedure Build_Static_Predicate is
- Exp : Node_Id;
- Alt : Node_Id;
+ Expr := Empty;
+ FDecl := Empty;
+ FBody := Empty;
+
+ -- Return if already built or if type does not have predicates
+
+ if not Has_Predicates (Typ)
+ or else Present (Predicate_Function (Typ))
+ then
+ return;
+ end if;
+
+ -- Add Predicates for the current type
+
+ Add_Predicates;
+
+ -- Add predicates for ancestor if present
+
+ declare
+ Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ begin
+ if Present (Atyp) then
+ Add_Call (Atyp);
+ end if;
+ end;
+
+ -- If we have predicates, build the function
+
+ if Present (Expr) then
+
+ -- Deal with static predicate case
+
+ Build_Static_Predicate (Typ, Expr, Object_Name);
+
+ -- Build function declaration
+
+ pragma Assert (Has_Predicates (Typ));
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Set_Has_Predicates (SId);
+ Set_Predicate_Function (Typ, SId);
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars => Object_Name),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
+
+ -- Build function body
+
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars => Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- Non_Static : Boolean := False;
- -- Set True if something non-static is found
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
+ end if;
+ end Build_Predicate_Function;
+
+ ----------------------------
+ -- Build_Static_Predicate --
+ ----------------------------
+
+ procedure Build_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
- Plist : List_Id := No_List;
- -- The entries in Plist are either static expressions which represent
- -- a possible value, or ranges of values. Subtype marks don't appear,
- -- since we expand them out.
+ Non_Static : exception;
+ -- Raised if something non-static is found
+ TLo, THi : Uint;
+ -- Low bound and high bound values of static subtype of Typ
+
+ type REnt is record
Lo, Hi : Uint;
- -- Low bound and high bound values of static subtype of Typ
+ end record;
+ -- One entry in a Rlist value, a single REnt (range entry) value
+ -- denotes one range from Lo to Hi. To represent a single value
+ -- range Lo = Hi = value.
+
+ type RList is array (Nat range <>) of REnt;
+ -- A list of ranges. The ranges are sorted in increasing order,
+ -- and are disjoint (there is a gap of at least one value between
+ -- each range in the table).
+
+ Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+ True_Range : RList renames Null_Range;
+ -- Constant representing null list of ranges, used to represent a
+ -- predicate of True, since there are no ranges to be satisfied.
+
+ False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0));
+ -- Range representing false
+
+ function "and" (Left, Right : RList) return RList;
+ -- And's together two range lists, returning a range list. This is
+ -- a set intersection operation.
+
+ function "or" (Left, Right : RList) return RList;
+ -- Or's together two range lists, returning a range list. This is a
+ -- set union operation.
+
+ function "not" (Right : RList) return RList;
+ -- Returns complement of a given range list, i.e. a range list
+ -- representing all the values in TLo .. THi that are not in the
+ -- input operand Right.
+
+ function Build_Val (V : Uint) return Node_Id;
+ -- Return an analyzed N_Identifier node referencing this value, suitable
+ -- for use as an entry in the Static_Predicate list.
+
+ function Build_Range (Lo, Hi : Uint) return Node_Id;
+ -- Return an analyzed N_Range node referencing this range, suitable
+ -- for use as an entry in the Static_Predicate list.
+
+ function Get_RList (Exp : Node_Id) return RList;
+ -- This is a recursive routine that converts the given expression into
+ -- a list of ranges, suitable for use in building the static predicate.
+
+ function Is_Type_Ref (N : Node_Id) return Boolean;
+ pragma Inline (Is_Type_Ref);
+ -- Returns if True if N is a reference to the type for the predicate in
+ -- the expression (i.e. if it is an identifier whose Chars field matches
+ -- the Nam given in the call).
+
+ function Lo_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value or low bound of range.
+
+ function Hi_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value of high bound of range.
+
+ function Membership_Entry (N : Node_Id) return RList;
+ -- Given a single membership entry (range, value, or subtype), returns
+ -- the corresponding range list. Raises Static_Error if not static.
+
+ function Membership_Entries (N : Node_Id) return RList;
+ -- Given an element on an alternatives list of a membership operation,
+ -- returns the range list corresponding to this entry and all following
+ -- entries (i.e. returns the "or" of this list of values).
+
+ function Stat_Pred (Typ : Entity_Id) return RList;
+ -- Given a type, if it has a static predicate, then return the predicate
+ -- as a range list, otherwise raise Non_Static.
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and" (Left, Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
- procedure Process_Entry (N : Node_Id);
- -- Process one entry (range or value or subtype mark)
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
- -------------------
- -- Process_Entry --
- -------------------
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
- procedure Process_Entry (N : Node_Id) is
- SLo, SHi : Uint;
- -- Low and high bounds of range in list
+ begin
+ -- If either range is True, return the other
- P : Node_Id;
+ if Left = True_Range then
+ return Right;
+ elsif Right = True_Range then
+ return Left;
+ end if;
- function Build_Val (V : Uint) return Node_Id;
- -- Return an analyzed N_Identifier node referencing this value
+ -- If either range is False, return False
- function Build_Range (Lo, Hi : Uint) return Node_Id;
- -- Return an analyzed N_Range node referencing this range
+ if Left = False_Range or else Right = False_Range then
+ return False_Range;
+ end if;
- function Lo_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- or low bound of range.
+ -- If either range is empty, return False
- function Hi_Val (N : Node_Id) return Uint;
- -- Given static expression or static range, gets expression value
- -- of high bound of range.
+ if Left'Length = 0 or else Right'Length = 0 then
+ return False_Range;
+ end if;
- -----------------
- -- Build_Range --
- -----------------
+ -- Loop to remove entries at start that are disjoint, and thus
+ -- just get discarded from the result entirely.
- function Build_Range (Lo, Hi : Uint) return Node_Id is
- Result : Node_Id;
- begin
- if Lo = Hi then
- return Build_Val (Hi);
- else
- Result :=
- Make_Range (Sloc (N),
- Low_Bound => Build_Val (Lo),
- High_Bound => Build_Val (Hi));
- Set_Etype (Result, Typ);
- Set_Analyzed (Result);
- return Result;
- end if;
- end Build_Range;
-
- ---------------
- -- Build_Val --
- ---------------
+ loop
+ -- If no operands left in either operand, result is false
- function Build_Val (V : Uint) return Node_Id is
- Result : Node_Id;
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return False_Range;
- begin
- if Is_Enumeration_Type (Typ) then
- Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N));
- else
- Result := Make_Integer_Literal (Sloc (N), Intval => V);
- end if;
+ -- Discard first left operand entry if disjoint with right
- Set_Etype (Result, Typ);
- Set_Is_Static_Expression (Result);
- Set_Analyzed (Result);
- return Result;
- end Build_Val;
+ elsif Left (SLeft).Hi < Right (SRight).Lo then
+ SLeft := SLeft + 1;
- ------------
- -- Hi_Val --
- ------------
+ -- Discard first right operand entry if disjoint with left
- function Hi_Val (N : Node_Id) return Uint is
- begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
- else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (High_Bound (N));
- end if;
- end Hi_Val;
+ elsif Right (SRight).Hi < Left (SLeft).Lo then
+ SRight := SRight + 1;
- ------------
- -- Lo_Val --
- ------------
+ -- Otherwise we have an overlapping entry
- function Lo_Val (N : Node_Id) return Uint is
- begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
- else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (Low_Bound (N));
- end if;
- end Lo_Val;
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Now we have two non-null operands, and first entries overlap.
+ -- The first entry in the result will be the overlapping part of
+ -- these two entries.
+
+ FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
+ Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
+
+ -- Now we can remove the entry that ended at a lower value, since
+ -- its contribution is entirely contained in Fent.
+
+ if Left (SLeft).Hi <= Right (SRight).Hi then
+ SLeft := SLeft + 1;
+ else
+ SRight := SRight + 1;
+ end if;
+
+ -- If either operand is empty, that's the only entry
+
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return RList'(1 => FEnt);
+
+ -- Else compute and of remaining entries and concatenate
+
+ else
+ return
+ FEnt &
+ (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
+ end if;
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not" (Right : RList) return RList is
+ begin
+ -- Return True if False range
+
+ if Right = False_Range then
+ return True_Range;
+ end if;
- -- Start of processing for Process_Entry
+ -- Return False if True range
+
+ if Right'Length = 0 then
+ return False_Range;
+ end if;
+
+ -- Here if not trivial case
+
+ declare
+ Result : RList (1 .. Right'Length + 1);
+ -- May need one more entry for gap at beginning and end
+
+ Count : Nat := 0;
+ -- Number of entries stored in Result
begin
- -- Range case
+ -- Gap at start
- if Nkind (N) = N_Range then
- if not Is_Static_Expression (Low_Bound (N))
- or else
- not Is_Static_Expression (High_Bound (N))
+ if Right (Right'First).Lo > TLo then
+ Count := Count + 1;
+ Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
+ end if;
+
+ -- Gaps between ranges
+
+ for J in Right'First .. Right'Last - 1 loop
+ Count := Count + 1;
+ Result (Count) :=
+ REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
+ end loop;
+
+ -- Gap at end
+
+ if Right (Right'Last).Hi < THi then
+ Count := Count + 1;
+ Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
+ end if;
+
+ return Result (1 .. Count);
+ end;
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or" (Left, Right : RList) return RList is
+ begin
+ -- If either range is True, return True
+
+ if Left = True_Range or else Right = True_Range then
+ return True_Range;
+ end if;
+
+ -- If either range is False, return the other
+
+ if Left = False_Range then
+ return Right;
+ elsif Right = False_Range then
+ return Left;
+ end if;
+
+ -- If either operand is null, return the other one
+
+ if Left'Length = 0 then
+ return Right;
+ elsif Right'Length = 0 then
+ return Left;
+ end if;
+
+ -- Now we have two non-null ranges
+
+ declare
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
+
+ begin
+ -- Initialize result first entry from left or right operand
+ -- depending on which starts with the lower range.
+
+ if Left (SLeft).Lo < Right (SRight).Lo then
+ FEnt := Left (SLeft);
+ SLeft := SLeft + 1;
+ else
+ FEnt := Right (SRight);
+ SRight := SRight + 1;
+ end if;
+
+ -- This loop eats ranges from left and right operands that
+ -- are contiguous with the first range we are gathering.
+
+ loop
+ -- Eat first entry in left operand if contiguous or
+ -- overlapped by gathered first operand of result.
+
+ if SLeft <= Left'Last
+ and then Left (SLeft).Lo <= FEnt.Hi + 1
then
- Non_Static := True;
- return;
+ FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
+ SLeft := SLeft + 1;
+
+ -- Eat first entry in right operand if contiguous or
+ -- overlapped by gathered right operand of result.
+
+ elsif SRight <= Right'Last
+ and then Right (SRight).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+ SRight := SRight + 1;
+
+ -- All done if no more entries to eat!
+
else
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ exit;
end if;
+ end loop;
- -- Static expression case
+ -- If left operand now empty, concatenate our new entry to right
- elsif Is_Static_Expression (N) then
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ if SLeft > Left'Last then
+ return FEnt & Right (SRight .. Right'Last);
- -- Identifier (other than static expression) case
+ -- If right operand now empty, concatenate our new entry to left
- else pragma Assert (Nkind (N) = N_Identifier);
+ elsif SRight > Right'Last then
+ return FEnt & Left (SLeft .. Left'Last);
- -- Type case
+ -- Otherwise, compute or of what is left and concatenate
- if Is_Type (Entity (N)) then
+ else
+ return
+ FEnt &
+ (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+ end if;
+ end;
+ end "or";
- -- If type has static predicates, process them recursively
+ -----------------
+ -- Build_Range --
+ -----------------
- if Present (Static_Predicate (Entity (N))) then
- P := First (Static_Predicate (Entity (N)));
- while Present (P) loop
- Process_Entry (P);
+ function Build_Range (Lo, Hi : Uint) return Node_Id is
+ Result : Node_Id;
+ begin
+ if Lo = Hi then
+ return Build_Val (Hi);
+ else
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Lo),
+ High_Bound => Build_Val (Hi));
+ Set_Etype (Result, Typ);
+ Set_Analyzed (Result);
+ return Result;
+ end if;
+ end Build_Range;
+
+ ---------------
+ -- Build_Val --
+ ---------------
- if Non_Static then
- return;
- else
- Next (P);
- end if;
- end loop;
+ function Build_Val (V : Uint) return Node_Id is
+ Result : Node_Id;
- return;
+ begin
+ if Is_Enumeration_Type (Typ) then
+ Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
+ else
+ Result := Make_Integer_Literal (Loc, Intval => V);
+ end if;
- -- For static subtype without predicates, get range
+ Set_Etype (Result, Typ);
+ Set_Is_Static_Expression (Result);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Val;
+
+ ---------------
+ -- Get_RList --
+ ---------------
+
+ function Get_RList (Exp : Node_Id) return RList is
+ Op : Node_Kind;
+ Val : Uint;
- elsif Is_Static_Subtype (Entity (N))
- and then not Has_Predicates (Entity (N))
- then
- SLo := Expr_Value (Type_Low_Bound (Entity (N)));
- SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ begin
+ -- Static expression can only be true or false
- -- Any other type makes us non-static
+ if Is_OK_Static_Expression (Exp) then
- else
- Non_Static := True;
- return;
- end if;
+ -- For False, return impossible range, which will always fail
+
+ if Expr_Value (Exp) = 0 then
+ return False_Range;
+
+ -- For True, null range
+
+ else
+ return Null_Range;
+ end if;
+ end if;
+
+ -- Otherwise test node type
- -- Any other kind of identifier in predicate (e.g. a non-static
- -- expression value) means this is not a static predicate.
+ Op := Nkind (Exp);
+
+ case Op is
+
+ -- And
+
+ when N_Op_And | N_And_Then =>
+ return Get_RList (Left_Opnd (Exp))
+ and
+ Get_RList (Right_Opnd (Exp));
+
+ -- Or
+
+ when N_Op_Or | N_Or_Else =>
+ return Get_RList (Left_Opnd (Exp))
+ or
+ Get_RList (Right_Opnd (Exp));
+
+ -- Not
+
+ when N_Op_Not =>
+ return not Get_RList (Right_Opnd (Exp));
+
+ -- Comparisons of type with static value
+
+ when N_Op_Compare =>
+ -- Type is left operand
+
+ if Is_Type_Ref (Left_Opnd (Exp))
+ and then Is_OK_Static_Expression (Right_Opnd (Exp))
+ then
+ Val := Expr_Value (Right_Opnd (Exp));
+
+ -- Typ is right operand
+
+ elsif Is_Type_Ref (Right_Opnd (Exp))
+ and then Is_OK_Static_Expression (Left_Opnd (Exp))
+ then
+ Val := Expr_Value (Left_Opnd (Exp));
+
+ -- Invert sense of comparison
+
+ case Op is
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Ge;
+ when others => null;
+ end case;
+
+ -- Other cases are non-static
else
- Non_Static := True;
- return;
+ raise Non_Static;
end if;
- end if;
- -- Here with SLo and SHi set for (possibly single element) range
- -- of entry to insert in Plist. Non-static if out of range.
+ -- Construct range according to comparison operation
- if SLo < Lo or else SHi > Hi then
- Non_Static := True;
- return;
- end if;
+ case Op is
+ when N_Op_Eq =>
+ return RList'(1 => REnt'(Val, Val));
- -- If no Plist currently, create it
+ when N_Op_Ge =>
+ return RList'(1 => REnt'(Val, THi));
- if No (Plist) then
- Plist := New_List (Build_Range (SLo, SHi));
- return;
+ when N_Op_Gt =>
+ return RList'(1 => REnt'(Val + 1, THi));
- -- Otherwise search Plist for insertion point
+ when N_Op_Le =>
+ return RList'(1 => REnt'(TLo, Val));
- else
- P := First (Plist);
- loop
- -- Case of inserting before current entry
+ when N_Op_Lt =>
+ return RList'(1 => REnt'(TLo, Val - 1));
- if SHi < Lo_Val (P) - 1 then
- Insert_Before (P, Build_Range (SLo, SHi));
- exit;
+ when N_Op_Ne =>
+ return RList'(REnt'(TLo, Val - 1),
+ REnt'(Val + 1, THi));
+
+ when others =>
+ raise Program_Error;
+ end case;
- -- Case of belongs past current entry
+ -- Membership (IN)
- elsif SLo > Hi_Val (P) + 1 then
+ when N_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
- -- End of list case
+ if Present (Right_Opnd (Exp)) then
+ return Membership_Entry (Right_Opnd (Exp));
+ else
+ return Membership_Entries (First (Alternatives (Exp)));
+ end if;
- if No (Next (P)) then
- Append_To (Plist, Build_Range (SLo, SHi));
- exit;
+ -- Negative membership (NOT IN)
- -- Else just move to next item on list
+ when N_Not_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
- else
- Next (P);
+ if Present (Right_Opnd (Exp)) then
+ return not Membership_Entry (Right_Opnd (Exp));
+ else
+ return not Membership_Entries (First (Alternatives (Exp)));
+ end if;
+
+ -- Function call, may be call to static predicate
+
+ when N_Function_Call =>
+ if Is_Entity_Name (Name (Exp)) then
+ declare
+ Ent : constant Entity_Id := Entity (Name (Exp));
+ begin
+ if Has_Predicates (Ent) then
+ return Stat_Pred (Etype (First_Formal (Ent)));
end if;
+ end;
+ end if;
- -- Case of extending current entyr, and in overlap cases
- -- may also eat up entries past this one.
+ -- Other function call cases are non-static
- else
- declare
- New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo);
- New_Hi : Uint := UI_Max (Hi_Val (P), SHi);
+ raise Non_Static;
- begin
- -- See if there are entries past us that we eat up
+ -- Qualified expression, dig out the expression
- while Present (Next (P))
- and then Lo_Val (Next (P)) <= New_Hi + 1
- loop
- New_Hi := Hi_Val (Next (P));
- Remove (Next (P));
- end loop;
+ when N_Qualified_Expression =>
+ return Get_RList (Expression (Exp));
- -- We now need to replace the current node P with
- -- a new entry New_Lo .. New_Hi.
+ -- Any other node type is non-static
- Insert_After (P, Build_Range (New_Lo, New_Hi));
- Remove (P);
- exit;
- end;
- end if;
- end loop;
- end if;
- end Process_Entry;
+ when others =>
+ raise Non_Static;
+ end case;
+ end Get_RList;
- -- Start of processing for Build_Static_Predicate
+ ------------
+ -- Hi_Val --
+ ------------
+ function Hi_Val (N : Node_Id) return Uint is
begin
- -- Immediately non-static if our subtype is non static, or we
- -- do not have an appropriate discrete subtype in the first place.
-
- if not Ekind_In (Typ, E_Enumeration_Subtype,
- E_Modular_Integer_Subtype,
- E_Signed_Integer_Subtype)
- or else not Is_Static_Subtype (Typ)
- then
- return;
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (High_Bound (N));
end if;
+ end Hi_Val;
- Lo := Expr_Value (Type_Low_Bound (Typ));
- Hi := Expr_Value (Type_High_Bound (Typ));
-
- -- Check if we have membership predicate
+ -----------------
+ -- Is_Type_Ref --
+ -----------------
- if Nkind (Expr) = N_In then
- Exp := Expr;
+ function Is_Type_Ref (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Identifier and then Chars (N) = Nam;
+ end Is_Type_Ref;
- -- Allow qualified expression with membership predicate inside
+ ------------
+ -- Lo_Val --
+ ------------
- elsif Nkind (Expr) = N_Qualified_Expression
- and then Nkind (Expression (Expr)) = N_In
- then
- Exp := Expression (Expr);
+ function Lo_Val (N : Node_Id) return Uint is
+ begin
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (Low_Bound (N));
+ end if;
+ end Lo_Val;
- -- Anything else cannot be a static predicate
+ ------------------------
+ -- Membership_Entries --
+ ------------------------
+ function Membership_Entries (N : Node_Id) return RList is
+ begin
+ if No (Next (N)) then
+ return Membership_Entry (N);
else
- return;
+ return Membership_Entry (N) or Membership_Entries (Next (N));
end if;
+ end Membership_Entries;
- -- We have a membership operation, so we have a potentially static
- -- predicate, collect and canonicalize the entries in the list.
+ ----------------------
+ -- Membership_Entry --
+ ----------------------
- if Present (Right_Opnd (Exp)) then
- Process_Entry (Right_Opnd (Exp));
+ function Membership_Entry (N : Node_Id) return RList is
+ Val : Uint;
+ SLo : Uint;
+ SHi : Uint;
- if Non_Static then
- return;
+ begin
+ -- Range case
+
+ if Nkind (N) = N_Range then
+ if not Is_Static_Expression (Low_Bound (N))
+ or else
+ not Is_Static_Expression (High_Bound (N))
+ then
+ raise Non_Static;
+ else
+ SLo := Expr_Value (Low_Bound (N));
+ SHi := Expr_Value (High_Bound (N));
+ return RList'(1 => REnt'(SLo, SHi));
end if;
- else
- Alt := First (Alternatives (Exp));
- while Present (Alt) loop
- Process_Entry (Alt);
+ -- Static expression case
- if Non_Static then
- return;
- end if;
+ elsif Is_Static_Expression (N) then
+ Val := Expr_Value (N);
+ return RList'(1 => REnt'(Val, Val));
- Next (Alt);
- end loop;
- end if;
+ -- Identifier (other than static expression) case
- -- Processing was successful and all entries were static, so
- -- now we can store the result as the predicate list.
+ else pragma Assert (Nkind (N) = N_Identifier);
- Set_Static_Predicate (Typ, Plist);
+ -- Type case
- -- The processing for static predicates coalesced ranges and also
- -- eliminated duplicates. We might as well replace the alternatives
- -- list of the right operand of the membership test with the static
- -- predicate list, which will be more efficient.
+ if Is_Type (Entity (N)) then
- declare
- New_Alts : constant List_Id := New_List;
- Old_Node : Node_Id;
- New_Node : Node_Id;
+ -- If type has predicates, process them
- begin
- Old_Node := First (Plist);
- while Present (Old_Node) loop
- New_Node := New_Copy (Old_Node);
+ if Has_Predicates (Entity (N)) then
+ return Stat_Pred (Entity (N));
- if Nkind (New_Node) = N_Range then
- Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
- Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
- end if;
+ -- For static subtype without predicates, get range
- Append_To (New_Alts, New_Node);
- Next (Old_Node);
- end loop;
+ elsif Is_Static_Subtype (Entity (N)) then
+ SLo := Expr_Value (Type_Low_Bound (Entity (N)));
+ SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ return RList'(1 => REnt'(SLo, SHi));
- -- Now update the membership test node
+ -- Any other type makes us non-static
- pragma Assert (Nkind (Expr) = N_In);
+ else
+ raise Non_Static;
+ end if;
+
+ -- Any other kind of identifier in predicate (e.g. a non-static
+ -- expression value) means this is not a static predicate.
- if List_Length (New_Alts) = 1 then
- Set_Right_Opnd (Expr, First (New_Alts));
- Set_Alternatives (Expr, No_List);
else
- Set_Alternatives (Expr, New_Alts);
- Set_Right_Opnd (Expr, Empty);
+ raise Non_Static;
end if;
- end;
- end Build_Static_Predicate;
+ end if;
+ end Membership_Entry;
- -- Start of processing for Build_Predicate_Function
+ ---------------
+ -- Stat_Pred --
+ ---------------
- begin
- -- Initialize for construction of statement list
+ function Stat_Pred (Typ : Entity_Id) return RList is
+ begin
+ -- Not static if type does not have static predicates
- Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
+ if not Has_Predicates (Typ)
+ or else No (Static_Predicate (Typ))
+ then
+ raise Non_Static;
+ end if;
- -- Return if already built or if type does not have predicates
+ -- Otherwise we convert the predicate list to a range list
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
+ declare
+ Result : RList (1 .. List_Length (Static_Predicate (Typ)));
+ P : Node_Id;
+
+ begin
+ P := First (Static_Predicate (Typ));
+ for J in Result'Range loop
+ Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
+ Next (P);
+ end loop;
+
+ return Result;
+ end;
+ end Stat_Pred;
+
+ -- Start of processing for Build_Static_Predicate
+
+ begin
+ -- Immediately non-static if our subtype is non static, or we
+ -- do not have an appropriate discrete subtype in the first place.
+
+ if not Ekind_In (Typ, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ or else not Is_Static_Subtype (Typ)
then
return;
end if;
- -- Add Predicates for the current type
+ -- Get bounds of the type
- Add_Predicates;
+ TLo := Expr_Value (Type_Low_Bound (Typ));
+ THi := Expr_Value (Type_High_Bound (Typ));
- -- Add predicates for ancestor if present
+ -- Now analyze the expression to see if it is a static predicate
declare
- Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ Ranges : constant RList := Get_RList (Expr);
+ -- Range list from expression if it is static
+
+ Plist : List_Id;
+
begin
- if Present (Atyp) then
- Add_Call (Atyp);
- end if;
- end;
+ -- Convert range list into a form for the static predicate. In the
+ -- Ranges array, we just have raw ranges, these must be converted
+ -- to properly typed and analyzed static expressions or range nodes.
- -- If we have predicates, build the function
+ Plist := New_List;
- if Present (Expr) then
+ for J in Ranges'Range loop
+ declare
+ Lo : constant Uint := Ranges (J).Lo;
+ Hi : constant Uint := Ranges (J).Hi;
- -- Deal with static predicate case
+ begin
+ if Lo = Hi then
+ Append_To (Plist, Build_Val (Lo));
+ else
+ Append_To (Plist, Build_Range (Lo, Hi));
+ end if;
+ end;
+ end loop;
- Build_Static_Predicate;
+ -- Processing was successful and all entries were static, so now we
+ -- can store the result as the predicate list.
- -- Build function declaration
+ Set_Static_Predicate (Typ, Plist);
- pragma Assert (Has_Predicates (Typ));
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Predicate_Function (Typ, SId);
+ -- The processing for static predicates put the expression into
+ -- canonical form as a series of ranges. It also eliminated
+ -- duplicates and collapsed and combined ranges. We might as well
+ -- replace the alternatives list of the right operand of the
+ -- membership test with the static predicate list, which will
+ -- usually be more efficient.
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ declare
+ New_Alts : constant List_Id := New_List;
+ Old_Node : Node_Id;
+ New_Node : Node_Id;
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ begin
+ Old_Node := First (Plist);
+ while Present (Old_Node) loop
+ New_Node := New_Copy (Old_Node);
- -- Build function body
+ if Nkind (New_Node) = N_Range then
+ Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
+ Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
+ end if;
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Append_To (New_Alts, New_Node);
+ Next (Old_Node);
+ end loop;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ -- If empty list, replace by True
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
- end if;
- end Build_Predicate_Function;
+ if Is_Empty_List (New_Alts) then
+ Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc));
+
+ -- If singleton list, replace by simple membership test
+
+ elsif List_Length (New_Alts) = 1 then
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Relocate_Node (First (New_Alts)),
+ Alternatives => No_List));
+
+ -- If more than one range, replace by set membership test
+
+ else
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Empty,
+ Alternatives => New_Alts));
+ end if;
+ end;
+ end;
+
+ -- If non-static, return doing nothing
+
+ exception
+ when Non_Static =>
+ return;
+ end Build_Static_Predicate;
-----------------------------------
-- Check_Constant_Address_Clause --
This rewrite of handling of static predicates allows much more general predicate forms, including inheritance of static predicates, comparisons with static values, IN, NOT IN, and the use of AND/OR/NOT to join conditions to create more complex static predicates. The following program compiled with -gnat12 shows some of the new capabilities (all capabilities are there, not all have been tested yet) 1. with Text_IO; use Text_IO; 2. procedure Predicate_Loops is 3. type Int is range 1 .. 10; 4. 5. subtype P2 is Int with 6. predicate => P2 > 6; 7. 8. subtype P3 is Int with 9. predicate => ((P3 > 6) and P3 < 9); 10. 11. subtype P4 is Int with 12. predicate => (P4 in P2) and P4 < 10; 13. 14. subtype P5 is Int with 15. predicate => P5 < 3 or P5 > 8; 16. 17. begin 18. for J in P2 loop 19. Put_Line ("P2:" & J'Img); 20. end loop; 21. 22. for J in P3 loop 23. Put_Line ("P3:" & J'Img); 24. end loop; 25. 26. for J in P4 loop 27. Put_Line ("P4:" & J'Img); 28. end loop; 29. 30. for J in P5 loop 31. Put_Line ("P5:" & J'Img); 32. end loop; 33. end Predicate_Loops; The output is: P2: 7 P2: 8 P2: 9 P2: 10 P3: 7 P3: 8 P4: 7 P4: 8 P4: 9 P5: 1 P5: 2 P5: 9 P5: 10 Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-25 Robert Dewar <dewar@adacore.com> * sem_ch13.adb (Build_Static_Predicate): Moved out of Build_Predicate_Function. (Build_Static_Predicate): Complet rewrite for more general predicates