with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Ch13 is
procedure Expand_External_Tag_Definition (N : Node_Id);
procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Exp : constant Node_Id := Expression (N);
Ent : Entity_Id;
V : Node_Id;
begin
Ent := Entity (Name (N));
if Is_Type (Ent) then
Ent := Underlying_Type (Ent);
end if;
case Get_Attribute_Id (Chars (N)) is
when Attribute_Address =>
declare
Decl : constant Node_Id := Declaration_Node (Ent);
begin
if Nkind (Decl) = N_Object_Declaration
and then Present (Expression (Decl))
and then
not Comes_From_Source (Original_Node (Expression (Decl)))
then
Set_Expression (Decl, Empty);
end if;
end;
when Attribute_Alignment =>
if Nkind (Exp) /= N_Integer_Literal then
Rewrite
(Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
end if;
when Attribute_Storage_Size =>
if Ekind (Ent) = E_Task_Type then
Insert_Action (N,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
Expression =>
Convert_To (RTE (RE_Size_Type), Expression (N))));
elsif Is_Access_Type (Ent) then
V := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Ent), 'V'));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => V,
Object_Definition =>
New_Reference_To (RTE (RE_Storage_Offset), Loc),
Expression =>
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
Set_Storage_Size_Variable (Ent, Entity_Id (V));
end if;
when others =>
null;
end case;
end Expand_N_Attribute_Definition_Clause;
procedure Expand_External_Tag_Definition (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id := Entity (Name (N));
E : Entity_Id;
Old_Val : String_Id := Strval (Expr_Value_S (Expression (N)));
New_Val : String_Id;
begin
if String_Length (Old_Val) > 0
and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
then
New_Val := Old_Val;
else
Start_String (Old_Val);
Store_String_Char (Get_Char_Code (ASCII.NUL));
New_Val := End_String;
end if;
E :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Ent), 'A'));
Append_Freeze_Action (Ent,
Make_Object_Declaration (Loc,
Defining_Identifier => E,
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc, Strval => New_Val)));
Append_Freeze_Actions (Ent, New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Tag,
Prefix => New_Occurrence_Of (Ent, Loc)),
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Occurrence_Of (E, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Tag,
Prefix => New_Occurrence_Of (Ent, Loc))))));
end Expand_External_Tag_Definition;
procedure Expand_N_Freeze_Entity (N : Node_Id) is
E : constant Entity_Id := Entity (N);
E_Scope : Entity_Id;
S : Entity_Id;
In_Other_Scope : Boolean;
In_Outer_Scope : Boolean;
Decl : Node_Id;
begin
if Is_Object (E) then
Apply_Alignment_Check (E, N);
elsif not Is_Type (E) and then not Is_Subprogram (E) then
return;
end if;
E_Scope := Scope (E);
if Ekind (E_Scope) = E_Protected_Type
or else (Ekind (E_Scope) = E_Task_Type
and then not Has_Completion (E_Scope))
then
E_Scope := Scope (E_Scope);
end if;
S := Current_Scope;
while S /= Standard_Standard and then S /= E_Scope loop
S := Scope (S);
end loop;
In_Other_Scope := not (S = E_Scope);
In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
if In_Other_Scope then
New_Scope (E_Scope);
Install_Visible_Declarations (E_Scope);
if Ekind (E_Scope) = E_Package or else
Ekind (E_Scope) = E_Generic_Package or else
Is_Protected_Type (E_Scope) or else
Is_Task_Type (E_Scope)
then
Install_Private_Declarations (E_Scope);
end if;
elsif In_Outer_Scope then
New_Scope (E_Scope);
end if;
if Is_Type (E) then
Freeze_Type (N);
if Is_Enumeration_Type (E) then
Build_Enumeration_Image_Tables (E, N);
elsif Is_Tagged_Type (E)
and then Is_First_Subtype (E)
then
declare
Def : Node_Id :=
Get_Attribute_Definition_Clause (E, Attribute_External_Tag);
begin
if Present (Def) then
Expand_External_Tag_Definition (Def);
end if;
end;
end if;
elsif Is_Subprogram (E) then
Freeze_Subprogram (N);
end if;
if Present (Actions (N)) then
Decl := First (Actions (N));
while Present (Decl) loop
if Nkind (Decl) = N_Subprogram_Body
and then (Chars (Defining_Entity (Decl)) = Name_uInit_Proc
or else Chars (Defining_Entity (Decl)) = Name_uAssign)
then
Analyze (Decl);
elsif Nkind (Decl) = N_Subprogram_Body
and then Present (Corresponding_Spec (Decl))
and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
then
New_Scope (Scope (Corresponding_Spec (Decl)));
Analyze (Decl, Suppress => All_Checks);
Pop_Scope;
else
Analyze (Decl, Suppress => All_Checks);
end if;
Next (Decl);
end loop;
end if;
if In_Other_Scope then
if Ekind (Current_Scope) = E_Package then
End_Package_Scope (E_Scope);
else
End_Scope;
end if;
elsif In_Outer_Scope then
Pop_Scope;
end if;
end Expand_N_Freeze_Entity;
procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rectype : constant Entity_Id := Entity (Identifier (N));
Mod_Val : Uint;
Citems : List_Id;
Repitem : Node_Id;
AtM_Nod : Node_Id;
begin
if Present (Mod_Clause (N)) then
Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
Citems := Pragmas_Before (Mod_Clause (N));
if Present (Citems) then
Append_List_To (Citems, Component_Clauses (N));
Set_Component_Clauses (N, Citems);
end if;
AtM_Nod :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Base_Type (Rectype), Loc),
Chars => Name_Alignment,
Expression => Make_Integer_Literal (Loc, Mod_Val));
Set_From_At_Mod (AtM_Nod);
Insert_After (N, AtM_Nod);
Set_Mod_Clause (N, Empty);
end if;
if Is_Empty_List (Component_Clauses (N)) then
if First_Rep_Item (Rectype) = N then
Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
else
Repitem := First_Rep_Item (Rectype);
while Present (Next_Rep_Item (Repitem)) loop
if Next_Rep_Item (Repitem) = N then
Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
exit;
end if;
Next_Rep_Item (Repitem);
end loop;
end if;
Rewrite (N,
Make_Null_Statement (Loc));
end if;
end Expand_N_Record_Representation_Clause;
end Exp_Ch13;