with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
package body Sem_Eval is
type Bits is array (Nat range <>) of Boolean;
CV_Bits : constant := 5;
CV_Cache_Size : constant Nat := 2 ** CV_Bits;
subtype CV_Range is Nat range 0 .. CV_Cache_Size;
type CV_Entry is record
N : Node_Id;
V : Uint;
end record;
type CV_Cache_Array is array (CV_Range) of CV_Entry;
CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
function From_Bits (B : Bits; T : Entity_Id) return Uint;
function Get_String_Val (N : Node_Id) return Node_Id;
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
procedure Out_Of_Range (N : Node_Id);
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
function String_Type_Len (Stype : Entity_Id) return Uint;
function Test (Cond : Boolean) return Uint;
pragma Inline (Test);
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Stat : out Boolean;
Fold : out Boolean);
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id;
Stat : out Boolean;
Fold : out Boolean);
procedure To_Bits (U : Uint; B : out Bits);
procedure Check_Non_Static_Context (N : Node_Id) is
T : constant Entity_Id := Etype (N);
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (T)
and not Range_Checks_Suppressed (T);
begin
if T = Any_Type or else not Is_Scalar_Type (T) then
return;
end if;
if Raises_Constraint_Error (N) then
return;
end if;
if not Is_Static_Expression (N) then
if Is_Floating_Point_Type (T)
and then Is_Out_Of_Range (N, Base_Type (T))
then
Error_Msg_N
("?float value out of range, infinity will be generated", N);
end if;
return;
end if;
if Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N)
and then not Is_Generic_Type (Etype (N))
and then Etype (N) /= Universal_Real
then
if Is_Out_Of_Range (N, Base_Type (T)) then
Out_Of_Range (N);
return;
end if;
Rewrite (N, New_Copy (N));
if not Is_Floating_Point_Type (T) then
Set_Realval
(N, Corresponding_Integer_Value (N) * Small_Value (T));
elsif not UR_Is_Zero (Realval (N)) then
Set_Realval
(N, Machine (Base_Type (T), Realval (N), Round_Even, N));
end if;
Set_Is_Machine_Number (N);
end if;
if Etype (N) = Universal_Integer
and then Nkind (N) = N_Integer_Literal
and then Nkind (Parent (N)) in N_Subexpr
and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else
Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
then
Apply_Compile_Time_Constraint_Error
(N, "non-static universal integer value out of range?",
CE_Range_Check_Failed);
elsif Is_Out_Of_Range (N, Base_Type (T)) then
Out_Of_Range (N);
elsif T /= Base_Type (T)
and then Nkind (Parent (N)) /= N_Range
then
if Is_In_Range (N, T) then
null;
elsif Is_Out_Of_Range (N, T) then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
elsif Checks_On then
Enable_Range_Check (N);
else
Set_Do_Range_Check (N, False);
end if;
end if;
end Check_Non_Static_Context;
procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
begin
if not Raises_Constraint_Error (N)
and then Is_Constrained (Ttype)
then
if
UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
then
Apply_Compile_Time_Constraint_Error
(N, "string length wrong for}?",
CE_Length_Check_Failed,
Ent => Ttype,
Typ => Ttype);
end if;
end if;
end Check_String_Literal_Length;
function Compile_Time_Compare
(L, R : Node_Id;
Rec : Boolean := False)
return Compare_Result
is
Ltyp : constant Entity_Id := Etype (L);
Rtyp : constant Entity_Id := Etype (R);
procedure Compare_Decompose
(N : Node_Id;
R : out Node_Id;
V : out Uint);
function Compare_Fixup (N : Node_Id) return Node_Id;
function Is_Same_Value (L, R : Node_Id) return Boolean;
procedure Compare_Decompose
(N : Node_Id;
R : out Node_Id;
V : out Uint)
is
begin
if Nkind (N) = N_Op_Add
and then Nkind (Right_Opnd (N)) = N_Integer_Literal
then
R := Left_Opnd (N);
V := Intval (Right_Opnd (N));
return;
elsif Nkind (N) = N_Op_Subtract
and then Nkind (Right_Opnd (N)) = N_Integer_Literal
then
R := Left_Opnd (N);
V := UI_Negate (Intval (Right_Opnd (N)));
return;
elsif Nkind (N) = N_Attribute_Reference then
if Attribute_Name (N) = Name_Succ then
R := First (Expressions (N));
V := Uint_1;
return;
elsif Attribute_Name (N) = Name_Pred then
R := First (Expressions (N));
V := Uint_Minus_1;
return;
end if;
end if;
R := N;
V := Uint_0;
end Compare_Decompose;
function Compare_Fixup (N : Node_Id) return Node_Id is
Indx : Node_Id;
Xtyp : Entity_Id;
Subs : Nat;
begin
if Nkind (N) = N_Attribute_Reference
and then (Attribute_Name (N) = Name_First
or else
Attribute_Name (N) = Name_Last)
then
Xtyp := Etype (Prefix (N));
if No (Xtyp) then
return N;
end if;
if Is_Access_Type (Xtyp) then
Xtyp := Designated_Type (Xtyp);
end if;
if not Is_Array_Type (Xtyp) then
return N;
end if;
if not Is_Constrained (Xtyp) then
return N;
end if;
if Ekind (Xtyp) = E_String_Literal_Subtype then
if Attribute_Name (N) = Name_First then
return String_Literal_Low_Bound (Xtyp);
else return Make_Integer_Literal (Sloc (N),
Intval => Intval (String_Literal_Low_Bound (Xtyp))
+ String_Literal_Length (Xtyp));
end if;
end if;
Indx := First_Index (Xtyp);
if Present (Expressions (N)) then
Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
for J in 2 .. Subs loop
Indx := Next_Index (Indx);
end loop;
end if;
Xtyp := Etype (Indx);
if Attribute_Name (N) = Name_First then
return Type_Low_Bound (Xtyp);
else return Type_High_Bound (Xtyp);
end if;
end if;
return N;
end Compare_Fixup;
function Is_Same_Value (L, R : Node_Id) return Boolean is
Lf : constant Node_Id := Compare_Fixup (L);
Rf : constant Node_Id := Compare_Fixup (R);
function Is_Same_Subscript (L, R : List_Id) return Boolean;
function Is_Same_Subscript (L, R : List_Id) return Boolean is
begin
if L = No_List then
if R = No_List then
return True;
else
return Expr_Value (First (R)) = Uint_1;
end if;
else
if R = No_List then
return Expr_Value (First (L)) = Uint_1;
else
return Expr_Value (First (L)) = Expr_Value (First (R));
end if;
end if;
end Is_Same_Subscript;
begin
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf)
and then not Is_Floating_Point_Type (Etype (L))
and then (Ekind (Entity (Lf)) = E_Constant or else
Ekind (Entity (Lf)) = E_In_Parameter or else
Ekind (Entity (Lf)) = E_Loop_Parameter)
then
return True;
elsif Compile_Time_Known_Value (Lf)
and then
Compile_Time_Known_Value (Rf)
and then Expr_Value (Lf) = Expr_Value (Rf)
then
return True;
elsif Nkind (Lf) = N_Attribute_Reference
and then
Nkind (Rf) = N_Attribute_Reference
and then Attribute_Name (Lf) = Attribute_Name (Rf)
and then (Attribute_Name (Lf) = Name_First
or else
Attribute_Name (Lf) = Name_Last)
and then Is_Entity_Name (Prefix (Lf))
and then Is_Entity_Name (Prefix (Rf))
and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
then
return True;
else
return False;
end if;
end Is_Same_Value;
begin
if not (Cannot_Raise_Constraint_Error (L)
and then
Cannot_Raise_Constraint_Error (R))
then
return Unknown;
end if;
if L = R then
return EQ;
elsif No (Ltyp) or else No (Rtyp) then
return Unknown;
elsif not Is_Scalar_Type (Ltyp)
or else Is_Packed_Array_Type (Ltyp)
then
return Unknown;
elsif Compile_Time_Known_Value (L)
and then Compile_Time_Known_Value (R)
then
if Is_Floating_Point_Type (Ltyp)
or else
Is_Floating_Point_Type (Rtyp)
then
declare
Lo : constant Ureal := Expr_Value_R (L);
Hi : constant Ureal := Expr_Value_R (R);
begin
if Lo < Hi then
return LE;
elsif Lo = Hi then
return EQ;
else
return GE;
end if;
end;
else
declare
Lo : constant Uint := Expr_Value (L);
Hi : constant Uint := Expr_Value (R);
begin
if Lo < Hi then
return LT;
elsif Lo = Hi then
return EQ;
else
return GT;
end if;
end;
end if;
else
if not Rec
and then Is_Discrete_Type (Ltyp)
and then Is_Discrete_Type (Rtyp)
and then not Is_Generic_Type (Ltyp)
and then not Is_Generic_Type (Rtyp)
then
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
when others => null;
end case;
case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
when others => null;
end case;
end if;
declare
Lnode : Node_Id;
Loffs : Uint;
Rnode : Node_Id;
Roffs : Uint;
begin
Compare_Decompose (L, Lnode, Loffs);
Compare_Decompose (R, Rnode, Roffs);
if Is_Same_Value (Lnode, Rnode) then
if Loffs = Roffs then
return EQ;
elsif Loffs < Roffs then
return LT;
else
return GT;
end if;
else
return Unknown;
end if;
end;
end if;
end Compile_Time_Compare;
function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
K : constant Node_Kind := Nkind (Op);
CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
begin
if No (Op)
or else Op = Error
or else Etype (Op) = Any_Type
or else Raises_Constraint_Error (Op)
then
return False;
end if;
if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then
return False;
end if;
if Present (Etype (Op)) and then Is_Entity_Name (Op) then
declare
E : constant Entity_Id := Entity (Op);
V : Node_Id;
begin
if Is_Packed_Array_Type (Etype (Op)) then
return False;
end if;
if Ekind (E) = E_Enumeration_Literal then
return True;
elsif Ekind (E) = E_Constant then
V := Constant_Value (E);
return Present (V) and then Compile_Time_Known_Value (V);
end if;
end;
else
if K = N_Integer_Literal then
CV_Ent.N := Op;
CV_Ent.V := Intval (Op);
return True;
elsif
K = N_Character_Literal
or else
K = N_Real_Literal
or else
K = N_String_Literal
or else
K = N_Null
then
return True;
elsif K = N_Attribute_Reference then
return Attribute_Name (Op) = Name_Null_Parameter;
end if;
end if;
return False;
exception
when others =>
return False;
end Compile_Time_Known_Value;
function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
begin
if Is_Entity_Name (Op) then
declare
E : constant Entity_Id := Entity (Op);
V : Node_Id;
begin
if Ekind (E) = E_Enumeration_Literal then
return True;
elsif Ekind (E) /= E_Constant then
return False;
else
V := Constant_Value (E);
return Present (V)
and then Compile_Time_Known_Value_Or_Aggr (V);
end if;
end;
else
if Compile_Time_Known_Value (Op) then
return True;
elsif Nkind (Op) = N_Aggregate then
if Present (Expressions (Op)) then
declare
Expr : Node_Id;
begin
Expr := First (Expressions (Op));
while Present (Expr) loop
if not Compile_Time_Known_Value_Or_Aggr (Expr) then
return False;
end if;
Next (Expr);
end loop;
end;
end if;
if Present (Component_Associations (Op)) then
declare
Cass : Node_Id;
begin
Cass := First (Component_Associations (Op));
while Present (Cass) loop
if not
Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
then
return False;
end if;
Next (Cass);
end loop;
end;
end if;
return True;
else
return False;
end if;
end if;
end Compile_Time_Known_Value_Or_Aggr;
procedure Eval_Actual (N : Node_Id) is
begin
Check_Non_Static_Context (N);
end Eval_Actual;
procedure Eval_Allocator (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
begin
if Nkind (Expr) = N_Qualified_Expression then
Check_Non_Static_Context (Expression (Expr));
end if;
end Eval_Allocator;
procedure Eval_Arithmetic_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Ltype : constant Entity_Id := Etype (Left);
Rtype : constant Entity_Id := Etype (Right);
Stat : Boolean;
Fold : Boolean;
begin
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Right_Int : constant Uint := Expr_Value (Right);
Result : Uint;
begin
case Nkind (N) is
when N_Op_Add =>
Result := Left_Int + Right_Int;
when N_Op_Subtract =>
Result := Left_Int - Right_Int;
when N_Op_Multiply =>
if OK_Bits
(N, UI_From_Int
(Num_Bits (Left_Int) + Num_Bits (Right_Int)))
then
Result := Left_Int * Right_Int;
else
Result := Left_Int;
end if;
when N_Op_Divide =>
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
(N, "division by zero",
CE_Divide_By_Zero,
Warn => not Stat);
return;
else
Result := Left_Int / Right_Int;
end if;
when N_Op_Mod =>
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor",
CE_Divide_By_Zero,
Warn => not Stat);
return;
else
Result := Left_Int mod Right_Int;
end if;
when N_Op_Rem =>
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor",
CE_Divide_By_Zero,
Warn => not Stat);
return;
else
Result := Left_Int rem Right_Int;
end if;
when others =>
raise Program_Error;
end case;
if Is_Modular_Integer_Type (Ltype) then
Result := Result mod Modulus (Ltype);
elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
declare
BT : constant Entity_Id := Base_Type (Ltype);
Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
begin
if Result < Lo or else Result > Hi then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of }?",
CE_Overflow_Check_Failed,
Ent => BT);
return;
end if;
end;
end if;
Fold_Uint (N, Result, Stat);
end;
elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
declare
Left_Real : Ureal;
Right_Real : Ureal;
Result : Ureal;
begin
if Is_Real_Type (Ltype) then
Left_Real := Expr_Value_R (Left);
else
Left_Real := UR_From_Uint (Expr_Value (Left));
end if;
if Is_Real_Type (Rtype) then
Right_Real := Expr_Value_R (Right);
else
Right_Real := UR_From_Uint (Expr_Value (Right));
end if;
if Nkind (N) = N_Op_Add then
Result := Left_Real + Right_Real;
elsif Nkind (N) = N_Op_Subtract then
Result := Left_Real - Right_Real;
elsif Nkind (N) = N_Op_Multiply then
Result := Left_Real * Right_Real;
else pragma Assert (Nkind (N) = N_Op_Divide);
if UR_Is_Zero (Right_Real) then
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero);
return;
end if;
Result := Left_Real / Right_Real;
end if;
Fold_Ureal (N, Result, Stat);
end;
end if;
end Eval_Arithmetic_Op;
procedure Eval_Character_Literal (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Eval_Character_Literal;
procedure Eval_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Lit : Entity_Id;
begin
if Nkind (N) = N_Function_Call
and then No (Parameter_Associations (N))
and then Is_Entity_Name (Name (N))
and then Present (Alias (Entity (Name (N))))
and then Is_Enumeration_Type (Base_Type (Typ))
then
Lit := Alias (Entity (Name (N)));
while Present (Alias (Lit)) loop
Lit := Alias (Lit);
end loop;
if Ekind (Lit) = E_Enumeration_Literal then
if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
Rewrite
(N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
else
Rewrite (N, New_Occurrence_Of (Lit, Loc));
end if;
Resolve (N, Typ);
end if;
end if;
end Eval_Call;
procedure Eval_Concatenation (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
Stat : Boolean;
Fold : Boolean;
begin
if Ada_Version = Ada_83
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if (C_Typ = Standard_Character
or else C_Typ = Standard_Wide_Character
or else C_Typ = Standard_Wide_Wide_Character)
and then Fold
then
null;
else
Set_Is_Static_Expression (N, False);
return;
end if;
declare
Left_Str : constant Node_Id := Get_String_Val (Left);
Left_Len : Nat;
Right_Str : constant Node_Id := Get_String_Val (Right);
begin
if Nkind (Left_Str) = N_String_Literal then
Left_Len := String_Length (Strval (Left_Str));
Start_String (Strval (Left_Str));
else
Start_String;
Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
Left_Len := 1;
end if;
if Nkind (Right_Str) = N_String_Literal then
declare
S : constant String_Id := Strval (Right_Str);
begin
for J in 1 .. String_Length (S) loop
Store_String_Char (Get_String_Char (S, J));
end loop;
end;
else
Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
end if;
Set_Is_Static_Expression (N, Stat);
if Stat then
if Left_Len = 0
and then Is_Array_Type (Etype (Right))
and then Etype (Right) /= Any_String
then
Set_Etype (N, Etype (Right));
end if;
Fold_Str (N, End_String, True);
end if;
end;
end Eval_Concatenation;
procedure Eval_Conditional_Expression (N : Node_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
begin
Check_Non_Static_Context (Then_Expr);
Check_Non_Static_Context (Else_Expr);
end Eval_Conditional_Expression;
procedure Eval_Entity_Name (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (N);
Val : Node_Id;
begin
if Ekind (Def_Id) = E_Enumeration_Literal then
Set_Is_Static_Expression (N);
return;
elsif Ekind (Def_Id) = E_Constant then
if Present (Full_View (Def_Id))
and then not In_Open_Scopes (Scope (Def_Id))
then
Val := Empty;
else
Val := Constant_Value (Def_Id);
end if;
if Present (Val) then
Set_Is_Static_Expression
(N, Is_Static_Expression (Val)
and then Is_Static_Subtype (Etype (Def_Id)));
Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
if not Is_Static_Expression (N)
and then not Is_Generic_Type (Etype (N))
then
Validate_Static_Object_Name (N);
end if;
return;
end if;
end if;
Validate_Static_Object_Name (N);
end Eval_Entity_Name;
procedure Eval_Indexed_Component (N : Node_Id) is
Expr : Node_Id;
begin
Expr := First (Expressions (N));
while Present (Expr) loop
Check_Non_Static_Context (Expr);
Next (Expr);
end loop;
if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
return;
elsif Nkind (Parent (N)) = N_Attribute_Reference then
return;
end if;
if List_Length (Expressions (N)) = 1
and then Is_Entity_Name (Prefix (N))
and then Ekind (Entity (Prefix (N))) = E_Constant
and then Present (Constant_Value (Entity (Prefix (N))))
then
declare
Loc : constant Source_Ptr := Sloc (N);
Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
Sub : constant Node_Id := First (Expressions (N));
Atyp : Entity_Id;
Lin : Nat;
Lbd : Node_Id;
Elm : Node_Id;
begin
Atyp := Etype (Arr);
if Is_Access_Type (Atyp) then
Atyp := Designated_Type (Atyp);
end if;
if Is_Array_Type (Atyp) then
if Ekind (Atyp) = E_String_Literal_Subtype then
Lbd := String_Literal_Low_Bound (Atyp);
else
Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
end if;
if Compile_Time_Known_Value (Sub)
and then Nkind (Arr) = N_Aggregate
and then Compile_Time_Known_Value (Lbd)
and then Is_Discrete_Type (Component_Type (Atyp))
then
Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
if List_Length (Expressions (Arr)) >= Lin then
Elm := Pick (Expressions (Arr), Lin);
if Compile_Time_Known_Value (Elm) then
Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
Set_Is_Static_Expression (N, False);
Set_Sloc (N, Loc);
end if;
end if;
end if;
end if;
end;
end if;
end Eval_Indexed_Component;
procedure Eval_Integer_Literal (N : Node_Id) is
T : constant Entity_Id := Etype (N);
function In_Any_Integer_Context return Boolean;
function In_Any_Integer_Context return Boolean is
Par : constant Node_Id := Parent (N);
K : constant Node_Kind := Nkind (Par);
begin
return K = N_Number_Declaration
or else K = N_Attribute_Reference
or else K = N_Attribute_Definition_Clause
or else K = N_Modular_Type_Definition
or else K = N_Signed_Integer_Type_Definition;
end In_Any_Integer_Context;
begin
if Nkind (Parent (N)) not in N_Subexpr
and then not In_Any_Integer_Context
then
Check_Non_Static_Context (N);
end if;
if Is_Modular_Integer_Type (T)
and then Is_Out_Of_Range (N, Base_Type (T))
then
Out_Of_Range (N);
end if;
end Eval_Integer_Literal;
procedure Eval_Logical_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
declare
Left_Int : constant Uint := Expr_Value (Left);
Right_Int : constant Uint := Expr_Value (Right);
begin
if Is_Modular_Integer_Type (Etype (N)) then
declare
Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
begin
To_Bits (Left_Int, Left_Bits);
To_Bits (Right_Int, Right_Bits);
if Nkind (N) = N_Op_And then
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
end loop;
elsif Nkind (N) = N_Op_Or then
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
end loop;
else
pragma Assert (Nkind (N) = N_Op_Xor);
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
end loop;
end if;
Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
end;
else
pragma Assert (Is_Boolean_Type (Etype (N)));
if Nkind (N) = N_Op_And then
Fold_Uint (N,
Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
elsif Nkind (N) = N_Op_Or then
Fold_Uint (N,
Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
else
pragma Assert (Nkind (N) = N_Op_Xor);
Fold_Uint (N,
Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
end if;
end if;
end;
end Eval_Logical_Op;
procedure Eval_Membership_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Def_Id : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
Result : Boolean;
Stat : Boolean;
Fold : Boolean;
begin
if Etype (Left) = Any_Type
or else Etype (Right) = Any_Type
then
Set_Etype (N, Any_Type);
return;
end if;
if Is_Entity_Name (Right) then
Def_Id := Entity (Right);
if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
and then Is_OK_Static_Subtype (Def_Id)
then
Test_Expression_Is_Foldable (N, Left, Stat, Fold);
if not Fold or else not Stat then
return;
end if;
else
Check_Non_Static_Context (Left);
return;
end if;
if not Is_String_Type (Def_Id) then
Lo := Type_Low_Bound (Def_Id);
Hi := Type_High_Bound (Def_Id);
else
Lo := Empty;
Hi := Empty;
end if;
else
if Is_Static_Range (Right) then
Test_Expression_Is_Foldable (N, Left, Stat, Fold);
if not Fold or else not Stat then
return;
elsif not Is_OK_Static_Range (Right) then
Check_Non_Static_Context (Left);
return;
end if;
else
Check_Non_Static_Context (Left);
return;
end if;
Lo := Low_Bound (Right);
Hi := High_Bound (Right);
end if;
if Is_String_Type (Etype (Right)) then
if not Is_Constrained (Etype (Right)) then
Result := True;
else
declare
Typlen : constant Uint := String_Type_Len (Etype (Right));
Strlen : constant Uint :=
UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
begin
Result := (Typlen = Strlen);
end;
end if;
elsif Is_Real_Type (Etype (Right)) then
declare
Leftval : constant Ureal := Expr_Value_R (Left);
begin
Result := Expr_Value_R (Lo) <= Leftval
and then Leftval <= Expr_Value_R (Hi);
end;
else
declare
Leftval : constant Uint := Expr_Value (Left);
begin
Result := Expr_Value (Lo) <= Leftval
and then Leftval <= Expr_Value (Hi);
end;
end if;
if Nkind (N) = N_Not_In then
Result := not Result;
end if;
Fold_Uint (N, Test (Result), True);
Warn_On_Known_Condition (N);
end Eval_Membership_Op;
procedure Eval_Named_Integer (N : Node_Id) is
begin
Fold_Uint (N,
Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Integer;
procedure Eval_Named_Real (N : Node_Id) is
begin
Fold_Ureal (N,
Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Real;
procedure Eval_Op_Expon (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
declare
Right_Int : constant Uint := Expr_Value (Right);
begin
if Is_Integer_Type (Etype (Left)) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Result : Uint;
begin
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
(N, "integer exponent negative",
CE_Range_Check_Failed,
Warn => not Stat);
return;
else
if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
Result := Left_Int ** Right_Int;
else
Result := Left_Int;
end if;
if Is_Modular_Integer_Type (Etype (N)) then
Result := Result mod Modulus (Etype (N));
end if;
Fold_Uint (N, Result, Stat);
end if;
end;
else
declare
Left_Real : constant Ureal := Expr_Value_R (Left);
begin
if UR_Is_Zero (Left_Real) then
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
(N, "zero ** negative integer",
CE_Range_Check_Failed,
Warn => not Stat);
return;
else
Fold_Ureal (N, Ureal_0, Stat);
end if;
else
Fold_Ureal (N, Left_Real ** Right_Int, Stat);
end if;
end;
end if;
end;
end Eval_Op_Expon;
procedure Eval_Op_Not (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
Test_Expression_Is_Foldable (N, Right, Stat, Fold);
if not Fold then
return;
end if;
declare
Rint : constant Uint := Expr_Value (Right);
Typ : constant Entity_Id := Etype (N);
begin
if Is_Modular_Integer_Type (Typ) then
Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
else
pragma Assert (Is_Boolean_Type (Typ));
Fold_Uint (N, Test (not Is_True (Rint)), Stat);
end if;
Set_Is_Static_Expression (N, Stat);
end;
end Eval_Op_Not;
procedure Eval_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
Stat : Boolean;
Fold : Boolean;
Hex : Boolean;
begin
if not Is_Static_Subtype (Target_Type)
or else Nkind (Parent (N)) = N_Allocator
then
Check_Non_Static_Context (Operand);
if Nkind (Operand) = N_Raise_Constraint_Error then
Set_Raises_Constraint_Error (N);
end if;
return;
end if;
Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
if not Fold then
return;
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
return;
end if;
Hex := Nkind (Operand) = N_Integer_Literal
and then Print_In_Hex (Operand);
if Is_Discrete_Type (Target_Type) then
Fold_Uint (N, Expr_Value (Operand), Stat);
if Hex and then Nkind (N) = N_Integer_Literal then
Set_Print_In_Hex (N);
end if;
elsif Is_Real_Type (Target_Type) then
Fold_Ureal (N, Expr_Value_R (Operand), Stat);
else
Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
if not Stat then
Set_Is_Static_Expression (N, False);
else
Check_String_Literal_Length (N, Target_Type);
end if;
return;
end if;
Set_Is_Static_Expression (N, Stat);
if Is_Out_Of_Range (N, Etype (N)) then
Out_Of_Range (N);
end if;
end Eval_Qualified_Expression;
procedure Eval_Real_Literal (N : Node_Id) is
begin
if Nkind (Parent (N)) not in N_Subexpr then
Check_Non_Static_Context (N);
end if;
end Eval_Real_Literal;
procedure Eval_Relational_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Typ : constant Entity_Id := Etype (Left);
Result : Boolean;
Stat : Boolean;
Fold : Boolean;
begin
if Is_Array_Type (Typ)
and then Number_Dimensions (Typ) = 1
and then (Nkind (N) = N_Op_Eq
or else Nkind (N) = N_Op_Ne)
then
if Raises_Constraint_Error (Left)
or else Raises_Constraint_Error (Right)
then
return;
end if;
declare
procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
T : Entity_Id;
begin
if Nkind (Op) = N_String_Literal then
Len := UI_From_Int (String_Length (Strval (Op)));
elsif not Is_Constrained (Etype (Op)) then
Len := Uint_Minus_1;
else
T := Etype (First_Index (Etype (Op)));
if Is_Discrete_Type (T)
and then
Compile_Time_Known_Value (Type_Low_Bound (T))
and then
Compile_Time_Known_Value (Type_High_Bound (T))
then
Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
else
Len := Uint_Minus_1;
end if;
end if;
end Get_Static_Length;
Len_L : Uint;
Len_R : Uint;
begin
Get_Static_Length (Left, Len_L);
Get_Static_Length (Right, Len_R);
if Len_L /= Uint_Minus_1
and then Len_R /= Uint_Minus_1
and then Len_L /= Len_R
then
Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
Warn_On_Known_Condition (N);
return;
end if;
end;
end if;
if not Is_Scalar_Type (Typ) then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
if Is_Discrete_Type (Typ) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Right_Int : constant Uint := Expr_Value (Right);
begin
case Nkind (N) is
when N_Op_Eq => Result := Left_Int = Right_Int;
when N_Op_Ne => Result := Left_Int /= Right_Int;
when N_Op_Lt => Result := Left_Int < Right_Int;
when N_Op_Le => Result := Left_Int <= Right_Int;
when N_Op_Gt => Result := Left_Int > Right_Int;
when N_Op_Ge => Result := Left_Int >= Right_Int;
when others =>
raise Program_Error;
end case;
Fold_Uint (N, Test (Result), Stat);
end;
else
pragma Assert (Is_Real_Type (Typ));
declare
Left_Real : constant Ureal := Expr_Value_R (Left);
Right_Real : constant Ureal := Expr_Value_R (Right);
begin
case Nkind (N) is
when N_Op_Eq => Result := (Left_Real = Right_Real);
when N_Op_Ne => Result := (Left_Real /= Right_Real);
when N_Op_Lt => Result := (Left_Real < Right_Real);
when N_Op_Le => Result := (Left_Real <= Right_Real);
when N_Op_Gt => Result := (Left_Real > Right_Real);
when N_Op_Ge => Result := (Left_Real >= Right_Real);
when others =>
raise Program_Error;
end case;
Fold_Uint (N, Test (Result), Stat);
end;
end if;
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
procedure Eval_Shift (N : Node_Id) is
begin
Check_Non_Static_Context (Left_Opnd (N));
Check_Non_Static_Context (Right_Opnd (N));
end Eval_Shift;
procedure Eval_Short_Circuit (N : Node_Id) is
Kind : constant Node_Kind := Nkind (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Left_Int : Uint;
Rstat : constant Boolean :=
Is_Static_Expression (Left)
and then Is_Static_Expression (Right);
begin
if Ada_Version = Ada_83
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
Set_Etype (N, Any_Type);
return;
elsif Raises_Constraint_Error (Left) then
if not Rstat then
Check_Non_Static_Context (Right);
end if;
Rewrite_In_Raise_CE (N, Left);
Set_Is_Static_Expression (N, Rstat);
return;
elsif not Rstat then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
Set_Is_Static_Expression (N);
Left_Int := Expr_Value (Left);
if (Kind = N_And_Then and then Is_False (Left_Int))
or else (Kind = N_Or_Else and Is_True (Left_Int))
then
Fold_Uint (N, Left_Int, Rstat);
return;
end if;
if Raises_Constraint_Error (Right) then
Rewrite_In_Raise_CE (N, Right);
Check_Non_Static_Context (Left);
return;
end if;
Fold_Uint (N, Expr_Value (Right), Rstat);
return;
end Eval_Short_Circuit;
procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N);
begin
if Nkind (Drange) = N_Range then
Check_Non_Static_Context (Low_Bound (Drange));
Check_Non_Static_Context (High_Bound (Drange));
end if;
end Eval_Slice;
procedure Eval_String_Literal (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Bas : constant Entity_Id := Base_Type (Typ);
Xtp : Entity_Id;
Len : Nat;
Lo : Node_Id;
begin
if Bas = Any_Type or else Bas = Any_String then
return;
end if;
if Ekind (Typ) = E_String_Literal_Subtype then
if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
Set_Is_Static_Expression (N, False);
return;
end if;
elsif not Is_OK_Static_Expression
(Type_Low_Bound (Etype (First_Index (Typ))))
then
Set_Is_Static_Expression (N, False);
return;
end if;
if Nkind (Original_Node (N)) = N_Type_Conversion then
Set_Is_Static_Expression (N, False);
return;
end if;
if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String
or else
Root_Type (Bas) = Standard_Wide_String
then
Xtp := Standard_Positive;
else
Xtp := Etype (First_Index (Bas));
end if;
if Ekind (Typ) = E_String_Literal_Subtype then
Lo := String_Literal_Low_Bound (Typ);
else
Lo := Type_Low_Bound (Etype (First_Index (Typ)));
end if;
Len := String_Length (Strval (N));
if UI_From_Int (Len) > String_Type_Len (Bas) then
Apply_Compile_Time_Constraint_Error
(N, "string literal too long for}", CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas));
elsif Len = 0
and then not Is_Generic_Type (Xtp)
and then
Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
then
Apply_Compile_Time_Constraint_Error
(N, "null string literal not allowed for}",
CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas));
end if;
end if;
end Eval_String_Literal;
procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Source_Type : constant Entity_Id := Etype (Operand);
Target_Type : constant Entity_Id := Etype (N);
Stat : Boolean;
Fold : Boolean;
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
begin
return
Is_Integer_Type (T)
or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
end To_Be_Treated_As_Integer;
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
begin
return
Is_Floating_Point_Type (T)
or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
end To_Be_Treated_As_Real;
begin
if not Is_Static_Subtype (Target_Type) then
Check_Non_Static_Context (Operand);
return;
elsif Error_Posted (N) then
return;
end if;
Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
if not Fold then
return;
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
return;
end if;
if Is_String_Type (Target_Type) then
Fold_Str (N, Strval (Get_String_Val (Operand)), False);
return;
elsif To_Be_Treated_As_Integer (Target_Type) then
declare
Result : Uint;
begin
if To_Be_Treated_As_Integer (Source_Type) then
Result := Expr_Value (Operand);
else
Result := UR_To_Uint (Expr_Value_R (Operand));
end if;
if Is_Fixed_Point_Type (Target_Type) then
Fold_Ureal
(N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
else
Fold_Uint (N, Result, Stat);
end if;
end;
elsif To_Be_Treated_As_Real (Target_Type) then
declare
Result : Ureal;
begin
if To_Be_Treated_As_Real (Source_Type) then
Result := Expr_Value_R (Operand);
else
Result := UR_From_Uint (Expr_Value (Operand));
end if;
Fold_Ureal (N, Result, Stat);
end;
else
Fold_Uint (N, Expr_Value (Operand), Stat);
end if;
if Is_Out_Of_Range (N, Etype (N)) then
Out_Of_Range (N);
end if;
end Eval_Type_Conversion;
procedure Eval_Unary_Op (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
Test_Expression_Is_Foldable (N, Right, Stat, Fold);
if not Fold then
return;
end if;
if Is_Integer_Type (Etype (N)) then
declare
Rint : constant Uint := Expr_Value (Right);
Result : Uint;
begin
if Nkind (N) = N_Op_Plus then
Result := Rint;
elsif Nkind (N) = N_Op_Minus then
if Is_Modular_Integer_Type (Etype (N)) then
Result := (-Rint) mod Modulus (Etype (N));
else
Result := (-Rint);
end if;
else
pragma Assert (Nkind (N) = N_Op_Abs);
Result := abs Rint;
end if;
Fold_Uint (N, Result, Stat);
end;
elsif Is_Real_Type (Etype (N)) then
declare
Rreal : constant Ureal := Expr_Value_R (Right);
Result : Ureal;
begin
if Nkind (N) = N_Op_Plus then
Result := Rreal;
elsif Nkind (N) = N_Op_Minus then
Result := UR_Negate (Rreal);
else
pragma Assert (Nkind (N) = N_Op_Abs);
Result := abs Rreal;
end if;
Fold_Ureal (N, Result, Stat);
end;
end if;
end Eval_Unary_Op;
procedure Eval_Unchecked_Conversion (N : Node_Id) is
begin
Check_Non_Static_Context (Expression (N));
end Eval_Unchecked_Conversion;
function Expr_Rep_Value (N : Node_Id) return Uint is
Kind : constant Node_Kind := Nkind (N);
Ent : Entity_Id;
begin
if Is_Entity_Name (N) then
Ent := Entity (N);
if Ekind (Ent) = E_Enumeration_Literal then
return Enumeration_Rep (Ent);
else
pragma Assert (Ekind (Ent) = E_Constant);
return Expr_Rep_Value (Constant_Value (Ent));
end if;
elsif Kind = N_Integer_Literal then
return Intval (N);
elsif Kind = N_Real_Literal then
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
return Corresponding_Integer_Value (N);
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
return Uint_0;
else
pragma Assert (Kind = N_Character_Literal);
Ent := Entity (N);
if No (Ent) then
return Char_Literal_Value (N);
else
return Enumeration_Rep (Ent);
end if;
end if;
end Expr_Rep_Value;
function Expr_Value (N : Node_Id) return Uint is
Kind : constant Node_Kind := Nkind (N);
CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
Ent : Entity_Id;
Val : Uint;
begin
if CV_Ent.N = N then
return CV_Ent.V;
end if;
if Is_Entity_Name (N) then
Ent := Entity (N);
if Ekind (Ent) = E_Enumeration_Literal then
Val := Enumeration_Pos (Ent);
else
pragma Assert (Ekind (Ent) = E_Constant);
Val := Expr_Value (Constant_Value (Ent));
end if;
elsif Kind = N_Integer_Literal then
Val := Intval (N);
elsif Kind = N_Real_Literal then
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
Val := Corresponding_Integer_Value (N);
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
Val := Uint_0;
else
pragma Assert (Kind = N_Character_Literal);
Ent := Entity (N);
if No (Ent) then
Val := Char_Literal_Value (N);
else
Val := Enumeration_Pos (Ent);
end if;
end if;
CV_Ent.N := N;
CV_Ent.V := Val;
return Val;
end Expr_Value;
function Expr_Value_E (N : Node_Id) return Entity_Id is
Ent : constant Entity_Id := Entity (N);
begin
if Ekind (Ent) = E_Enumeration_Literal then
return Ent;
else
pragma Assert (Ekind (Ent) = E_Constant);
return Expr_Value_E (Constant_Value (Ent));
end if;
end Expr_Value_E;
function Expr_Value_R (N : Node_Id) return Ureal is
Kind : constant Node_Kind := Nkind (N);
Ent : Entity_Id;
Expr : Node_Id;
begin
if Kind = N_Real_Literal then
return Realval (N);
elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
Ent := Entity (N);
pragma Assert (Ekind (Ent) = E_Constant);
return Expr_Value_R (Constant_Value (Ent));
elsif Kind = N_Integer_Literal then
return UR_From_Uint (Expr_Value (N));
elsif Vax_Float (Etype (N))
and then Nkind (N) = N_Unchecked_Type_Conversion
then
Expr := Expression (N);
if Nkind (Expr) = N_Function_Call
and then Present (Parameter_Associations (Expr))
then
Expr := First (Parameter_Associations (Expr));
if Nkind (Expr) = N_Real_Literal then
return Realval (Expr);
end if;
end if;
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
return Ureal_0;
end if;
raise Program_Error;
end Expr_Value_R;
function Expr_Value_S (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_String_Literal then
return N;
else
pragma Assert (Ekind (Entity (N)) = E_Constant);
return Expr_Value_S (Constant_Value (Entity (N)));
end if;
end Expr_Value_S;
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
begin
if Error_Posted (Expr) and then not All_Errors_Mode then
return;
else
Error_Msg_F (Msg, Expr);
Why_Not_Static (Expr);
end if;
end Flag_Non_Static_Expr;
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N, Make_String_Literal (Loc, Strval => Val));
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
end Fold_Str;
procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id := Etype (N);
Ent : Entity_Id;
begin
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Integer
then
Ent := Entity (N);
else
Ent := Empty;
end if;
if Is_Private_Type (Typ) then
Typ := Full_View (Typ);
end if;
if Is_Integer_Type (Typ) then
Rewrite (N, Make_Integer_Literal (Loc, Val));
Set_Original_Entity (N, Ent);
else pragma Assert (Is_Enumeration_Type (Typ));
Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
end if;
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
end Fold_Uint;
procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Ent : Entity_Id;
begin
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Real
then
Ent := Entity (N);
else
Ent := Empty;
end if;
Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
Set_Original_Entity (N, Ent);
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
end Fold_Ureal;
function From_Bits (B : Bits; T : Entity_Id) return Uint is
V : Uint := Uint_0;
begin
for J in 0 .. B'Last loop
if B (J) then
V := V + 2 ** J;
end if;
end loop;
if Non_Binary_Modulus (T) then
V := V mod Modulus (T);
end if;
return V;
end From_Bits;
function Get_String_Val (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_String_Literal then
return N;
elsif Nkind (N) = N_Character_Literal then
return N;
else
pragma Assert (Is_Entity_Name (N));
return Get_String_Val (Constant_Value (Entity (N)));
end if;
end Get_String_Val;
procedure Initialize is
begin
CV_Cache := (others => (Node_High_Bound, Uint_0));
end Initialize;
function In_Subrange_Of
(T1 : Entity_Id;
T2 : Entity_Id;
Fixed_Int : Boolean := False)
return Boolean
is
L1 : Node_Id;
H1 : Node_Id;
L2 : Node_Id;
H2 : Node_Id;
begin
if T1 = T2 or else Is_Subtype_Of (T1, T2) then
return True;
elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
return False;
else
L1 := Type_Low_Bound (T1);
H1 := Type_High_Bound (T1);
L2 := Type_Low_Bound (T2);
H2 := Type_High_Bound (T2);
if Compile_Time_Compare (L1, L2) in Compare_GE
and then
Compile_Time_Compare (H1, H2) in Compare_LE
then
return True;
end if;
if not Compile_Time_Known_Value (L2)
or else not Compile_Time_Known_Value (H2)
then
return False;
end if;
if not Compile_Time_Known_Value (L1) then
L1 := Type_Low_Bound (Base_Type (T1));
end if;
if not Compile_Time_Known_Value (H1) then
H1 := Type_High_Bound (Base_Type (T1));
end if;
if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
then
return
Expr_Value_R (L2) <= Expr_Value_R (L1)
and then
Expr_Value_R (H2) >= Expr_Value_R (H1);
else
return
Expr_Value (L2) <= Expr_Value (L1)
and then
Expr_Value (H2) >= Expr_Value (H1);
end if;
end if;
exception
when others =>
if Debug_Flag_K then
raise;
else
return False;
end if;
end In_Subrange_Of;
function Is_In_Range
(N : Node_Id;
Typ : Entity_Id;
Fixed_Int : Boolean := False;
Int_Real : Boolean := False)
return Boolean
is
Val : Uint;
Valr : Ureal;
begin
if Typ = Universal_Integer or else Typ = Universal_Real then
return True;
elsif not Is_Scalar_Type (Typ) then
return False;
elsif not Compile_Time_Known_Value (N) then
return False;
else
declare
Lo : constant Node_Id := Type_Low_Bound (Typ);
Hi : constant Node_Id := Type_High_Bound (Typ);
LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
begin
if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
if LB_Known and then Valr >= Expr_Value_R (Lo)
and then UB_Known and then Valr <= Expr_Value_R (Hi)
then
return True;
else
return False;
end if;
else
Val := Expr_Value (N);
if LB_Known and then Val >= Expr_Value (Lo)
and then UB_Known and then Val <= Expr_Value (Hi)
then
return True;
else
return False;
end if;
end if;
end;
end if;
end Is_In_Range;
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (Lo);
begin
if not Compile_Time_Known_Value (Lo)
or else not Compile_Time_Known_Value (Hi)
then
return False;
end if;
if Is_Discrete_Type (Typ) then
return Expr_Value (Lo) > Expr_Value (Hi);
else
pragma Assert (Is_Real_Type (Typ));
return Expr_Value_R (Lo) > Expr_Value_R (Hi);
end if;
end Is_Null_Range;
function Is_OK_Static_Expression (N : Node_Id) return Boolean is
begin
return Is_Static_Expression (N)
and then not Raises_Constraint_Error (N);
end Is_OK_Static_Expression;
function Is_OK_Static_Range (N : Node_Id) return Boolean is
begin
return Is_OK_Static_Expression (Low_Bound (N))
and then Is_OK_Static_Expression (High_Bound (N));
end Is_OK_Static_Range;
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
Base_T : constant Entity_Id := Base_Type (Typ);
Anc_Subt : Entity_Id;
begin
if Is_Non_Static_Subtype (Typ) then
return False;
end if;
Anc_Subt := Ancestor_Subtype (Typ);
if Anc_Subt = Empty then
Anc_Subt := Base_T;
end if;
if Is_Generic_Type (Root_Type (Base_T))
or else Is_Generic_Actual_Type (Base_T)
then
return False;
elsif Is_String_Type (Typ) then
return
Ekind (Typ) = E_String_Literal_Subtype
or else
(Is_OK_Static_Subtype (Component_Type (Typ))
and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
elsif Is_Scalar_Type (Typ) then
if Base_T = Typ then
return True;
else
return Is_OK_Static_Subtype (Anc_Subt)
and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
and then Is_OK_Static_Expression (Type_High_Bound (Typ));
end if;
else
return False;
end if;
end Is_OK_Static_Subtype;
function Is_Out_Of_Range
(N : Node_Id;
Typ : Entity_Id;
Fixed_Int : Boolean := False;
Int_Real : Boolean := False)
return Boolean
is
Val : Uint;
Valr : Ureal;
begin
if Typ = Universal_Integer or else Typ = Universal_Real then
return False;
elsif not Is_Scalar_Type (Typ) then
return False;
elsif Is_Generic_Type (Typ) then
return False;
elsif not Compile_Time_Known_Value (N) then
return False;
else
declare
Lo : constant Node_Id := Type_Low_Bound (Typ);
Hi : constant Node_Id := Type_High_Bound (Typ);
LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
begin
if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
if LB_Known and then Valr < Expr_Value_R (Lo) then
return True;
elsif UB_Known and then Expr_Value_R (Hi) < Valr then
return True;
else
return False;
end if;
else
Val := Expr_Value (N);
if LB_Known and then Val < Expr_Value (Lo) then
return True;
elsif UB_Known and then Expr_Value (Hi) < Val then
return True;
else
return False;
end if;
end if;
end;
end if;
end Is_Out_Of_Range;
function Is_Static_Range (N : Node_Id) return Boolean is
begin
return Is_Static_Expression (Low_Bound (N))
and then Is_Static_Expression (High_Bound (N));
end Is_Static_Range;
function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
Base_T : constant Entity_Id := Base_Type (Typ);
Anc_Subt : Entity_Id;
begin
if Is_Non_Static_Subtype (Typ) then
return False;
end if;
Anc_Subt := Ancestor_Subtype (Typ);
if Anc_Subt = Empty then
Anc_Subt := Base_T;
end if;
if Is_Generic_Type (Root_Type (Base_T))
or else Is_Generic_Actual_Type (Base_T)
then
return False;
elsif Is_String_Type (Typ) then
return
Ekind (Typ) = E_String_Literal_Subtype
or else
(Is_Static_Subtype (Component_Type (Typ))
and then Is_Static_Subtype (Etype (First_Index (Typ))));
elsif Is_Scalar_Type (Typ) then
if Base_T = Typ then
return True;
else
return Is_Static_Subtype (Anc_Subt)
and then Is_Static_Expression (Type_Low_Bound (Typ))
and then Is_Static_Expression (Type_High_Bound (Typ));
end if;
else
return False;
end if;
end Is_Static_Subtype;
function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (Lo);
begin
if not Compile_Time_Known_Value (Lo)
or else not Compile_Time_Known_Value (Hi)
then
return False;
end if;
if Is_Discrete_Type (Typ) then
return Expr_Value (Lo) <= Expr_Value (Hi);
else
pragma Assert (Is_Real_Type (Typ));
return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
end if;
end Not_Null_Range;
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
begin
if Bits < 500_000 then
return True;
else
Error_Msg_N ("static value too large, capacity exceeded", N);
return False;
end if;
end OK_Bits;
procedure Out_Of_Range (N : Node_Id) is
begin
if Is_Static_Expression (N)
and then not In_Instance
and then not In_Inlined_Body
and then Ada_Version >= Ada_95
then
if Nkind (Parent (N)) = N_Defining_Identifier
and then Is_Array_Type (Parent (N))
and then Present (Packed_Array_Type (Parent (N)))
and then Present (First_Rep_Item (Parent (N)))
then
Error_Msg_N
("length of packed array must not exceed Integer''Last",
First_Rep_Item (Parent (N)));
Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
else
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}", CE_Range_Check_Failed);
end if;
else
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
end if;
end Out_Of_Range;
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
if Present (Parent (N))
and then Nkind (Parent (N)) = N_Raise_Constraint_Error
then
Set_Condition (Parent (N), Empty);
elsif Nkind (Exp) = N_Raise_Constraint_Error then
Rewrite (N, Exp);
Set_Etype (N, Typ);
else
Rewrite (N,
Make_Raise_Constraint_Error (Sloc (Exp),
Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (N);
Set_Etype (N, Typ);
end if;
end Rewrite_In_Raise_CE;
function String_Type_Len (Stype : Entity_Id) return Uint is
NT : constant Entity_Id := Etype (First_Index (Stype));
T : Entity_Id;
begin
if Is_OK_Static_Subtype (NT) then
T := NT;
else
T := Base_Type (NT);
end if;
return Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1;
end String_Type_Len;
function Subtypes_Statically_Compatible
(T1 : Entity_Id;
T2 : Entity_Id)
return Boolean
is
begin
if Is_Scalar_Type (T1) then
if Subtypes_Statically_Match (T1, T2) then
return True;
elsif not Is_Static_Subtype (T1)
or else not Is_Static_Subtype (T2)
then
return False;
elsif not Is_OK_Static_Subtype (T1)
or else not Is_OK_Static_Subtype (T2)
then
return True;
elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
return False;
else
declare
LB1 : constant Node_Id := Type_Low_Bound (T1);
HB1 : constant Node_Id := Type_High_Bound (T1);
LB2 : constant Node_Id := Type_Low_Bound (T2);
HB2 : constant Node_Id := Type_High_Bound (T2);
begin
if Is_Real_Type (T1) then
return
(Expr_Value_R (LB1) > Expr_Value_R (HB1))
or else
(Expr_Value_R (LB2) <= Expr_Value_R (LB1)
and then
Expr_Value_R (HB1) <= Expr_Value_R (HB2));
else
return
(Expr_Value (LB1) > Expr_Value (HB1))
or else
(Expr_Value (LB2) <= Expr_Value (LB1)
and then
Expr_Value (HB1) <= Expr_Value (HB2));
end if;
end;
end if;
elsif Is_Access_Type (T1) then
return not Is_Constrained (T2)
or else Subtypes_Statically_Match
(Designated_Type (T1), Designated_Type (T2));
else
return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
or else Subtypes_Statically_Match (T1, T2);
end if;
end Subtypes_Statically_Compatible;
function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
begin
if T1 = T2 then
return True;
elsif Is_Scalar_Type (T1) then
if Base_Type (T1) /= Base_Type (T2) then
return False;
end if;
if Is_Numeric_Type (T1)
and then (Is_Constrained (T1) /= Is_Constrained (T2))
and then (Scope (T1) = Standard_Standard
or else Comes_From_Source (T1))
and then (Scope (T2) = Standard_Standard
or else Comes_From_Source (T2))
then
return False;
elsif Is_Generic_Type (T1)
and then Is_Generic_Type (T2)
and then (Is_Constrained (T1) /= Is_Constrained (T2))
then
return False;
end if;
if Error_Posted (Scalar_Range (T1))
or else
Error_Posted (Scalar_Range (T2))
then
return True;
end if;
declare
LB1 : constant Node_Id := Type_Low_Bound (T1);
HB1 : constant Node_Id := Type_High_Bound (T1);
LB2 : constant Node_Id := Type_Low_Bound (T2);
HB2 : constant Node_Id := Type_High_Bound (T2);
begin
if LB1 = LB2 and then HB1 = HB2 then
return True;
else
if not Is_Static_Subtype (T1)
or else not Is_Static_Subtype (T2)
then
return False;
elsif not Is_OK_Static_Subtype (T1)
or else not Is_OK_Static_Subtype (T2)
then
return True;
elsif Is_Real_Type (T1) then
return
(Expr_Value_R (LB1) = Expr_Value_R (LB2))
and then
(Expr_Value_R (HB1) = Expr_Value_R (HB2));
else
return
Expr_Value (LB1) = Expr_Value (LB2)
and then
Expr_Value (HB1) = Expr_Value (HB2);
end if;
end if;
end;
elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
if Has_Discriminants (T1) /= Has_Discriminants (T2) then
return False;
end if;
declare
DL1 : constant Elist_Id := Discriminant_Constraint (T1);
DL2 : constant Elist_Id := Discriminant_Constraint (T2);
DA1 : Elmt_Id := First_Elmt (DL1);
DA2 : Elmt_Id := First_Elmt (DL2);
begin
if DL1 = DL2 then
return True;
elsif Is_Constrained (T1) /= Is_Constrained (T2) then
return False;
end if;
while Present (DA1) loop
declare
Expr1 : constant Node_Id := Node (DA1);
Expr2 : constant Node_Id := Node (DA2);
begin
if not Is_Static_Expression (Expr1)
or else not Is_Static_Expression (Expr2)
then
return False;
elsif Raises_Constraint_Error (Expr1)
or else Raises_Constraint_Error (Expr2)
then
null;
elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
return False;
end if;
end;
Next_Elmt (DA1);
Next_Elmt (DA2);
end loop;
end;
return True;
elsif
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
then
return False;
elsif Is_Array_Type (T1) then
if not Is_Constrained (T1) or else not Is_Constrained (T2) then
return not (Is_Constrained (T1) or else Is_Constrained (T2));
end if;
declare
Index1 : Node_Id := First_Index (T1);
Index2 : Node_Id := First_Index (T2);
begin
while Present (Index1) loop
if not
Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
then
return False;
end if;
Next_Index (Index1);
Next_Index (Index2);
end loop;
return True;
end;
elsif Is_Access_Type (T1) then
return Subtypes_Statically_Match
(Designated_Type (T1),
Designated_Type (T2));
else
return True;
end if;
end Subtypes_Statically_Match;
function Test (Cond : Boolean) return Uint is
begin
if Cond then
return Uint_1;
else
return Uint_0;
end if;
end Test;
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Stat : out Boolean;
Fold : out Boolean)
is
begin
Stat := False;
if Etype (Op1) = Any_Type then
Set_Etype (N, Any_Type);
Fold := False;
return;
elsif Raises_Constraint_Error (Op1) then
Rewrite_In_Raise_CE (N, Op1);
Fold := False;
return;
elsif not Is_Static_Expression (Op1) then
Check_Non_Static_Context (Op1);
Fold := Compile_Time_Known_Value (Op1);
return;
elsif Is_Modular_Integer_Type (Etype (Op1))
and then Is_Generic_Type (Etype (Op1))
then
Check_Non_Static_Context (Op1);
Fold := False;
return;
else
Set_Is_Static_Expression (N);
Fold := True;
Stat := True;
end if;
end Test_Expression_Is_Foldable;
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id;
Stat : out Boolean;
Fold : out Boolean)
is
Rstat : constant Boolean := Is_Static_Expression (Op1)
and then Is_Static_Expression (Op2);
begin
Stat := False;
if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
Set_Etype (N, Any_Type);
Fold := False;
return;
elsif Raises_Constraint_Error (Op1) then
if not Rstat then
Check_Non_Static_Context (Op2);
end if;
Rewrite_In_Raise_CE (N, Op1);
Set_Is_Static_Expression (N, Rstat);
Fold := False;
return;
elsif Raises_Constraint_Error (Op2) then
if not Rstat then
Check_Non_Static_Context (Op1);
end if;
Rewrite_In_Raise_CE (N, Op2);
Set_Is_Static_Expression (N, Rstat);
Fold := False;
return;
elsif Is_Modular_Integer_Type (Etype (Op1))
and then Is_Generic_Type (Etype (Op1))
then
Check_Non_Static_Context (Op1);
Fold := False;
return;
elsif not Rstat then
Check_Non_Static_Context (Op1);
Check_Non_Static_Context (Op2);
Fold := Compile_Time_Known_Value (Op1)
and then Compile_Time_Known_Value (Op2);
return;
else
Set_Is_Static_Expression (N);
Fold := True;
Stat := True;
return;
end if;
end Test_Expression_Is_Foldable;
procedure To_Bits (U : Uint; B : out Bits) is
begin
for J in 0 .. B'Last loop
B (J) := (U / (2 ** J)) mod 2 /= 0;
end loop;
end To_Bits;
procedure Why_Not_Static (Expr : Node_Id) is
N : constant Node_Id := Original_Node (Expr);
Typ : Entity_Id;
E : Entity_Id;
procedure Why_Not_Static_List (L : List_Id);
procedure Why_Not_Static_List (L : List_Id) is
N : Node_Id;
begin
if Is_Non_Empty_List (L) then
N := First (L);
while Present (N) loop
Why_Not_Static (N);
Next (N);
end loop;
end if;
end Why_Not_Static_List;
begin
if Debug_Flag_2 then
return;
end if;
if No (Expr) or else Nkind (Expr) = N_Error then
return;
end if;
if Nkind (Expr) in N_Subexpr then
if Is_OK_Static_Expression (Expr) then
return;
end if;
if Raises_Constraint_Error (Expr) then
Error_Msg_N
("expression raises exception, cannot be static " &
"('R'M 4.9(34))!", N);
return;
end if;
Typ := Etype (Expr);
if No (Typ) then
return;
end if;
if not Is_Scalar_Type (Typ)
and then not Is_String_Type (Typ)
then
Error_Msg_N
("static expression must have scalar or string type " &
"('R'M 4.9(2))!", N);
return;
end if;
end if;
case Nkind (N) is
when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
E := Entity (N);
if Is_Named_Number (E) then
null;
elsif Ekind (E) = E_Constant then
if not Is_Static_Expression (Constant_Value (E)) then
Error_Msg_NE
("& is not a static constant ('R'M 4.9(5))!", N, E);
end if;
else
Error_Msg_NE
("& is not static constant or named number " &
"('R'M 4.9(5))!", N, E);
end if;
when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
("shift functions are never static ('R'M 4.9(6,18))!", N);
else
Why_Not_Static (Left_Opnd (N));
Why_Not_Static (Right_Opnd (N));
end if;
when N_Unary_Op =>
Why_Not_Static (Right_Opnd (N));
when N_Attribute_Reference =>
Why_Not_Static_List (Expressions (N));
E := Etype (Prefix (N));
if E = Standard_Void_Type then
return;
end if;
if Attribute_Name (N) = Name_Size then
Error_Msg_N
("size attribute is only static for scalar type " &
"('R'M 4.9(7,8))", N);
elsif Is_Array_Type (E) then
if Attribute_Name (N) /= Name_First
and then
Attribute_Name (N) /= Name_Last
and then
Attribute_Name (N) /= Name_Length
then
Error_Msg_N
("static array attribute must be Length, First, or Last " &
"('R'M 4.9(8))!", N);
else
Error_Msg_N
("prefix is non-static array ('R'M 4.9(8))!", Prefix (N));
end if;
return;
elsif Is_Generic_Actual_Type (E)
or else
Is_Generic_Type (E)
then
Error_Msg_N
("attribute of generic type is never static " &
"('R'M 4.9(7,8))!", N);
elsif Is_Static_Subtype (E) then
null;
elsif Is_Scalar_Type (E) then
Error_Msg_N
("prefix type for attribute is not static scalar subtype " &
"('R'M 4.9(7))!", N);
else
Error_Msg_N
("static attribute must apply to array/scalar type " &
"('R'M 4.9(7,8))!", N);
end if;
when N_String_Literal =>
Error_Msg_N
("subtype of string literal is non-static ('R'M 4.9(4))!", N);
when N_Explicit_Dereference =>
Error_Msg_N
("explicit dereference is never static ('R'M 4.9)!", N);
when N_Function_Call =>
Why_Not_Static_List (Parameter_Associations (N));
Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N);
when N_Parameter_Association =>
Why_Not_Static (Explicit_Actual_Parameter (N));
when N_Indexed_Component =>
Error_Msg_N
("indexed component is never static ('R'M 4.9)!", N);
when N_Procedure_Call_Statement =>
Error_Msg_N
("procedure call is never static ('R'M 4.9)!", N);
when N_Qualified_Expression =>
Why_Not_Static (Expression (N));
when N_Aggregate | N_Extension_Aggregate =>
Error_Msg_N
("an aggregate is never static ('R'M 4.9)!", N);
when N_Range =>
Why_Not_Static (Low_Bound (N));
Why_Not_Static (High_Bound (N));
when N_Range_Constraint =>
Why_Not_Static (Range_Expression (N));
when N_Subtype_Indication =>
Why_Not_Static (Constraint (N));
when N_Selected_Component =>
Error_Msg_N
("selected component is never static ('R'M 4.9)!", N);
when N_Slice =>
Error_Msg_N
("slice is never static ('R'M 4.9)!", N);
when N_Type_Conversion =>
Why_Not_Static (Expression (N));
if not Is_Scalar_Type (Etype (Prefix (N)))
or else not Is_Static_Subtype (Etype (Prefix (N)))
then
Error_Msg_N
("static conversion requires static scalar subtype result " &
"('R'M 4.9(9))!", N);
end if;
when N_Unchecked_Type_Conversion =>
Error_Msg_N
("unchecked type conversion is never static ('R'M 4.9)!", N);
when others =>
null;
end case;
end Why_Not_Static;
end Sem_Eval;