with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Ch2 is
procedure Expand_Current_Value (N : Node_Id);
procedure Expand_Discriminant (N : Node_Id);
procedure Expand_Entity_Reference (N : Node_Id);
procedure Expand_Entry_Index_Parameter (N : Node_Id);
procedure Expand_Entry_Parameter (N : Node_Id);
procedure Expand_Formal (N : Node_Id);
procedure Expand_Protected_Private (N : Node_Id);
procedure Expand_Renaming (N : Node_Id);
procedure Expand_Current_Value (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
CV : constant Node_Id := Current_Value (E);
T : constant Entity_Id := Etype (N);
Val : Node_Id;
Op : Node_Kind;
begin
if True
and then Nkind (CV) /= N_Raise_Constraint_Error
and then Is_Discrete_Type (T)
and then not Has_Biased_Representation (T)
and then not Is_Lvalue (N)
and then OK_To_Do_Constant_Replacement (E)
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
and then not (Nkind (Parent (N)) = N_Attribute_Reference
and then
(Attribute_Name (Parent (N)) = Name_Asm_Input
or else
Attribute_Name (Parent (N)) = Name_Asm_Output))
then
if Nkind (CV) in N_Subexpr then
Val := CV;
else
Get_Current_Value_Condition (N, Op, Val);
if Op /= N_Op_Eq then
return;
end if;
end if;
if Is_Entity_Name (Val)
and then Ekind (Entity (Val)) = E_Enumeration_Literal
then
Rewrite (N,
Unchecked_Convert_To (T,
New_Occurrence_Of (Entity (Val), Loc)));
else
Rewrite (N,
Unchecked_Convert_To (T,
Make_Integer_Literal (Loc,
Intval => Expr_Rep_Value (Val))));
end if;
Analyze_And_Resolve (N, T);
Set_Is_Static_Expression (N, False);
end if;
end Expand_Current_Value;
procedure Expand_Discriminant (N : Node_Id) is
Scop : constant Entity_Id := Scope (Entity (N));
P : Node_Id := N;
Parent_P : Node_Id := Parent (P);
In_Entry : Boolean := False;
begin
if Ekind (Scop) = E_Record_Type
or Ekind (Scop) in Incomplete_Or_Private_Kind
then
while Present (Parent_P)
and then Nkind (Parent_P) /= N_Component_Declaration
loop
P := Parent_P;
Parent_P := Parent (P);
end loop;
if Present (Parent_P) and then P = Expression (Parent_P) then
Set_Entity (N, Discriminal (Entity (N)));
end if;
elsif Is_Concurrent_Type (Scop) then
while Present (Parent_P)
and then Nkind (Parent_P) /= N_Subprogram_Body
loop
P := Parent_P;
if Nkind (P) = N_Entry_Declaration then
In_Entry := True;
end if;
Parent_P := Parent (Parent_P);
end loop;
if Present (Parent_P)
and then Present (Corresponding_Spec (Parent_P))
then
declare
Loc : constant Source_Ptr := Sloc (N);
D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
Formal : constant Entity_Id := First_Formal (D_Fun);
New_N : Node_Id;
Disc : Entity_Id;
begin
if Present (Formal)
and then Etype (Formal) = Scope (Entity (N))
then
Disc := CR_Discriminant (Entity (N));
New_N :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Formal, Loc),
Selector_Name => New_Occurrence_Of (Disc, Loc));
Set_Etype (New_N, Etype (N));
Rewrite (N, New_N);
else
Set_Entity (N, Discriminal (Entity (N)));
end if;
end;
elsif Nkind (Parent (N)) = N_Range
and then In_Entry
then
Set_Entity (N, CR_Discriminant (Entity (N)));
else
Set_Entity (N, Discriminal (Entity (N)));
end if;
else
Set_Entity (N, Discriminal (Entity (N)));
end if;
end Expand_Discriminant;
procedure Expand_Entity_Reference (N : Node_Id) is
E : constant Entity_Id := Entity (N);
begin
if No (E) and then Total_Errors_Detected /= 0 then
return;
end if;
if Ekind (E) = E_Discriminant then
Expand_Discriminant (N);
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
elsif Ekind (E) = E_Component
and then Is_Protected_Private (E)
then
if No_Run_Time_Mode then
return;
end if;
Expand_Protected_Private (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
elsif Is_Formal (E) then
Expand_Formal (N);
elsif Is_Renaming_Of_Object (E) then
Expand_Renaming (N);
elsif Ekind (E) = E_Variable
and then Is_Shared_Passive (E)
then
Expand_Shared_Passive_Variable (N);
elsif (Ekind (E) = E_Variable
or else
Ekind (E) = E_In_Out_Parameter
or else
Ekind (E) = E_Out_Parameter)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
if Is_Boolean_Type (Etype (N)) then
Warn_On_Known_Condition (N);
end if;
end if;
end Expand_Entity_Reference;
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
begin
Set_Entity (N, Entry_Index_Constant (Entity (N)));
end Expand_Entry_Index_Parameter;
procedure Expand_Entry_Parameter (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formal : constant Entity_Id := Entity (N);
Ent_Spec : constant Entity_Id := Scope (Ent_Formal);
Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec);
Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec);
Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
P_Comp_Ref : Entity_Id;
function In_Assignment_Context (N : Node_Id) return Boolean;
function In_Assignment_Context (N : Node_Id) return Boolean is
begin
if Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Entry_Call_Statement
or else
(Nkind (Parent (N)) = N_Assignment_Statement
and then N = Name (Parent (N)))
then
return True;
elsif Nkind (Parent (N)) = N_Parameter_Association then
return In_Assignment_Context (Parent (N));
elsif (Nkind (Parent (N)) = N_Selected_Component
or else Nkind (Parent (N)) = N_Indexed_Component
or else Nkind (Parent (N)) = N_Slice)
and then In_Assignment_Context (Parent (N))
then
return True;
else
return False;
end if;
end In_Assignment_Context;
begin
if Is_Task_Type (Scope (Ent_Spec))
and then Comes_From_Source (Ent_Formal)
then
if Ekind (Entity (N)) /= E_In_Parameter
and then In_Assignment_Context (N)
then
Note_Possible_Modification (N);
end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
return;
end if;
P_Comp_Ref :=
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Parm_Type,
New_Reference_To (Addr_Ent, Loc))),
Selector_Name =>
New_Reference_To (Entry_Component (Ent_Formal), Loc));
Rewrite (N,
Make_Explicit_Dereference (Loc, P_Comp_Ref));
Analyze (N);
end Expand_Entry_Parameter;
procedure Expand_Formal (N : Node_Id) is
E : constant Entity_Id := Entity (N);
Subp : constant Entity_Id := Scope (E);
begin
if Is_Protected_Type (Scope (Subp))
and then not Is_Init_Proc (Subp)
and then Present (Protected_Formal (E))
then
Set_Entity (N, Protected_Formal (E));
end if;
end Expand_Formal;
procedure Expand_N_Expanded_Name (N : Node_Id) is
begin
Expand_Entity_Reference (N);
end Expand_N_Expanded_Name;
procedure Expand_N_Identifier (N : Node_Id) is
begin
Expand_Entity_Reference (N);
end Expand_N_Identifier;
procedure Expand_N_Real_Literal (N : Node_Id) is
begin
if Vax_Float (Etype (N)) then
Expand_Vax_Real_Literal (N);
end if;
end Expand_N_Real_Literal;
procedure Expand_Protected_Private (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
Op : constant Node_Id := Protected_Operation (E);
Scop : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
D_Range : Node_Id;
begin
if Nkind (Op) /= N_Subprogram_Body
or else Nkind (Specification (Op)) /= N_Function_Specification
then
Set_Ekind (Prival (E), E_Variable);
else
Set_Ekind (Prival (E), E_Constant);
end if;
if Comes_From_Source (N)
and then Is_Array_Type (Etype (E))
and then Number_Dimensions (Etype (E)) = 1
and then not Within_Init_Proc
then
Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
if Nkind (Parent (N)) = N_Assignment_Statement
and then ((Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_In_Parameter)
or else (Is_Entity_Name (Hi)
and then
Ekind (Entity (Hi)) = E_In_Parameter))
then
D_Range := New_Node (N_Range, Loc);
if Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_In_Parameter
then
Set_Low_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Lo))));
else
Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
end if;
if Is_Entity_Name (Hi)
and then Ekind (Entity (Hi)) = E_In_Parameter
then
Set_High_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Hi))));
else
Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
end if;
Rewrite (N,
Make_Slice (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Discrete_Range => D_Range));
Analyze_And_Resolve (N, Etype (E));
return;
end if;
end if;
Set_Entity (N, Prival (E));
Set_Etype (N, Etype (Prival (E)));
Scop := Current_Scope;
while not Is_Protected_Type (Scope (Scop)) loop
Scop := Scope (Scop);
end loop;
Append_Elmt (N, Privals_Chain (Scop));
end Expand_Protected_Private;
procedure Expand_Renaming (N : Node_Id) is
E : constant Entity_Id := Entity (N);
T : constant Entity_Id := Etype (N);
begin
Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
Reset_Analyzed_Flags (N);
Analyze_And_Resolve (N, T);
end Expand_Renaming;
function Param_Entity (N : Node_Id) return Entity_Id is
begin
if Nkind (N) = N_Identifier or else Nkind (N) = N_Expanded_Name then
if Is_Formal (Entity (N)) then
return Entity (N);
elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
then
return Entity (N);
end if;
else
if Nkind (N) = N_Explicit_Dereference then
declare
P : constant Node_Id := Prefix (N);
S : Node_Id;
begin
if Nkind (P) = N_Selected_Component then
S := Selector_Name (P);
if Present (Entry_Formal (Entity (S))) then
return Entry_Formal (Entity (S));
end if;
elsif Nkind (Original_Node (N)) = N_Identifier then
return Param_Entity (Original_Node (N));
end if;
end;
end if;
end if;
return (Empty);
end Param_Entity;
end Exp_Ch2;