with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Fixd; use Exp_Fixd;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Validsw; use Validsw;
package body Exp_Ch4 is
procedure Binary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Binary_Op_Validity_Checks);
procedure Expand_Array_Comparison (N : Node_Id);
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
procedure Expand_Boolean_Operator (N : Node_Id);
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
procedure Insert_Dereference_Action (N : Node_Id);
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id;
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id;
procedure Rewrite_Comparison (N : Node_Id);
function Tagged_Membership (N : Node_Id) return Node_Id;
procedure Unary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Unary_Op_Validity_Checks);
procedure Binary_Op_Validity_Checks (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
Ensure_Valid (Left_Opnd (N));
Ensure_Valid (Right_Opnd (N));
end if;
end Binary_Op_Validity_Checks;
procedure Expand_Array_Comparison (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Op1 : Node_Id := Left_Opnd (N);
Op2 : Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
if Chars (N) = Name_Op_Le then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
elsif Chars (N) = Name_Op_Lt then
Func_Body := Make_Array_Comparison_Op (Typ1, N);
Op1 := Right_Opnd (N);
Op2 := Left_Opnd (N);
elsif Chars (N) = Name_Op_Ge then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
else
pragma Assert (Chars (N) = Name_Op_Gt);
Func_Body := Make_Array_Comparison_Op (Typ1, N);
end if;
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Expr :=
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Op1, Op2));
Insert_Action (N, Func_Body);
Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_Array_Comparison;
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Actuals : List_Id;
Decls : List_Id := New_List;
Index_List1 : List_Id := New_List;
Index_List2 : List_Id := New_List;
Formals : List_Id;
Stats : Node_Id;
Func_Name : Entity_Id;
Func_Body : Node_Id;
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
function Component_Equality (Typ : Entity_Id) return Node_Id;
function Loop_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id;
function Component_Equality (Typ : Entity_Id) return Node_Id is
Test : Node_Id;
L, R : Node_Id;
begin
L :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (A)),
Expressions => Index_List1);
R :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (B)),
Expressions => Index_List2);
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
return
Make_Implicit_If_Statement (Nod,
Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end Component_Equality;
function Loop_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id
is
I : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('I'));
J : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('J'));
Index_Type : Entity_Id;
Stats : Node_Id;
begin
if N > Number_Dimensions (Typ) then
return Component_Equality (Typ);
else
Index_Type := Base_Type (Etype (Index));
Append (New_Reference_To (I, Loc), Index_List1);
Append (New_Reference_To (J, Loc), Index_List2);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => J,
Object_Definition => New_Reference_To (Index_Type, Loc)));
Stats :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, N))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (B, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, N)))),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))),
Else_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (B, Loc),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, N)))),
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => I,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => New_List (
Loop_One_Dimension (N + 1, Next_Index (Index)),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_Type, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (J, Loc))))))));
return Stats;
end if;
end Loop_One_Dimension;
begin
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Stats := Loop_One_Dimension (1, First_Index (Typ));
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Stats,
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True);
if Base_Type (A_Typ) /= Base_Type (Typ) then
Actuals := New_List (
OK_Convert_To (Typ, Lhs),
OK_Convert_To (Typ, Rhs));
else
Actuals := New_List (Lhs, Rhs);
end if;
Append_To (Bodies, Func_Body);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => Actuals);
end Expand_Array_Equality;
procedure Expand_Boolean_Operator (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
if Is_Bit_Packed_Array (Typ) then
Expand_Packed_Boolean_Operator (N);
else
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
Ensure_Defined (Etype (L), N);
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations =>
New_List
(L, Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
Analyze_And_Resolve (N, Typ);
end;
end if;
end Expand_Boolean_Operator;
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Full_Type : Entity_Id;
Prim : Elmt_Id;
Eq_Op : Entity_Id;
begin
if Is_Private_Type (Typ) then
Full_Type := Underlying_Type (Typ);
else
Full_Type := Typ;
end if;
if No (Full_Type) then
return New_Reference_To (Standard_False, Loc);
end if;
Full_Type := Base_Type (Full_Type);
if Is_Array_Type (Full_Type) then
if Is_Elementary_Type (Component_Type (Full_Type))
and then not Is_Floating_Point_Type (Component_Type (Full_Type))
then
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
else
return Expand_Array_Equality
(Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
end if;
elsif Is_Tagged_Type (Full_Type) then
if Is_Class_Wide_Type (Full_Type) then
Full_Type := Root_Type (Full_Type);
end if;
if Is_Private_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Controlled (Typ)
and then Is_Derived_Type (Typ)
and then No (Full_View (Typ))
then
Prim := First_Elmt (Collect_Primitive_Operations (Typ));
else
Prim := First_Elmt (Primitive_Operations (Full_Type));
end if;
loop
Eq_Op := Node (Prim);
exit when Chars (Eq_Op) = Name_Op_Eq
and then Etype (First_Formal (Eq_Op)) =
Etype (Next_Formal (First_Formal (Eq_Op)));
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Eq_Op := Node (Prim);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List
(Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
elsif Is_Record_Type (Full_Type) then
Eq_Op := TSS (Full_Type, Name_uEquality);
if Present (Eq_Op) then
if Etype (First_Formal (Eq_Op)) /= Full_Type then
declare
T : Entity_Id := Etype (First_Formal (Eq_Op));
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List (OK_Convert_To (T, Lhs),
OK_Convert_To (T, Rhs)));
end;
else
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations => New_List (Lhs, Rhs));
end if;
else
return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
end if;
else
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
end if;
end Expand_Composite_Equality;
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Nb_Opnds : constant Nat := List_Length (Opnds);
Arr_Typ : constant Entity_Id := Etype (Entity (Cnode));
Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ));
Func_Id : Node_Id;
Func_Spec : Node_Id;
Param_Specs : List_Id;
Func_Body : Node_Id;
Func_Decls : List_Id;
Func_Stmts : List_Id;
L_Decl : Node_Id;
If_Stmt : Node_Id;
Elsif_List : List_Id;
Declare_Block : Node_Id;
Declare_Decls : List_Id;
Declare_Stmts : List_Id;
H_Decl : Node_Id;
H_Init : Node_Id;
P_Decl : Node_Id;
R_Decl : Node_Id;
R_Constr : Node_Id;
R_Range : Node_Id;
Params : List_Id;
Operand : Node_Id;
function Copy_Into_R_S (I : Nat) return List_Id;
function Init_L (I : Nat) return Node_Id;
function H return Node_Id;
function Ind_Val (E : Node_Id) return Node_Id;
function L return Node_Id;
function L_Pos return Node_Id;
function L_Succ return Node_Id;
function One return Node_Id;
function P return Node_Id;
function P_Succ return Node_Id;
function R return Node_Id;
function S (I : Nat) return Node_Id;
function S_First (I : Nat) return Node_Id;
function S_Last (I : Nat) return Node_Id;
function S_Length (I : Nat) return Node_Id;
function S_Length_Test (I : Nat) return Node_Id;
function Copy_Into_R_S (I : Nat) return List_Id is
Stmts : List_Id := New_List;
P_Start : Node_Id;
Loop_Stmt : Node_Id;
R_Copy : Node_Id;
Exit_Stmt : Node_Id;
L_Inc : Node_Id;
P_Inc : Node_Id;
begin
P_Start := Make_Assignment_Statement (Loc,
Name => P,
Expression => S_First (I));
Append_To (Stmts, P_Start);
R_Copy := Make_Assignment_Statement (Loc,
Name => Make_Indexed_Component (Loc,
Prefix => R,
Expressions => New_List (L)),
Expression => Make_Indexed_Component (Loc,
Prefix => S (I),
Expressions => New_List (P)));
L_Inc := Make_Assignment_Statement (Loc,
Name => L,
Expression => L_Succ);
Exit_Stmt := Make_Exit_Statement (Loc,
Condition => Make_Op_Eq (Loc, P, S_Last (I)));
P_Inc := Make_Assignment_Statement (Loc,
Name => P,
Expression => P_Succ);
Loop_Stmt :=
Make_Implicit_Loop_Statement (Cnode,
Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
Append_To (Stmts, Loop_Stmt);
return Stmts;
end Copy_Into_R_S;
function H return Node_Id is
begin
return Make_Identifier (Loc, Name_uH);
end H;
function Ind_Val (E : Node_Id) return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (E));
end Ind_Val;
function Init_L (I : Nat) return Node_Id is
E : Node_Id;
begin
if Is_Constrained (Arr_Typ) then
E := Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Arr_Typ, Loc),
Attribute_Name => Name_First);
else
E := S_First (I);
end if;
return Make_Assignment_Statement (Loc, Name => L, Expression => E);
end Init_L;
function L return Node_Id is
begin
return Make_Identifier (Loc, Name_uL);
end L;
function L_Pos return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (L));
end L_Pos;
function L_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (L));
end L_Succ;
function One return Node_Id is
begin
return Make_Integer_Literal (Loc, 1);
end One;
function P return Node_Id is
begin
return Make_Identifier (Loc, Name_uP);
end P;
function P_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (P));
end P_Succ;
function R return Node_Id is
begin
return Make_Identifier (Loc, Name_uR);
end R;
function S (I : Nat) return Node_Id is
begin
return Make_Identifier (Loc, New_External_Name ('S', I));
end S;
function S_First (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_First);
end S_First;
function S_Last (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Last);
end S_Last;
function S_Length (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Length);
end S_Length;
function S_Length_Test (I : Nat) return Node_Id is
begin
return
Make_Op_Ne (Loc,
Left_Opnd => S_Length (I),
Right_Opnd => Make_Integer_Literal (Loc, 0));
end S_Length_Test;
begin
Param_Specs := New_List;
for I in 1 .. Nb_Opnds loop
Append_To
(Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
Parameter_Type => New_Reference_To (Base_Typ, Loc)));
end loop;
Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Param_Specs,
Subtype_Mark => New_Reference_To (Base_Typ, Loc));
L_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
Func_Decls := New_List (L_Decl);
Elsif_List := New_List;
for I in 2 .. Nb_Opnds - 1 loop
Append_To (Elsif_List, Make_Elsif_Part (Loc,
Condition => S_Length_Test (I),
Then_Statements => New_List (Init_L (I))));
end loop;
If_Stmt :=
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (1),
Then_Statements => New_List (Init_L (1)),
Elsif_Parts => Elsif_List,
Else_Statements => New_List (Make_Return_Statement (Loc,
Expression => S (Nb_Opnds))));
P_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
for I in 2 .. Nb_Opnds loop
H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
end loop;
H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
H_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
Object_Definition => New_Reference_To (Ind_Typ, Loc),
Expression => H_Init);
R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
R_Constr :=
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (R_Range));
R_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Base_Typ, Loc),
Constraint => R_Constr));
Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
Declare_Stmts := New_List;
for I in 1 .. Nb_Opnds loop
Append_To (Declare_Stmts,
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (I),
Then_Statements => Copy_Into_R_S (I)));
end loop;
Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
Declare_Block := Make_Block_Statement (Loc,
Declarations => Declare_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
Func_Stmts := New_List (If_Stmt, Declare_Block);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification => Func_Spec,
Declarations => Func_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
Params := New_List;
Operand := First (Opnds);
for I in 1 .. Nb_Opnds loop
Append_To (Params, Relocate_Node (Operand));
Next (Operand);
end loop;
Rewrite
(Cnode,
Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
Analyze_And_Resolve (Cnode, Base_Typ);
Set_Is_Inlined (Func_Id);
end Expand_Concatenate_Other;
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Opnd1 : constant Node_Id := First (Opnds);
Opnd2 : constant Node_Id := Next (Opnd1);
Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1));
Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2));
R : RE_Id;
begin
case List_Length (Opnds) is
when 2 =>
if Typ1 = Standard_Character then
if Typ2 = Standard_Character then
R := RE_Str_Concat_CC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat_CS;
end if;
elsif Typ1 = Standard_String then
if Typ2 = Standard_Character then
R := RE_Str_Concat_SC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat;
end if;
else
pragma Assert (Serious_Errors_Detected > 0);
return;
end if;
when 3 =>
R := RE_Str_Concat_3;
when 4 =>
R := RE_Str_Concat_4;
when 5 =>
R := RE_Str_Concat_5;
when others =>
R := RE_Null;
raise Program_Error;
end case;
Rewrite (Cnode,
Make_Function_Call (Sloc (Cnode),
Name => New_Occurrence_Of (RTE (R), Loc),
Parameter_Associations => Opnds));
Analyze_And_Resolve (Cnode, Standard_String);
end Expand_Concatenate_String;
procedure Expand_N_Allocator (N : Node_Id) is
PtrT : constant Entity_Id := Etype (N);
Desig : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Temp : Entity_Id;
Node : Node_Id;
begin
Validate_Remote_Access_To_Class_Wide_Type (N);
Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
if Present (Storage_Pool (N)) then
if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
if not Java_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
end if;
end if;
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression
(Expression (N))))
then
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Desig := Subtype_Mark (Expression (N));
if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
end if;
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Aliased_Present => True,
Constant_Present => Is_Access_Constant (PtrT),
Object_Definition => Desig,
Expression => Expression (Expression (N))));
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
Set_Is_Statically_Allocated (Temp);
return;
end if;
if Nkind (Expression (N)) = N_Qualified_Expression then
declare
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
Exp : constant Node_Id := Expression (Expression (N));
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Tag_Assign : Node_Id;
Tmp_Node : Node_Id;
begin
if Is_Tagged_Type (T) or else Controlled_Type (T) then
if not Aggr_In_Place then
Remove_Side_Effects (Exp);
end if;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
Set_Expression (Expression (N),
Unchecked_Convert_To (Entity (Indic), Exp));
Analyze_And_Resolve (Expression (N), Entity (Indic));
end if;
if Aggr_In_Place then
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Node));
end if;
if Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
and then not Java_VM
then
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (T), Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
elsif Is_Private_Type (T)
and then Is_Tagged_Type (Underlying_Type (T))
and then not Java_VM
then
declare
Utyp : constant Entity_Id := Underlying_Type (T);
Ref : constant Node_Id :=
Unchecked_Convert_To (Utyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc)));
begin
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
New_Reference_To (Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Utyp), Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
end;
end if;
if Controlled_Type (Designated_Type (PtrT))
and then Controlled_Type (T)
then
declare
Flist : Node_Id;
Attach : Node_Id;
Apool : constant Entity_Id :=
Associated_Storage_Pool (PtrT);
begin
if Is_RTE (Apool, RE_SS_Pool) then
declare
F : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('F'));
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => F,
Object_Definition => New_Reference_To (RTE
(RE_Finalizable_Ptr), Loc)));
Flist := New_Reference_To (F, Loc);
Attach := Make_Integer_Literal (Loc, 1);
end;
else
Flist := Find_Final_List (PtrT);
Attach := Make_Integer_Literal (Loc, 2);
end if;
if not Aggr_In_Place then
Insert_Actions (N,
Make_Adjust_Call (
Ref =>
Unchecked_Convert_To (T,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc))),
Typ => T,
Flist_Ref => Flist,
With_Attach => Attach));
end if;
end;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Aggr_In_Place then
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Is_Access_Type (Designated_Type (PtrT))
and then Nkind (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then
Apply_Constraint_Check (Expression (Exp),
Designated_Type (Designated_Type (PtrT)),
No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
if Is_Constrained (Designated_Type (PtrT))
and then not Subtypes_Statically_Match
(T, Designated_Type (PtrT))
then
Apply_Constraint_Check
(Exp, Designated_Type (PtrT), No_Sliding => False);
else
Apply_Constraint_Check
(Exp, Designated_Type (PtrT), No_Sliding => True);
end if;
end if;
end;
else
declare
T : constant Entity_Id := Entity (Expression (N));
Init : Entity_Id;
Arg1 : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Elmt_Id;
Flist : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
begin
if No_Initialization (N) then
null;
elsif not Has_Non_Null_Base_Init_Proc (T) then
if Needs_Simple_Initialization (T) then
Rewrite (Expression (N),
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Expression => Get_Simple_Init_Val (T, Loc)));
Analyze_And_Resolve (Expression (Expression (N)), T);
Analyze_And_Resolve (Expression (N), T);
Set_Paren_Count (Expression (Expression (N)), 1);
Expand_N_Allocator (N);
else
null;
end if;
else
Init := Base_Init_Proc (T);
Node := N;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Is_CPP_Class (T) then
Arg1 := New_Reference_To (Temp, Loc);
Temp_Type := T;
else
Arg1 :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
Temp_Type := PtrT;
if Is_Class_Wide_Type (Designated_Type (PtrT)) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
end if;
if Is_Concurrent_Type (T) then
Arg1 :=
Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 :=
Unchecked_Convert_To
(Corresponding_Record_Type (Full_View (T)), Arg1);
elsif Etype (First_Formal (Init)) /= Base_Type (T) then
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
begin
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
Set_Etype (Arg1, Ftyp);
end;
end if;
Args := New_List (Arg1);
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
Expand_N_Full_Type_Declaration
(Parent (Base_Type (PtrT)));
end if;
if Nkind (Parent (N)) = N_Assignment_Statement then
declare
Nam : constant Node_Id := Name (Parent (N));
begin
if Is_Entity_Name (Nam) then
Decls :=
Build_Task_Image_Decls (
Loc,
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif (Nkind (Nam) = N_Indexed_Component
or else Nkind (Nam) = N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then
Decls :=
Build_Task_Image_Decls (
Loc, Defining_Identifier (Parent (N)), T);
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
else
Decls := No_List;
end if;
if Has_Discriminants (T) then
Discr := First_Elmt (Discriminant_Constraint (T));
while Present (Discr) loop
Append (New_Copy (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Discr :=
First_Elmt (Discriminant_Constraint (Full_View (T)));
while Present (Discr) loop
Append (New_Copy (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
end if;
Set_Analyzed (N, True);
Node := Relocate_Node (N);
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Node);
Set_Assignment_OK (Temp_Decl);
if Is_CPP_Class (T) then
Set_Aliased_Present (Temp_Decl);
end if;
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
if Has_Task (T) then
declare
L : List_Id := New_List;
Blk : Node_Id;
begin
Build_Task_Allocate_Block (L, Node, Args);
Blk := Last (L);
Insert_List_Before (First (Declarations (Blk)), Decls);
Insert_Actions (N, L);
end;
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
if Controlled_Type (T) then
if Ekind (PtrT) = E_Anonymous_Access_Type then
declare
Acc : Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('I'));
begin
Insert_Action (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (T, Loc))));
Build_Final_List (N, Acc);
Flist := Find_Final_List (Acc);
end;
else
Flist := Find_Final_List (PtrT);
end if;
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, 2)));
end if;
if Is_CPP_Class (T) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Temp, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Rewrite (N, New_Reference_To (Temp, Loc));
end if;
Analyze_And_Resolve (N, PtrT);
end if;
end;
end if;
end Expand_N_Allocator;
procedure Expand_N_And_Then (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Actlist : List_Id;
begin
if Is_Boolean_Type (Typ) then
Adjust_Condition (Left);
Adjust_Condition (Right);
Set_Etype (N, Standard_Boolean);
end if;
if Nkind (Left) = N_Identifier then
if Entity (Left) = Standard_True then
if Present (Actions (N)) then
Insert_Actions (N, Actions (N));
end if;
Rewrite (N, Right);
Adjust_Result_Type (N, Typ);
return;
elsif Entity (Left) = Standard_False then
Kill_Dead_Code (Right);
Kill_Dead_Code (Actions (N));
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Adjust_Result_Type (N, Typ);
return;
end if;
end if;
if Present (Actions (N)) then
Actlist := Actions (N);
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Left,
Right,
New_Occurrence_Of (Standard_False, Loc))));
Set_Then_Actions (N, Actlist);
Analyze_And_Resolve (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
return;
end if;
if Nkind (Right) = N_Identifier then
if Entity (Right) = Standard_True then
Rewrite (N, Left);
elsif Entity (Right) = Standard_False then
Remove_Side_Effects (Left);
Rewrite
(N, New_Occurrence_Of (Standard_False, Loc));
end if;
end if;
Adjust_Result_Type (N, Typ);
end Expand_N_And_Then;
procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := First (Expressions (N));
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
Cnn : Entity_Id;
New_If : Node_Id;
begin
if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
New_If :=
Make_Implicit_If_Statement (N,
Condition => Relocate_Node (Cond),
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression => Relocate_Node (Thenx))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Relocate_Node (Elsex))));
if Present (Then_Actions (N)) then
Insert_List_Before
(First (Then_Statements (New_If)), Then_Actions (N));
end if;
if Present (Else_Actions (N)) then
Insert_List_Before
(First (Else_Statements (New_If)), Else_Actions (N));
end if;
Rewrite (N, New_Occurrence_Of (Cnn, Loc));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc)));
Insert_Action (N, New_If);
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Conditional_Expression;
procedure Expand_N_Explicit_Dereference (N : Node_Id) is
begin
Insert_Dereference_Action (Prefix (N));
end Expand_N_Explicit_Dereference;
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
begin
if Nkind (Right_Opnd (N)) = N_Range then
return;
else
declare
Typ : Entity_Id := Etype (Right_Opnd (N));
Obj : Node_Id := Left_Opnd (N);
Cond : Node_Id := Empty;
Is_Acc : Boolean := Is_Access_Type (Typ);
begin
Remove_Side_Effects (Obj);
if Is_Tagged_Type (Typ) then
if not Java_VM then
Rewrite (N, Tagged_Membership (N));
Analyze_And_Resolve (N, Rtyp);
end if;
return;
elsif Is_Scalar_Type (Typ) then
Rewrite (Right_Opnd (N),
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Reference_To (Typ, Loc)),
High_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Rtyp);
return;
end if;
if Is_Acc then
Typ := Designated_Type (Typ);
end if;
if not Is_Constrained (Typ) then
Rewrite (N,
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
elsif Is_Array_Type (Typ) then
declare
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id;
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id
is
begin
return
Make_Attribute_Reference (Loc,
Prefix => E,
Attribute_Name => Nam,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)));
end Construct_Attribute_Reference;
begin
for J in 1 .. Number_Dimensions (Typ) loop
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr (Obj), Name_First, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J)));
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr (Obj), Name_Last, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
if Is_Acc then
Cond := Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end;
else
Obj := Relocate_Node (Left_Opnd (N));
if Has_Discriminants (Typ) then
Cond := Make_Op_Not (Loc,
Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
if Is_Acc then
Cond := Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
else
Cond := New_Occurrence_Of (Standard_True, Loc);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end if;
end;
end if;
end Expand_N_In;
procedure Expand_N_Indexed_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
begin
if Nkind (P) = N_Slice then
Rewrite (N,
Make_Indexed_Component (Loc,
Prefix => Prefix (P),
Expressions => New_List (
Convert_To
(Etype (First_Index (Etype (P))),
First (Expressions (N))))));
Analyze_And_Resolve (N, Typ);
return;
end if;
if Is_Access_Type (T) then
Rewrite (P,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (P)));
Analyze_And_Resolve (P, Designated_Type (T));
end if;
if Validity_Checks_On and then Validity_Check_Subscripts then
Apply_Subscript_Validity_Checks (N);
end if;
if not Is_Packed (Etype (Prefix (N))) then
return;
end if;
if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
Expand_Packed_Element_Reference (N);
return;
end if;
declare
Child : Node_Id := N;
Parnt : Node_Id := Parent (N);
begin
loop
if Nkind (Parnt) = N_Unchecked_Expression then
null;
elsif Nkind (Parnt) = N_Object_Renaming_Declaration
or else Nkind (Parnt) = N_Procedure_Call_Statement
or else (Nkind (Parnt) = N_Parameter_Association
and then
Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then (Attribute_Name (Parnt) = Name_Address
or else
Attribute_Name (Parnt) = Name_Size)
and then Prefix (Parnt) = Child
then
return;
elsif Nkind (Parnt) = N_Assignment_Statement
and then Name (Parnt) = Child
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then Attribute_Name (Parnt) = Name_Read
and then Next (First (Expressions (Parnt))) = Child
then
return;
elsif (Nkind (Parnt) = N_Indexed_Component
or else Nkind (Parnt) = N_Selected_Component)
and then Prefix (Parnt) = Child
then
null;
else
Expand_Packed_Element_Reference (N);
return;
end if;
Child := Parnt;
Parnt := Parent (Child);
end loop;
end;
end Expand_N_Indexed_Component;
procedure Expand_N_Not_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_In (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
Analyze_And_Resolve (N, Typ);
end Expand_N_Not_In;
procedure Expand_N_Null (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Agg : Node_Id;
begin
if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
Agg :=
Make_Aggregate (Loc,
Expressions => New_List (
New_Occurrence_Of (RTE (RE_Null_Address), Loc),
Make_Null (Loc)));
Rewrite (N, Agg);
Analyze_And_Resolve (N, Equivalent_Type (Typ));
Set_Etype (N, Typ);
end if;
end Expand_N_Null;
procedure Expand_N_Op_Abs (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Right_Opnd (N);
begin
Unary_Op_Validity_Checks (N);
if not Backend_Overflow_Checks_On_Target
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr (Expr),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Duplicate_Subexpr (Expr),
Make_Op_Minus (Loc,
Right_Opnd => Duplicate_Subexpr (Expr)))));
Analyze_And_Resolve (N);
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Abs;
procedure Expand_N_Op_Add (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Integer_Type (Typ) then
if Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_0
then
Rewrite (N, Left_Opnd (N));
return;
elsif Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_0
then
Rewrite (N, Right_Opnd (N));
return;
end if;
end if;
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
return;
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Add;
procedure Expand_N_Op_And (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
end Expand_N_Op_And;
procedure Expand_N_Op_Concat (N : Node_Id) is
Opnds : List_Id;
Opnd : Node_Id;
Cnode : Node_Id;
Atyp : Entity_Id;
Ctyp : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
if Nkind (Parent (N)) = N_Op_Concat
and then N = Left_Opnd (Parent (N))
then
return;
end if;
Cnode := N;
while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
Cnode := Left_Opnd (Cnode);
end loop;
Outer : loop
Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
Set_Parent (Opnds, N);
Inner : while Cnode /= N
and then (Base_Type (Etype (Cnode)) /= Standard_String
or else
List_Length (Opnds) < 5)
and then Base_Type (Etype (Cnode)) =
Base_Type (Etype (Parent (Cnode)))
loop
Cnode := Parent (Cnode);
Append (Right_Opnd (Cnode), Opnds);
end loop Inner;
Atyp := Base_Type (Etype (Cnode));
Ctyp := Base_Type (Component_Type (Etype (Cnode)));
if List_Length (Opnds) > 2 or else Atyp /= Standard_String then
Opnd := First (Opnds);
loop
if Base_Type (Etype (Opnd)) = Ctyp then
Rewrite (Opnd,
Make_Aggregate (Sloc (Cnode),
Expressions => New_List (Relocate_Node (Opnd))));
Analyze_And_Resolve (Opnd, Atyp);
end if;
Next (Opnd);
exit when No (Opnd);
end loop;
end if;
if Atyp = Standard_String then
Expand_Concatenate_String (Cnode, Opnds);
else
Expand_Concatenate_Other (Cnode, Opnds);
end if;
exit Outer when Cnode = N;
Cnode := Parent (Cnode);
end loop Outer;
end Expand_N_Op_Concat;
procedure Expand_N_Op_Divide (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ltyp : constant Entity_Id := Etype (Left_Opnd (N));
Rtyp : constant Entity_Id := Etype (Right_Opnd (N));
Typ : Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
if Is_Integer_Type (Typ)
and then Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_1
then
Rewrite (N, Left_Opnd (N));
return;
end if;
if Nkind (Right_Opnd (N)) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
then
Rewrite (N,
Make_Op_Shift_Right (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
Analyze_And_Resolve (N, Typ);
return;
end if;
if Typ = Universal_Fixed then
Fixup_Universal_Fixed_Operation (N);
Typ := Etype (N);
end if;
if Is_Fixed_Point_Type (Typ) then
if not Treat_Fixed_As_Integer (N) then
if Is_Integer_Type (Rtyp) then
Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
else
Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
end if;
end if;
elsif (Is_Fixed_Point_Type (Ltyp) or else
Is_Fixed_Point_Type (Rtyp))
and then not Treat_Fixed_As_Integer (N)
then
if Is_Integer_Type (Typ) then
Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Typ));
Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
end if;
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
then
Rewrite (Right_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
elsif Typ = Universal_Real
and then Is_Integer_Type (Ltyp)
then
Rewrite (Left_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N);
end if;
end Expand_N_Op_Divide;
procedure Expand_N_Op_Eq (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Lhs : constant Node_Id := Left_Opnd (N);
Rhs : constant Node_Id := Right_Opnd (N);
A_Typ : Entity_Id := Etype (Lhs);
Typl : Entity_Id := A_Typ;
Op_Name : Entity_Id;
Prim : Elmt_Id;
Bodies : List_Id := New_List;
procedure Build_Equality_Call (Eq : Entity_Id);
procedure Build_Equality_Call (Eq : Entity_Id) is
Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
L_Exp : Node_Id := Relocate_Node (Lhs);
R_Exp : Node_Id := Relocate_Node (Rhs);
begin
if Base_Type (Op_Type) /= Base_Type (A_Typ)
and then not Is_Class_Wide_Type (A_Typ)
then
L_Exp := OK_Convert_To (Op_Type, L_Exp);
R_Exp := OK_Convert_To (Op_Type, R_Exp);
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Eq, Loc),
Parameter_Associations => New_List (L_Exp, R_Exp)));
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Build_Equality_Call;
begin
Binary_Op_Validity_Checks (N);
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then
Typl := Underlying_Type (Base_Type (Typl));
end if;
if No (Typl) then
return;
end if;
Typl := Base_Type (Typl);
if Vax_Float (Typl) then
Expand_Vax_Comparison (N);
return;
elsif Is_Boolean_Type (Typl) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
elsif Is_Array_Type (Typl) then
if Is_Bit_Packed_Array (Typl) then
Expand_Packed_Eq (N);
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not No_Run_Time
then
null;
else
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
elsif Is_Record_Type (Typl) then
if Is_Tagged_Type (Typl) then
if Is_Private_Type (A_Typ)
and then not Is_Tagged_Type (A_Typ)
and then Is_Derived_Type (A_Typ)
and then No (Full_View (A_Typ))
then
Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
while Chars (Node (Prim)) /= Name_Op_Eq loop
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Op_Name := Node (Prim);
else
Op_Name := Find_Prim_Op (Typl, Name_Op_Eq);
end if;
Build_Equality_Call (Op_Name);
elsif Present (TSS (Root_Type (Typl), Name_uEquality)) then
Build_Equality_Call (TSS (Root_Type (Typl), Name_uEquality));
else
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
Rewrite (N,
Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
end if;
if Nkind (N) = N_Op_Eq then
Rewrite_Comparison (N);
end if;
end Expand_N_Op_Eq;
procedure Expand_N_Op_Expon (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Rtyp : constant Entity_Id := Root_Type (Typ);
Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
Bastyp : constant Node_Id := Etype (Base);
Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
Exptyp : constant Entity_Id := Etype (Exp);
Ovflo : constant Boolean := Do_Overflow_Check (N);
Expv : Uint;
Xnode : Node_Id;
Temp : Node_Id;
Rent : RE_Id;
Ent : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
if Is_Private_Type (Etype (Base))
or else
Is_Private_Type (Typ)
or else
Is_Private_Type (Exptyp)
or else
Rtyp /= Root_Type (Bastyp)
then
declare
Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
begin
Rewrite (N,
Unchecked_Convert_To (Typ,
Make_Op_Expon (Loc,
Left_Opnd => Unchecked_Convert_To (Bt, Base),
Right_Opnd => Unchecked_Convert_To (Et, Exp))));
Analyze_And_Resolve (N, Typ);
return;
end;
end if;
if Compile_Time_Known_Value (Exp) then
Expv := Expr_Value (Exp);
if Expv >= 0 and then Expv <= 4 then
if Expv = 0 then
if Ekind (Typ) in Integer_Kind then
Xnode := Make_Integer_Literal (Loc, Intval => 1);
else
Xnode := Make_Real_Literal (Loc, Ureal_1);
end if;
elsif Expv = 1 then
Xnode := Base;
elsif Expv = 2 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base));
elsif Expv = 3 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base)),
Right_Opnd => Duplicate_Subexpr (Base));
else Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Typ, Loc),
Expression =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base)))));
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => New_Reference_To (Temp, Loc),
Right_Opnd => New_Reference_To (Temp, Loc));
end if;
Rewrite (N, Xnode);
Analyze_And_Resolve (N, Typ);
return;
end if;
end if;
if Nkind (Base) = N_Integer_Literal
and then Intval (Base) = 2
and then Is_Integer_Type (Root_Type (Exptyp))
and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
and then Is_Unsigned_Type (Exptyp)
and then not Ovflo
and then Nkind (Parent (N)) in N_Binary_Op
then
declare
P : constant Node_Id := Parent (N);
L : constant Node_Id := Left_Opnd (P);
R : constant Node_Id := Right_Opnd (P);
begin
if (Nkind (P) = N_Op_Multiply
and then
((Is_Integer_Type (Etype (L)) and then R = N)
or else
(Is_Integer_Type (Etype (R)) and then L = N))
and then not Do_Overflow_Check (P))
or else
(Nkind (P) = N_Op_Divide
and then Is_Integer_Type (Etype (L))
and then Is_Unsigned_Type (Etype (L))
and then R = N
and then not Do_Overflow_Check (P))
then
Set_Is_Power_Of_2_For_Shift (N);
return;
end if;
end;
end if;
if No_Run_Time then
Disallow_In_No_Run_Time_Mode (N);
return;
end if;
if Is_Modular_Integer_Type (Rtyp) then
if Non_Binary_Modulus (Rtyp) then
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
Parameter_Associations => New_List (
Convert_To (Standard_Integer, Base),
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Exp))));
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Ent := RTE (RE_Exp_Unsigned);
else
Ent := RTE (RE_Exp_Long_Long_Unsigned);
end if;
Rewrite (N,
Convert_To (Typ,
Make_Op_And (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name => New_Reference_To (Ent, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Ent)), Base),
Exp)),
Right_Opnd =>
Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
end if;
Analyze_And_Resolve (N, Typ);
return;
elsif Rtyp = Base_Type (Standard_Integer) then
if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Short_Integer) then
if Ovflo then
Rent := RE_Exp_Short_Integer;
else
Rent := RE_Exn_Short_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then
if Ovflo then
Rent := RE_Exp_Short_Short_Integer;
else
Rent := RE_Exn_Short_Short_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Long_Integer) then
if Ovflo then
Rent := RE_Exp_Long_Integer;
else
Rent := RE_Exn_Long_Integer;
end if;
elsif (Rtyp = Base_Type (Standard_Long_Long_Integer)
or else Rtyp = Universal_Integer)
then
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
elsif Rtyp = Standard_Float then
if Ovflo then
Rent := RE_Exp_Float;
else
Rent := RE_Exn_Float;
end if;
elsif Rtyp = Standard_Short_Float then
if Ovflo then
Rent := RE_Exp_Short_Float;
else
Rent := RE_Exn_Short_Float;
end if;
elsif Rtyp = Standard_Long_Float then
if Ovflo then
Rent := RE_Exp_Long_Float;
else
Rent := RE_Exn_Long_Float;
end if;
else
pragma Assert
(Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real);
if Ovflo then
Rent := RE_Exp_Long_Long_Float;
else
Rent := RE_Exn_Long_Long_Float;
end if;
end if;
if Typ = Rtyp
and then Rtyp /= Universal_Integer
and then Rtyp /= Universal_Real
then
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (Base, Exp)));
else
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (
Convert_To (Rtyp, Base),
Exp))));
end if;
Analyze_And_Resolve (N, Typ);
return;
end Expand_N_Op_Expon;
procedure Expand_N_Op_Ge (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Ge;
procedure Expand_N_Op_Gt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Gt;
procedure Expand_N_Op_Le (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Le;
procedure Expand_N_Op_Lt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Lt;
procedure Expand_N_Op_Minus (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Unary_Op_Validity_Checks (N);
if not Backend_Overflow_Checks_On_Target
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
Rewrite (N,
Make_Op_Subtract (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 0),
Right_Opnd => Right_Opnd (N)));
Analyze_And_Resolve (N, Typ);
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Minus;
procedure Expand_N_Op_Mod (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
T : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
DOC : constant Boolean := Do_Overflow_Check (N);
DDC : constant Boolean := Do_Division_Check (N);
LLB : Uint;
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
begin
Binary_Op_Validity_Checks (N);
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
if LOK and then Llo >= 0
and then
ROK and then Rlo >= 0
then
Rewrite (N,
Make_Op_Rem (Sloc (N),
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N)));
Set_Entity (N, Standard_Entity (S_Op_Rem));
Set_Etype (N, T);
Set_Do_Overflow_Check (N, DOC);
Set_Do_Division_Check (N, DDC);
Expand_N_Op_Rem (N);
Set_Analyzed (N);
else
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Check (N);
end if;
LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
((not LOK) or else (Llo = LLB))
then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1)),
Make_Integer_Literal (Loc, Uint_0),
Relocate_Node (N))));
Set_Analyzed (Next (Next (First (Expressions (N)))));
Analyze_And_Resolve (N, T);
end if;
end if;
end Expand_N_Op_Mod;
procedure Expand_N_Op_Multiply (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
Ltyp : constant Entity_Id := Etype (Lop);
Rtyp : constant Entity_Id := Etype (Rop);
Typ : Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Integer_Type (Typ) then
if (Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_0)
or else
(Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_0)
then
Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
Analyze_And_Resolve (N, Typ);
return;
end if;
if Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_1
then
Rewrite (N, Left_Opnd (N));
return;
elsif Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_1
then
Rewrite (N, Right_Opnd (N));
return;
end if;
end if;
if Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
if Nkind (Rop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Rop)
then
if Nkind (Lop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Lop)
then
Rewrite (N,
Make_Op_Expon (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Right_Opnd (Lop),
Right_Opnd => Right_Opnd (Rop))));
Analyze_And_Resolve (N, Typ);
return;
else
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Lop,
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Rop))));
Analyze_And_Resolve (N, Typ);
return;
end if;
elsif Nkind (Lop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Lop)
then
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Rop,
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Lop))));
Analyze_And_Resolve (N, Typ);
return;
end if;
if Typ = Universal_Fixed then
Fixup_Universal_Fixed_Operation (N);
Typ := Etype (N);
end if;
if Is_Fixed_Point_Type (Typ) then
if not Treat_Fixed_As_Integer (N) then
if Is_Integer_Type (Rtyp) then
Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
elsif Is_Integer_Type (Ltyp) then
Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
else
Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
end if;
end if;
elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
and then not Treat_Fixed_As_Integer (N)
then
if Is_Integer_Type (Typ) then
Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Typ));
Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
end if;
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
then
Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
Analyze_And_Resolve (Rop, Universal_Real);
elsif Typ = Universal_Real
and then Is_Integer_Type (Ltyp)
then
Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
Analyze_And_Resolve (Lop, Universal_Real);
elsif Is_Signed_Integer_Type (Etype (N)) then
Apply_Arithmetic_Overflow_Check (N);
end if;
end Expand_N_Op_Multiply;
procedure Expand_N_Op_Ne (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Neg : Node_Id;
Ne : constant Entity_Id := Entity (N);
begin
Binary_Op_Validity_Checks (N);
Neg :=
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N)));
Set_Paren_Count (Right_Opnd (Neg), 1);
if Scope (Ne) /= Standard_Standard then
Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
end if;
Rewrite (N, Neg);
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Op_Ne;
procedure Expand_N_Op_Not (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Opnd : Node_Id;
Arr : Entity_Id;
A : Entity_Id;
B : Entity_Id;
J : Entity_Id;
A_J : Node_Id;
B_J : Node_Id;
Func_Name : Entity_Id;
Loop_Statement : Node_Id;
begin
Unary_Op_Validity_Checks (N);
if Is_Boolean_Type (Typ) then
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
return;
end if;
if not Is_Array_Type (Typ) then
return;
end if;
if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
Expand_Packed_Not (N);
return;
end if;
Opnd := Relocate_Node (Right_Opnd (N));
Convert_To_Actual_Subtype (Opnd);
Arr := Etype (Opnd);
Ensure_Defined (Arr, N);
A := Make_Defining_Identifier (Loc, Name_uA);
B := Make_Defining_Identifier (Loc, Name_uB);
J := Make_Defining_Identifier (Loc, Name_uJ);
A_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (A, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
B_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (B, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
Loop_Statement :=
Make_Implicit_Loop_Statement (N,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Chars (A)),
Attribute_Name => Name_Range))),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => B_J,
Expression => Make_Op_Not (Loc, A_J))));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
Set_Is_Inlined (Func_Name);
Insert_Action (N,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc))),
Subtype_Mark => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Arr, Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression =>
Make_Identifier (Loc, Chars (B)))))));
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Opnd)));
Analyze_And_Resolve (N, Typ);
end Expand_N_Op_Not;
procedure Expand_N_Op_Or (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
end Expand_N_Op_Or;
procedure Expand_N_Op_Plus (N : Node_Id) is
begin
Unary_Op_Validity_Checks (N);
end Expand_N_Op_Plus;
procedure Expand_N_Op_Rem (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
LLB : Uint;
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
Typ : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Check (N);
end if;
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
Typ := Etype (N);
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
((not LOK) or else (Llo = LLB))
then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1)),
Make_Integer_Literal (Loc, Uint_0),
Relocate_Node (N))));
Set_Analyzed (Next (Next (First (Expressions (N)))));
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Op_Rem;
procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Rotate_Left;
procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Rotate_Right;
procedure Expand_N_Op_Shift_Left (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Left;
procedure Expand_N_Op_Shift_Right (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Right;
procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Right_Arithmetic;
procedure Expand_N_Op_Subtract (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Integer_Type (Typ)
and then Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = 0
then
Rewrite (N, Left_Opnd (N));
return;
end if;
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Subtract;
procedure Expand_N_Op_Xor (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
end Expand_N_Op_Xor;
procedure Expand_N_Or_Else (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Actlist : List_Id;
begin
if Is_Boolean_Type (Typ) then
Adjust_Condition (Left);
Adjust_Condition (Right);
Set_Etype (N, Standard_Boolean);
elsif Nkind (Left) = N_Identifier then
if Entity (Left) = Standard_False then
if Present (Actions (N)) then
Insert_Actions (N, Actions (N));
end if;
Rewrite (N, Right);
Adjust_Result_Type (N, Typ);
return;
elsif Entity (Left) = Standard_True then
Kill_Dead_Code (Right);
Kill_Dead_Code (Actions (N));
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
Adjust_Result_Type (N, Typ);
return;
end if;
end if;
if Present (Actions (N)) then
Actlist := Actions (N);
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Left,
New_Occurrence_Of (Standard_True, Loc),
Right)));
Set_Else_Actions (N, Actlist);
Analyze_And_Resolve (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
return;
end if;
if Nkind (Right) = N_Identifier then
if Entity (Right) = Standard_False then
Rewrite (N, Left);
elsif Entity (Right) = Standard_True then
Remove_Side_Effects (Left);
Rewrite
(N, New_Occurrence_Of (Standard_True, Loc));
end if;
end if;
Adjust_Result_Type (N, Typ);
end Expand_N_Or_Else;
procedure Expand_N_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
begin
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
end Expand_N_Qualified_Expression;
procedure Expand_N_Selected_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Parent (N);
P : constant Node_Id := Prefix (N);
Disc : Entity_Id;
Ptyp : Entity_Id := Underlying_Type (Etype (P));
New_N : Node_Id;
function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
begin
return
(Nkind (Parent (Comp)) = N_Assignment_Statement
and then Comp = Name (Parent (Comp)))
or else
(Present (Parent (Comp))
and then Nkind (Parent (Comp)) in N_Subexpr
and then In_Left_Hand_Side (Parent (Comp)));
end In_Left_Hand_Side;
begin
if Do_Discriminant_Check (N) then
Add_Inlined_Body
(Discriminant_Checking_Func
(Original_Record_Component (Entity (Selector_Name (N)))));
end if;
if Is_Access_Type (Ptyp) then
Insert_Dereference_Action (P);
return;
end if;
if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
and then Has_Discriminants (Etype (N))
and then not In_Left_Hand_Side (N)
then
Force_Evaluation (Prefix (N));
end if;
if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
if Is_Record_Type (Ptyp)
and then Has_Discriminants (Ptyp)
and then Is_Constrained (Ptyp)
and then Is_Discrete_Type (Etype (N))
and then (Nkind (Par) /= N_Assignment_Statement
or else Name (Par) /= N)
and then (Nkind (Par) /= N_Attribute_Reference
or else Prefix (Par) /= N)
and then not Is_Renamed_Object (N)
then
declare
D : Entity_Id;
E : Elmt_Id;
begin
D := First_Discriminant (Ptyp);
E := First_Elmt (Discriminant_Constraint (Ptyp));
while Present (E) loop
if D = Entity (Selector_Name (N)) then
if Nkind (Parent (N)) = N_Case_Statement
and then Etype (Node (E)) /= Etype (D)
then
Rewrite (N,
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
Expression => New_Copy (Node (E))));
Analyze (N);
else
Rewrite (N, New_Copy (Node (E)));
end if;
Set_Is_Static_Expression (N, False);
return;
end if;
Next_Elmt (E);
Next_Discriminant (D);
end loop;
end;
end if;
if not Is_Concurrent_Type (Ptyp) then
return;
end if;
Disc := Entity (Selector_Name (N));
if Is_Derived_Type (Ptyp)
and then Present (Corresponding_Discriminant (Disc))
then
Disc := Corresponding_Discriminant (Disc);
end if;
New_N :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
New_Copy_Tree (P)),
Selector_Name => Make_Identifier (Loc, Chars (Disc)));
Rewrite (N, New_N);
Analyze (N);
end if;
end Expand_N_Selected_Component;
procedure Expand_N_Slice (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx);
Ent : Entity_Id;
Decl : Node_Id;
begin
if Is_Access_Type (Ptp) then
Insert_Dereference_Action (Pfx);
Ptp := Designated_Type (Ptp);
if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
Rewrite (Pfx,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (Pfx)));
Analyze_And_Resolve (Pfx, Ptp);
Set_Do_Access_Check (N, False);
end if;
end if;
if not Index_Checks_Suppressed (Ptp)
and then (not Is_Entity_Name (Pfx)
or else not Index_Checks_Suppressed (Entity (Pfx)))
and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
then
Enable_Range_Check (Discrete_Range (N));
end if;
if Is_Packed (Typ)
and then Nkind (Parent (N)) /= N_Assignment_Statement
and then Nkind (Parent (N)) /= N_Indexed_Component
and then not Is_Renamed_Object (N)
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else
Attribute_Name (Parent (N)) /= Name_Address)
then
Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Set_No_Initialization (Decl);
Insert_Actions (N, New_List (
Decl,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Expression => Relocate_Node (N))));
Rewrite (N, New_Occurrence_Of (Ent, Loc));
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Slice;
procedure Expand_N_Type_Conversion (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Etype (N);
Operand_Type : Entity_Id := Etype (Operand);
procedure Handle_Changed_Representation;
procedure Real_Range_Check;
procedure Handle_Changed_Representation is
Temp : Entity_Id;
Decl : Node_Id;
Odef : Node_Id;
Disc : Node_Id;
N_Ix : Node_Id;
Cons : List_Id;
begin
if Same_Representation (Operand_Type, Target_Type) then
return;
elsif Nkind (Parent (N)) = N_Assignment_Statement then
return;
else
Cons := No_List;
if not Is_Constrained (Target_Type) then
if Has_Discriminants (Operand_Type) then
Disc := First_Discriminant (Operand_Type);
Cons := New_List;
while Present (Disc) loop
Append_To (Cons,
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Operand),
Selector_Name =>
Make_Identifier (Loc, Chars (Disc))));
Next_Discriminant (Disc);
end loop;
elsif Is_Array_Type (Operand_Type) then
N_Ix := First_Index (Target_Type);
Cons := New_List;
for J in 1 .. Number_Dimensions (Operand_Type) loop
Append_To (Cons,
Make_Range (Loc,
Low_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr
(Operand, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))),
High_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr
(Operand, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J))))));
Next_Index (N_Ix);
end loop;
end if;
end if;
Odef := New_Occurrence_Of (Target_Type, Loc);
if Present (Cons) then
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => Odef,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cons));
end if;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Odef);
Set_No_Initialization (Decl, True);
Insert_Actions (N,
New_List (
Decl,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp, Loc),
Expression => Relocate_Node (N))),
Suppress => All_Checks);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
return;
end if;
end Handle_Changed_Representation;
procedure Real_Range_Check is
Btyp : constant Entity_Id := Base_Type (Target_Type);
Lo : constant Node_Id := Type_Low_Bound (Target_Type);
Hi : constant Node_Id := Type_High_Bound (Target_Type);
Conv : Node_Id;
Tnn : Entity_Id;
begin
if Nkind (N) /= N_Type_Conversion then
return;
end if;
if Range_Checks_Suppressed (Target_Type)
or else (Lo = Type_Low_Bound (Btyp)
and then
Hi = Type_High_Bound (Btyp))
then
return;
end if;
if Is_Entity_Name (Expression (N))
and then Range_Checks_Suppressed (Entity (Expression (N)))
then
return;
end if;
Conv := Relocate_Node (N);
Rewrite
(Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp);
if not Is_Integer_Type (Etype (Expression (N))) then
Set_Do_Overflow_Check (Conv, True);
end if;
Tnn :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Btyp, Loc),
Expression => Conv),
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix =>
New_Occurrence_Of (Target_Type, Loc))),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix =>
New_Occurrence_Of (Target_Type, Loc)))),
Reason => CE_Range_Check_Failed)));
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
Analyze_And_Resolve (N, Btyp);
end Real_Range_Check;
begin
if Operand_Type = Target_Type then
Rewrite (N, Relocate_Node (Expression (N)));
return;
end if;
if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
Expand_Vax_Conversion (N);
return;
end if;
if Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Read
and then Next (First (Expressions (Parent (N)))) = N
then
return;
end if;
if Is_Boolean_Type (Operand_Type)
and then (Nonzero_Is_True (Operand_Type))
then
Adjust_Condition (Operand);
Set_Etype (Operand, Standard_Boolean);
Operand_Type := Standard_Boolean;
end if;
if Is_Access_Type (Target_Type) then
if Is_Entity_Name (Operand)
and then Ekind (Entity (Operand)) in Formal_Kind
and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
then
Apply_Accessibility_Check (Operand, Target_Type);
elsif In_Instance_Body
and then Type_Access_Level (Operand_Type) >
Type_Access_Level (Target_Type)
then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
elsif In_Instance_Body
and then Ekind (Operand_Type) = E_Anonymous_Access_Type
and then Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
end if;
end if;
if (Is_Access_Type (Target_Type)
and then Is_Tagged_Type (Designated_Type (Target_Type)))
or else Is_Tagged_Type (Target_Type)
then
if Is_Access_Type (Target_Type)
and then Is_Renamed_Object (N)
then
return;
end if;
declare
Actual_Operand_Type : Entity_Id;
Actual_Target_Type : Entity_Id;
Cond : Node_Id;
begin
if Is_Access_Type (Target_Type) then
Actual_Operand_Type := Designated_Type (Operand_Type);
Actual_Target_Type := Designated_Type (Target_Type);
else
Actual_Operand_Type := Operand_Type;
Actual_Target_Type := Target_Type;
end if;
if Is_Class_Wide_Type (Actual_Operand_Type)
and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type
and then Is_Ancestor
(Root_Type (Actual_Operand_Type),
Actual_Target_Type)
and then not Tag_Checks_Suppressed (Actual_Target_Type)
then
Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
if Is_Access_Type (Target_Type) then
Cond :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd => Duplicate_Subexpr (Operand),
Right_Opnd => Make_Null (Loc)),
Right_Opnd =>
Make_Not_In (Loc,
Left_Opnd =>
Make_Explicit_Dereference (Loc,
Prefix => Duplicate_Subexpr (Operand)),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc)));
else
Cond :=
Make_Not_In (Loc,
Left_Opnd => Duplicate_Subexpr (Operand),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc));
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Tag_Check_Failed));
Change_Conversion_To_Unchecked (N);
Analyze_And_Resolve (N, Target_Type);
end if;
end;
elsif Is_Access_Type (Target_Type) then
Apply_Constraint_Check (Operand, Target_Type);
elsif Is_Fixed_Point_Type (Operand_Type)
and then not Conversion_OK (N)
then
pragma Assert (Operand_Type /= Universal_Fixed);
if Target_Type = Universal_Real
and then Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Round
then
Set_Rounded_Result (N);
Set_Etype (N, Etype (Parent (N)));
end if;
if not Conversion_OK (N) then
if Is_Fixed_Point_Type (Etype (N)) then
Expand_Convert_Fixed_To_Fixed (N);
Real_Range_Check;
elsif Is_Integer_Type (Etype (N)) then
Expand_Convert_Fixed_To_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Etype (N)));
Expand_Convert_Fixed_To_Float (N);
Real_Range_Check;
end if;
end if;
elsif Is_Fixed_Point_Type (Target_Type)
and then not Conversion_OK (N)
then
if Is_Integer_Type (Operand_Type) then
Expand_Convert_Integer_To_Fixed (N);
Real_Range_Check;
else
pragma Assert (Is_Floating_Point_Type (Operand_Type));
Expand_Convert_Float_To_Fixed (N);
Real_Range_Check;
end if;
elsif Is_Floating_Point_Type (Operand_Type)
and then
(Is_Integer_Type (Target_Type)
or else
(Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
then
if Nkind (Operand) = N_Attribute_Reference
and then Attribute_Name (Operand) = Name_Truncation
then
Rewrite (Operand,
Relocate_Node (First (Expressions (Operand))));
Set_Float_Truncate (N, True);
end if;
if Do_Range_Check (Expression (N)) then
Rewrite (Expression (N),
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Standard_Long_Long_Float, Loc),
Expression =>
Relocate_Node (Expression (N))));
Set_Etype (Expression (N), Standard_Long_Long_Float);
Enable_Range_Check (Expression (N));
Set_Do_Range_Check (Expression (Expression (N)), False);
end if;
elsif Is_Array_Type (Target_Type) then
if Is_Constrained (Target_Type) then
Apply_Length_Check (Operand, Target_Type);
else
Apply_Range_Check (Operand, Target_Type);
end if;
Handle_Changed_Representation;
elsif Has_Discriminants (Target_Type)
and then Is_Constrained (Target_Type)
then
Apply_Discriminant_Check (Operand, Target_Type);
Handle_Changed_Representation;
elsif Is_Record_Type (Target_Type) then
Handle_Changed_Representation;
elsif Is_Enumeration_Type (Target_Type) then
if not Same_Representation (Target_Type, Operand_Type) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Target_Type, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Operand_Type, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Operand)))));
Analyze_And_Resolve (N, Target_Type);
end if;
elsif Is_Floating_Point_Type (Target_Type) then
Real_Range_Check;
else
null;
end if;
end Expand_N_Type_Conversion;
procedure Expand_N_Unchecked_Expression (N : Node_Id) is
Exp : constant Node_Id := Expression (N);
begin
Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
Rewrite (N, Exp);
end Expand_N_Unchecked_Expression;
procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N);
Operand_Type : constant Entity_Id := Etype (Operand);
begin
if Is_Integer_Type (Target_Type)
and then Is_Integer_Type (Operand_Type)
and then Compile_Time_Known_Value (Operand)
and then not Kill_Range_Check (N)
then
declare
Val : constant Uint := Expr_Value (Operand);
begin
if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
and then
Compile_Time_Known_Value (Type_High_Bound (Target_Type))
and then
Val >= Expr_Value (Type_Low_Bound (Target_Type))
and then
Val <= Expr_Value (Type_High_Bound (Target_Type))
then
Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
Analyze_And_Resolve (N, Target_Type);
return;
end if;
end;
end if;
if Safe_Unchecked_Type_Conversion (N) then
return;
end if;
if Assignment_OK (N) then
null;
else
Force_Evaluation (N);
end if;
end Expand_N_Unchecked_Type_Conversion;
function Expand_Record_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
function Suitable_Element (C : Entity_Id) return Entity_Id;
function Suitable_Element (C : Entity_Id) return Entity_Id is
begin
if No (C) then
return Empty;
elsif Ekind (C) /= E_Discriminant
and then Ekind (C) /= E_Component
then
return Suitable_Element (Next_Entity (C));
elsif Is_Tagged_Type (Typ)
and then C /= Original_Record_Component (C)
then
return Suitable_Element (Next_Entity (C));
elsif Chars (C) = Name_uController
or else Chars (C) = Name_uTag
then
return Suitable_Element (Next_Entity (C));
else
return C;
end if;
end Suitable_Element;
Result : Node_Id;
C : Entity_Id;
First_Time : Boolean := True;
begin
if Is_Unchecked_Union (Typ) then
if No (Parent (Lhs)) then
Result :=
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction);
Set_Etype (Result, Standard_Boolean);
return Result;
else
Insert_Action (Lhs,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
return New_Occurrence_Of (Standard_True, Loc);
end if;
end if;
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
while Present (C) loop
declare
New_Lhs : Node_Id;
New_Rhs : Node_Id;
begin
if First_Time then
First_Time := False;
New_Lhs := Lhs;
New_Rhs := Rhs;
else
New_Lhs := New_Copy_Tree (Lhs);
New_Rhs := New_Copy_Tree (Rhs);
end if;
Result :=
Make_And_Then (Loc,
Left_Opnd => Result,
Right_Opnd =>
Expand_Composite_Equality (Nod, Etype (C),
Lhs =>
Make_Selected_Component (Loc,
Prefix => New_Lhs,
Selector_Name => New_Reference_To (C, Loc)),
Rhs =>
Make_Selected_Component (Loc,
Prefix => New_Rhs,
Selector_Name => New_Reference_To (C, Loc)),
Bodies => Bodies));
end;
C := Suitable_Element (Next_Entity (C));
end loop;
return Result;
end Expand_Record_Equality;
procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
Conv : constant Node_Id := Parent (N);
begin
pragma Assert (Nkind (Conv) = N_Type_Conversion);
if Nkind (Parent (Conv)) = N_Attribute_Reference
and then Attribute_Name (Parent (Conv)) = Name_Round
then
Set_Etype (N, Etype (Parent (Conv)));
Set_Rounded_Result (N);
else
Set_Etype (N, Etype (Conv));
end if;
end Fixup_Universal_Fixed_Operation;
procedure Insert_Dereference_Action (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
T : Entity_Id;
begin
if No (P) then
return False;
end if;
T := Etype (P);
while T /= Etype (T) loop
if Is_RTE (T, RE_Checked_Pool) then
return True;
else
T := Etype (T);
end if;
end loop;
return False;
end Is_Checked_Storage_Pool;
begin
if not Comes_From_Source (Parent (N)) then
return;
elsif not Is_Checked_Storage_Pool (Pool) then
return;
end if;
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
Parameter_Associations => New_List (
New_Reference_To (Pool, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Address),
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Alignment))));
end Insert_Dereference_Action;
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
Loop_Statement : Node_Id;
Loop_Body : Node_Id;
If_Stat : Node_Id;
Inner_If : Node_Id;
Final_Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
Formals : List_Id;
Length1 : Node_Id;
Length2 : Node_Id;
begin
Inner_If :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (J, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Last)),
Then_Statements => New_List (
Make_Exit_Statement (Loc)),
Else_Statements =>
New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (New_Reference_To (J, Loc))))));
Loop_Body :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (X, Loc),
Expressions => New_List (New_Reference_To (I, Loc))),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Y, Loc),
Expressions => New_List (New_Reference_To (J, Loc)))),
Then_Statements => New_List (Inner_If),
Else_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Op_Gt (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (X, Loc),
Expressions => New_List (New_Reference_To (I, Loc))),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Y, Loc),
Expressions => New_List (
New_Reference_To (J, Loc)))))));
Loop_Statement :=
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => I,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Range))),
Statements => New_List (Loop_Body));
Length1 :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Length);
Length2 :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Length);
Final_Expr :=
Make_Op_Gt (Loc,
Left_Opnd => Length1,
Right_Opnd => Length2);
If_Stat :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, 0)),
Then_Statements =>
New_List (
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_False, Loc))),
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, 0)),
Then_Statements =>
New_List (
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))))),
Else_Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression => Final_Expr)));
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => X,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Y,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => J,
Object_Definition => New_Reference_To (Index, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_First))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (If_Stat)));
return Func_Body;
end Make_Array_Comparison_Op;
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
A_J : Node_Id;
B_J : Node_Id;
C_J : Node_Id;
Op : Node_Id;
Formals : List_Id;
Func_Name : Entity_Id;
Func_Body : Node_Id;
Loop_Statement : Node_Id;
begin
A_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (A, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
B_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (B, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
C_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (C, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
if Nkind (N) = N_Op_And then
Op :=
Make_Op_And (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
elsif Nkind (N) = N_Op_Or then
Op :=
Make_Op_Or (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
else
Op :=
Make_Op_Xor (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
end if;
Loop_Statement :=
Make_Implicit_Loop_Statement (N,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Range))),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => C_J,
Expression => Op)));
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Set_Is_Inlined (Func_Name);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => C,
Object_Definition => New_Reference_To (Typ, Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression => New_Reference_To (C, Loc)))));
return Func_Body;
end Make_Boolean_Array_Op;
procedure Rewrite_Comparison (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
True_Result : Boolean;
False_Result : Boolean;
begin
case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
True_Result := Res = EQ;
False_Result := Res = LT or else Res = GT or else Res = NE;
when N_Op_Ge =>
True_Result := Res in Compare_GE;
False_Result := Res = LT;
when N_Op_Gt =>
True_Result := Res = GT;
False_Result := Res in Compare_LE;
when N_Op_Lt =>
True_Result := Res = LT;
False_Result := Res in Compare_GE;
when N_Op_Le =>
True_Result := Res in Compare_LE;
False_Result := Res = GT;
when N_Op_Ne =>
True_Result := Res = NE;
False_Result := Res = LT or else Res = GT or else Res = EQ;
end case;
if True_Result then
Rewrite (N,
Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
Analyze_And_Resolve (N, Typ);
Warn_On_Known_Condition (N);
elsif False_Result then
Rewrite (N,
Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
Analyze_And_Resolve (N, Typ);
Warn_On_Known_Condition (N);
end if;
end Rewrite_Comparison;
function Tagged_Membership (N : Node_Id) return Node_Id is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
Left_Type : Entity_Id;
Right_Type : Entity_Id;
Obj_Tag : Node_Id;
begin
Left_Type := Etype (Left);
Right_Type := Etype (Right);
if Is_Class_Wide_Type (Left_Type) then
Left_Type := Root_Type (Left_Type);
end if;
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
return
Make_DT_Access_Action (Left_Type,
Action => CW_Membership,
Args => New_List (
Obj_Tag,
New_Reference_To (
Access_Disp_Table (Root_Type (Right_Type)), Loc)));
else
return
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
New_Reference_To (Access_Disp_Table (Right_Type), Loc));
end if;
end Tagged_Membership;
procedure Unary_Op_Validity_Checks (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
Ensure_Valid (Right_Opnd (N));
end if;
end Unary_Op_Validity_Checks;
end Exp_Ch4;