with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Smem; use Exp_Smem;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
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_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch3 is
procedure Adjust_Discriminants (Rtype : Entity_Id);
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
procedure Build_Class_Wide_Master (T : Entity_Id);
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean)
return List_Id;
procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id);
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id);
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
procedure Expand_Tagged_Root (T : Entity_Id);
procedure Expand_Record_Controller (T : Entity_Id);
procedure Freeze_Array_Type (N : Node_Id);
procedure Freeze_Enumeration_Type (N : Node_Id);
procedure Freeze_Record_Type (N : Node_Id);
function Init_Formals (Typ : Entity_Id) return List_Id;
function In_Runtime (E : Entity_Id) return Boolean;
function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id;
function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id;
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_Id;
Renamed_Eq : out Node_Id);
function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
function Predef_Spec_Or_Body
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
For_Body : Boolean := False)
return Node_Id;
function Predef_Stream_Attr_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
For_Body : Boolean := False)
return Node_Id;
function Predef_Deep_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
For_Body : Boolean := False)
return Node_Id;
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
Renamed_Eq : Node_Id)
return List_Id;
function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
procedure Adjust_Discriminants (Rtype : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Rtype);
Comp : Entity_Id;
Ctyp : Entity_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
P : Node_Id;
Loval : Uint;
Discr : Entity_Id;
Dtyp : Entity_Id;
Dhi : Node_Id;
Dhiv : Uint;
Ahi : Node_Id;
Ahiv : Uint;
Tnn : Entity_Id;
begin
Comp := First_Component (Rtype);
while Present (Comp) loop
P := Parent (Comp); P := Parent (P);
exit when Nkind (Parent (P)) = N_Variant;
Ctyp := Etype (Comp);
if not Is_Array_Type (Ctyp)
or else Number_Dimensions (Ctyp) > 1
then
goto Continue;
end if;
Ityp := Etype (First_Index (Ctyp));
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
if not Compile_Time_Known_Value (Lo)
or else Nkind (Hi) /= N_Identifier
or else No (Entity (Hi))
or else Ekind (Entity (Hi)) /= E_Discriminant
then
goto Continue;
end if;
Loval := Expr_Value (Lo);
Discr := Entity (Hi);
Dtyp := Etype (Discr);
Dhi := Type_High_Bound (Dtyp);
if not Compile_Time_Known_Value (Dhi) then
goto Continue;
end if;
Dhiv := Expr_Value (Dhi);
Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
if not Compile_Time_Known_Value (Ahi) then
goto Continue;
end if;
Ahiv := Expr_Value (Ahi);
if Dhiv > Loval and then Dhiv > Ahiv then
Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Insert_Action (Declaration_Node (Rtype),
Make_Subtype_Declaration (Loc,
Defining_Identifier => Tnn,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Occurrence_Of (Dtyp, Loc)),
High_Bound =>
Make_Integer_Literal (Loc,
Intval => UI_Max (Loval, Ahiv)))))));
Set_Etype (Discr, Tnn);
end if;
<<Continue>>
Next_Component (Comp);
end loop;
end Adjust_Discriminants;
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nod);
Comp_Type : constant Entity_Id := Component_Type (A_Type);
Index_List : List_Id;
Proc_Id : Entity_Id;
Proc_Body : Node_Id;
Body_Stmts : List_Id;
function Init_Component return List_Id;
function Init_One_Dimension (N : Int) return List_Id;
function Init_Component return List_Id is
Comp : Node_Id;
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Expressions => Index_List);
if Needs_Simple_Initialization (Comp_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression => Get_Simple_Init_Val (Comp_Type, Loc)));
else
return
Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type);
end if;
end Init_Component;
function Init_One_Dimension (N : Int) return List_Id is
Index : Entity_Id;
begin
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Needs_Simple_Initialization (Comp_Type)
and then not Has_Task (Comp_Type)
then
return New_List (Make_Null_Statement (Loc));
elsif N > Number_Dimensions (A_Type) then
return Init_Component;
else
Index :=
Make_Defining_Identifier (Loc, New_External_Name ('J', N));
Append (New_Reference_To (Index, Loc), Index_List);
return New_List (
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => Init_One_Dimension (N + 1)));
end if;
end Init_One_Dimension;
begin
if Suppress_Init_Proc (A_Type) then
return;
end if;
Index_List := New_List;
if Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type)
or else (Is_Public (A_Type)
and then Root_Type (A_Type) /= Standard_String
and then Root_Type (A_Type) /= Standard_Wide_String)
then
Proc_Id :=
Make_Defining_Identifier (Loc, Name_uInit_Proc);
Body_Stmts := Init_One_Dimension (1);
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => Init_Formals (A_Type)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
Set_Is_Inlined (Proc_Id);
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
Set_Init_Proc (A_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
and then Nkind (First (Body_Stmts)) = N_Null_Statement
then
Set_Is_Null_Init_Proc (Proc_Id);
end if;
end if;
end Build_Array_Init_Proc;
procedure Build_Class_Wide_Master (T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (T);
M_Id : Entity_Id;
Decl : Node_Id;
P : Node_Id;
begin
if Restrictions (No_Task_Hierarchy) then
return;
end if;
if not Has_Master_Entity (Scope (T)) then
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Constant_Present => True,
Object_Definition => New_Reference_To (Standard_Integer, Loc),
Expression =>
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
P := Parent (T);
Insert_Before (P, Decl);
Analyze (Decl);
Set_Has_Master_Entity (Scope (T));
while Nkind (P) /= N_Compilation_Unit loop
P := Parent (P);
if Nkind (P) = N_Task_Body
or else Nkind (P) = N_Block_Statement
or else Nkind (P) = N_Subprogram_Body
then
Set_Is_Task_Master (P, True);
exit;
end if;
end loop;
end if;
M_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (T), 'M'));
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => M_Id,
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (Parent (T), Decl);
Analyze (Decl);
Set_Master_Id (T, M_Id);
end Build_Class_Wide_Master;
procedure Build_Discr_Checking_Funcs (N : Node_Id) is
Rec_Id : Entity_Id;
Loc : Source_Ptr;
Enclosing_Func_Id : Entity_Id;
Sequence : Nat := 1;
Type_Def : Node_Id;
V : Node_Id;
function Build_Case_Statement
(Case_Id : Entity_Id;
Variant : Node_Id)
return Node_Id;
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id)
return Entity_Id;
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
function Build_Case_Statement
(Case_Id : Entity_Id;
Variant : Node_Id)
return Node_Id
is
Actuals_List : List_Id;
Alt_List : List_Id := New_List;
Case_Node : Node_Id;
Case_Alt_Node : Node_Id;
Choice : Node_Id;
Choice_List : List_Id;
D : Entity_Id;
Return_Node : Node_Id;
begin
Case_Node := New_Node (N_Case_Statement, Loc);
Set_Expression (Case_Node,
Make_Identifier (Loc, Chars (Case_Id)));
Choice := First (Discrete_Choices (Variant));
if Nkind (Choice) = N_Others_Choice then
Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
else
Choice_List := New_Copy_List (Discrete_Choices (Variant));
end if;
if not Is_Empty_List (Choice_List) then
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
Set_Discrete_Choices (Case_Alt_Node, Choice_List);
if Present (Enclosing_Func_Id) then
Actuals_List := New_List;
D := First_Discriminant (Rec_Id);
while Present (D) loop
Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
Next_Discriminant (D);
end loop;
Return_Node :=
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Enclosing_Func_Id, Loc),
Parameter_Associations =>
Actuals_List));
else
Return_Node :=
Make_Return_Statement (Loc,
Expression =>
New_Reference_To (Standard_False, Loc));
end if;
Set_Statements (Case_Alt_Node, New_List (Return_Node));
Append (Case_Alt_Node, Alt_List);
end if;
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
Choice_List := New_List (New_Node (N_Others_Choice, Loc));
Set_Discrete_Choices (Case_Alt_Node, Choice_List);
Return_Node :=
Make_Return_Statement (Loc,
Expression =>
New_Reference_To (Standard_True, Loc));
Set_Statements (Case_Alt_Node, New_List (Return_Node));
Append (Case_Alt_Node, Alt_List);
Set_Alternatives (Case_Node, Alt_List);
return Case_Node;
end Build_Case_Statement;
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id)
return Entity_Id
is
Body_Node : Node_Id;
Func_Id : Entity_Id;
Parameter_List : List_Id;
Spec_Node : Node_Id;
begin
Body_Node := New_Node (N_Subprogram_Body, Loc);
Sequence := Sequence + 1;
Func_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
Spec_Node := New_Node (N_Function_Specification, Loc);
Set_Defining_Unit_Name (Spec_Node, Func_Id);
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
Set_Subtype_Mark (Spec_Node,
New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Build_Case_Statement (Case_Id, Variant))));
Set_Ekind (Func_Id, E_Function);
Set_Mechanism (Func_Id, Default_Mechanism);
Set_Is_Inlined (Func_Id, True);
Set_Is_Pure (Func_Id, True);
Set_Is_Public (Func_Id, Is_Public (Rec_Id));
Set_Is_Internal (Func_Id, True);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Func_Id);
end if;
Append_Freeze_Action (Rec_Id, Body_Node);
Set_Dcheck_Function (Variant, Func_Id);
return Func_Id;
end Build_Dcheck_Function;
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
Component_List_Node : Node_Id;
Decl : Entity_Id;
Discr_Name : Entity_Id;
Func_Id : Entity_Id;
Variant : Node_Id;
Saved_Enclosing_Func_Id : Entity_Id;
begin
Discr_Name := Entity (Name (Variant_Part_Node));
Variant := First_Non_Pragma (Variants (Variant_Part_Node));
while Present (Variant) loop
Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Component_List_Node := Component_List (Variant);
if not Null_Present (Component_List_Node) then
Decl :=
First_Non_Pragma (Component_Items (Component_List_Node));
while Present (Decl) loop
Set_Discriminant_Checking_Func
(Defining_Identifier (Decl), Func_Id);
Next_Non_Pragma (Decl);
end loop;
if Present (Variant_Part (Component_List_Node)) then
Saved_Enclosing_Func_Id := Enclosing_Func_Id;
Enclosing_Func_Id := Func_Id;
Build_Dcheck_Functions (Variant_Part (Component_List_Node));
Enclosing_Func_Id := Saved_Enclosing_Func_Id;
end if;
end if;
Next_Non_Pragma (Variant);
end loop;
end Build_Dcheck_Functions;
begin
if not Discr_Check_Funcs_Built (N) then
Type_Def := Type_Definition (N);
if Nkind (Type_Def) = N_Record_Definition then
if No (Component_List (Type_Def)) then return;
else
V := Variant_Part (Component_List (Type_Def));
end if;
else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
if No (Component_List (Record_Extension_Part (Type_Def))) then
return;
else
V := Variant_Part
(Component_List (Record_Extension_Part (Type_Def)));
end if;
end if;
Rec_Id := Defining_Identifier (N);
if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
Loc := Sloc (N);
Enclosing_Func_Id := Empty;
Build_Dcheck_Functions (V);
end if;
Set_Discr_Check_Funcs_Built (N);
end if;
end Build_Discr_Checking_Funcs;
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean)
return List_Id
is
D : Entity_Id;
Formal : Entity_Id;
Loc : Source_Ptr := Sloc (Rec_Id);
Param_Spec_Node : Node_Id;
Parameter_List : List_Id := New_List;
begin
if Has_Discriminants (Rec_Id) then
D := First_Discriminant (Rec_Id);
while Present (D) loop
Loc := Sloc (D);
if Use_Dl then
Formal := Discriminal (D);
else
Formal := Make_Defining_Identifier (Loc, Chars (D));
end if;
Param_Spec_Node :=
Make_Parameter_Specification (Loc,
Defining_Identifier => Formal,
Parameter_Type =>
New_Reference_To (Etype (D), Loc));
Append (Param_Spec_Node, Parameter_List);
Next_Discriminant (D);
end loop;
end if;
return Parameter_List;
end Build_Discriminant_Formals;
function Build_Initialization_Call
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List)
return List_Id
is
First_Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Entity_Id;
Arg : Node_Id;
Proc : constant Entity_Id := Base_Init_Proc (Typ);
Init_Type : constant Entity_Id := Etype (First_Formal (Proc));
Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
Res : List_Id := New_List;
Full_Type : Entity_Id := Typ;
Controller_Typ : Entity_Id;
begin
if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
return Empty_List;
end if;
if Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
Full_Type := Full_View (Typ);
end if;
if (Is_Record_Type (Typ)
or else Is_Array_Type (Typ)
or else Is_Private_Type (Typ))
and then Init_Type /= Base_Type (Typ)
then
First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
Set_Etype (First_Arg, Init_Type);
else
First_Arg := Id_Ref;
end if;
Args := New_List (Convert_Concurrent (First_Arg, Typ));
if Has_Task (Full_Type) then
if Restrictions (No_Task_Hierarchy) then
Append_To (Args, Make_Integer_Literal (Loc, 3));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
Append_List (Decls, Res);
else
Decls := No_List;
Decl := Empty;
end if;
if Has_Discriminants (Full_Init_Type) then
Discr := First_Discriminant (Full_Init_Type);
while Present (Discr) loop
declare
T : Entity_Id := Full_Type;
begin
if Is_Protected_Type (T) then
T := Corresponding_Record_Type (T);
end if;
Arg :=
Get_Discriminant_Value (
Discr,
T,
Discriminant_Constraint (Full_Type));
end;
if In_Init_Proc then
if Nkind (Arg) = N_Identifier
and then Ekind (Entity (Arg)) = E_Discriminant
then
Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc);
elsif Nkind (Arg) = N_Attribute_Reference
and then Is_Access_Type (Etype (Arg))
and then Is_Entity_Name (Prefix (Arg))
and then Is_Type (Entity (Prefix (Arg)))
then
Arg :=
Make_Attribute_Reference (Loc,
Prefix => New_Copy (Prefix (Id_Ref)),
Attribute_Name => Name_Unrestricted_Access);
else
Arg :=
New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
end if;
else
if Is_Constrained (Full_Type) then
Arg := Duplicate_Subexpr (Arg);
else
Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
end if;
end if;
Append_To (Args, Arg);
Next_Discriminant (Discr);
end loop;
end if;
if Is_Tagged_Type (Full_Init_Type)
and then not Is_CPP_Class (Full_Init_Type)
and then Nkind (Id_Ref) = N_Selected_Component
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
end if;
Append_To (Res,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
if Controlled_Type (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Append_List_To (Res,
Make_Init_Call (
Ref => New_Copy_Tree (First_Arg),
Typ => Typ,
Flist_Ref =>
Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
With_Attach => Make_Integer_Literal (Loc, 1)));
elsif Present (Enclos_Type)
and then Has_New_Controlled_Component (Enclos_Type)
and then Has_Controlled_Component (Typ)
then
if Is_Return_By_Reference_Type (Typ) then
Controller_Typ := RTE (RE_Limited_Record_Controller);
else
Controller_Typ := RTE (RE_Record_Controller);
end if;
Append_List_To (Res,
Make_Init_Call (
Ref =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (First_Arg),
Selector_Name => Make_Identifier (Loc, Name_uController)),
Typ => Controller_Typ,
Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
With_Attach => Make_Integer_Literal (Loc, 1)));
end if;
end if;
if Has_Task (Full_Type)
and then not Is_Task_Type (Full_Type)
then
Append_To (Res,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Free_Task_Image), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Defining_Identifier (Decl), Loc))));
end if;
return Res;
end Build_Initialization_Call;
procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
M_Id : Entity_Id;
Decl : Node_Id;
begin
if Restrictions (No_Task_Hierarchy) then
return;
end if;
M_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (T), 'M'));
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => M_Id,
Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc),
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (N, Decl);
Analyze (Decl);
Set_Master_Id (T, M_Id);
end Build_Master_Renaming;
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is
Loc : Source_Ptr := Sloc (N);
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
Discr_Map : Elist_Id := New_Elmt_List;
Set_Tag : Entity_Id := Empty;
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
procedure Build_Discriminant_Assignments (Statement_List : List_Id);
function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
function Build_Init_Call_Thru
(Parameters : List_Id)
return List_Id;
procedure Build_Init_Procedure;
procedure Build_Record_Checks
(S : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id);
function Component_Needs_Simple_Initialization
(T : Entity_Id)
return Boolean;
procedure Constrain_Array
(SI : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id);
procedure Constrain_Index
(Index : Node_Id;
S : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id);
function Parent_Subtype_Renaming_Discrims return Boolean;
function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
Exp : Node_Id := N;
Lhs : Node_Id;
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
Kind : Node_Kind := Nkind (N);
Res : List_Id;
begin
Loc := Sloc (N);
Lhs :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc));
Set_Assignment_OK (Lhs);
if Kind = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Unchecked_Access
or else
Attribute_Name (N) = Name_Unrestricted_Access)
and then Is_Entity_Name (Prefix (N))
and then Is_Type (Entity (Prefix (N)))
and then Entity (Prefix (N)) = Rec_Type
then
Exp :=
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
end if;
if Nkind (Exp) = N_Identifier
and then not Comes_From_Source (Exp)
and then Analyzed (Exp)
and then not In_Open_Scopes (Scope (Entity (Exp)))
and then Nkind (Original_Node (Exp)) = N_Aggregate
then
Exp := New_Copy_Tree (Original_Node (Exp));
end if;
Res := New_List (
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Exp));
Set_No_Ctrl_Actions (First (Res));
if Is_Tagged_Type (Typ) and then not Java_VM then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (Typ), Loc))));
end if;
if Kind = N_Qualified_Expression then
Kind := Nkind (Parent (N));
end if;
if Controlled_Type (Typ)
and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate)
then
Append_List_To (Res,
Make_Adjust_Call (
Ref => New_Copy_Tree (Lhs),
Typ => Etype (Id),
Flist_Ref =>
Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
With_Attach => Make_Integer_Literal (Loc, 1)));
end if;
return Res;
end Build_Assignment;
procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
D : Entity_Id;
Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
begin
if Has_Discriminants (Rec_Type)
and then not Is_Unchecked_Union (Rec_Type)
then
D := First_Discriminant (Rec_Type);
while Present (D) loop
if Is_Tagged and then
Present (Corresponding_Discriminant (D))
then
null;
else
Loc := Sloc (D);
Append_List_To (Statement_List,
Build_Assignment (D,
New_Reference_To (Discriminal (D), Loc)));
end if;
Next_Discriminant (D);
end loop;
end if;
end Build_Discriminant_Assignments;
function Build_Init_Call_Thru
(Parameters : List_Id)
return List_Id
is
Parent_Proc : constant Entity_Id :=
Base_Init_Proc (Etype (Rec_Type));
Parent_Type : constant Entity_Id :=
Etype (First_Formal (Parent_Proc));
Uparent_Type : constant Entity_Id :=
Underlying_Type (Parent_Type);
First_Discr_Param : Node_Id;
Parent_Discr : Entity_Id;
First_Arg : Node_Id;
Args : List_Id;
Arg : Node_Id;
Res : List_Id;
begin
First_Arg :=
OK_Convert_To (Parent_Type,
New_Reference_To (Defining_Identifier (First (Parameters)), Loc));
Set_Etype (First_Arg, Parent_Type);
Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
First_Discr_Param := Next (First (Parameters));
if Has_Task (Rec_Type) then
if Restrictions (No_Task_Hierarchy) then
Append_To (Args, Make_Integer_Literal (Loc, 3));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Append_To (Args, Make_Identifier (Loc, Name_uTask_Id));
First_Discr_Param := Next (Next (Next (First_Discr_Param)));
end if;
if Has_Discriminants (Uparent_Type) then
pragma Assert (not Is_Tagged_Type (Uparent_Type));
Parent_Discr := First_Discriminant (Uparent_Type);
while Present (Parent_Discr) loop
declare
Discr_Value : Elmt_Id :=
First_Elmt
(Girder_Constraint (Rec_Type));
Discr : Entity_Id :=
First_Girder_Discriminant (Uparent_Type);
begin
while Original_Record_Component (Parent_Discr) /= Discr loop
Next_Girder_Discriminant (Discr);
Next_Elmt (Discr_Value);
end loop;
Arg := Node (Discr_Value);
end;
if Nkind (Arg) = N_Identifier
and then Ekind (Entity (Arg)) = E_Discriminant
then
Append_To (Args,
New_Reference_To (Discriminal (Entity (Arg)), Loc));
else
Append_To (Args, New_Copy (Arg));
end if;
Next_Discriminant (Parent_Discr);
end loop;
end if;
Res :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Parent_Proc, Loc),
Parameter_Associations => Args));
return Res;
end Build_Init_Call_Thru;
procedure Build_Init_Procedure is
Body_Node : Node_Id;
Handled_Stmt_Node : Node_Id;
Parameters : List_Id;
Proc_Spec_Node : Node_Id;
Body_Stmts : List_Id;
Record_Extension_Node : Node_Id;
Init_Tag : Node_Id;
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc);
Set_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
Parameters := Init_Formals (Rec_Type);
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
if Is_Tagged_Type (Rec_Type)
and then not Is_CPP_Class (Rec_Type)
then
Set_Tag :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => Set_Tag,
Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_True, Loc)));
end if;
Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
Set_Specification (Body_Node, Proc_Spec_Node);
Set_Declarations (Body_Node, New_List);
if Parent_Subtype_Renaming_Discrims then
Append_List_To (Body_Stmts,
Build_Init_Call_Thru (Parameters));
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
Build_Discriminant_Assignments (Body_Stmts);
if not Null_Present (Type_Definition (N)) then
Append_List_To (Body_Stmts,
Build_Init_Statements (
Component_List (Type_Definition (N))));
end if;
else
Build_Discriminant_Assignments (Body_Stmts);
Record_Extension_Node :=
Record_Extension_Part (Type_Definition (N));
if not Null_Present (Record_Extension_Node) then
declare
Stmts : List_Id :=
Build_Init_Statements (
Component_List (Record_Extension_Node));
begin
Prepend_To (Body_Stmts, Remove_Head (Stmts));
Append_List_To (Body_Stmts, Stmts);
end;
end if;
end if;
if Is_Tagged_Type (Rec_Type)
and then not Is_CPP_Class (Rec_Type)
and then not Java_VM
then
Init_Tag :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
New_Reference_To (Tag_Component (Rec_Type), Loc)),
Expression =>
New_Reference_To (Access_Disp_Table (Rec_Type), Loc));
Init_Tag :=
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => New_List (Init_Tag));
if not Is_CPP_Class (Etype (Rec_Type)) then
Prepend_To (Body_Stmts, Init_Tag);
else
declare
Nod : Node_Id := First (Body_Stmts);
begin
while Present (Next (Nod))
and then (Nkind (Nod) /= N_Procedure_Call_Statement
or else Chars (Name (Nod)) /= Name_uInit_Proc)
loop
Nod := Next (Nod);
end loop;
Insert_After (Nod, Init_Tag);
end;
end if;
end if;
Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
Set_Statements (Handled_Stmt_Node, Body_Stmts);
Set_Exception_Handlers (Handled_Stmt_Node, No_List);
Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
Set_Init_Proc (Rec_Type, Proc_Id);
if List_Length (Body_Stmts) = 1
and then Nkind (First (Body_Stmts)) = N_Null_Statement
then
Set_Is_Null_Init_Proc (Proc_Id);
end if;
end Build_Init_Procedure;
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
Alt_List : List_Id;
Statement_List : List_Id;
Stmts : List_Id;
Check_List : List_Id := New_List;
Per_Object_Constraint_Components : Boolean;
Decl : Node_Id;
Variant : Node_Id;
Id : Entity_Id;
Typ : Entity_Id;
begin
if Null_Present (Comp_List) then
return New_List (Make_Null_Statement (Loc));
end if;
Statement_List := New_List;
Per_Object_Constraint_Components := False;
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Loc := Sloc (Decl);
Build_Record_Checks
(Subtype_Indication (Decl),
Decl,
Check_List);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
if Has_Per_Object_Constraint (Id)
and then No (Expression (Decl))
then
Per_Object_Constraint_Components := True;
else
if Present (Expression (Decl)) then
Stmts := Build_Assignment (Id, Expression (Decl));
elsif Has_Non_Null_Base_Init_Proc (Typ) then
Stmts :=
Build_Initialization_Call (Loc,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ, True, Rec_Type, Discr_Map => Discr_Map);
elsif Component_Needs_Simple_Initialization (Typ) then
Stmts :=
Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc));
else
Stmts := No_List;
end if;
if Present (Check_List) then
Append_List_To (Statement_List, Check_List);
end if;
if Present (Stmts) then
if Chars (Id) = Name_uController
and then Rec_Type /= Etype (Rec_Type)
and then Has_Controlled_Component (Etype (Rec_Type))
and then Has_New_Controlled_Component (Rec_Type)
then
Insert_List_Before (Last (Statement_List), Stmts);
else
Append_List_To (Statement_List, Stmts);
end if;
end if;
end if;
Next_Non_Pragma (Decl);
end loop;
if Per_Object_Constraint_Components then
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Loc := Sloc (Decl);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
if Has_Per_Object_Constraint (Id)
and then No (Expression (Decl))
then
if Has_Non_Null_Base_Init_Proc (Typ) then
Append_List_To (Statement_List,
Build_Initialization_Call (Loc,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ, True, Rec_Type, Discr_Map => Discr_Map));
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Statement_List,
Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc)));
end if;
end if;
Next_Non_Pragma (Decl);
end loop;
end if;
if Present (Variant_Part (Comp_List)) then
Alt_List := New_List;
Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (Variant) loop
Loc := Sloc (Variant);
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_Copy_List (Discrete_Choices (Variant)),
Statements =>
Build_Init_Statements (Component_List (Variant))));
Next_Non_Pragma (Variant);
end loop;
Append_To (Statement_List,
Make_Case_Statement (Loc,
Expression =>
New_Reference_To (Discriminal (
Entity (Name (Variant_Part (Comp_List)))), Loc),
Alternatives => Alt_List));
end if;
if Is_Task_Record_Type (Rec_Type) then
Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
Task_Decl : constant Node_Id := Parent (Task_Type);
Task_Def : constant Node_Id := Task_Definition (Task_Decl);
Vis_Decl : Node_Id;
Ent : Entity_Id;
begin
if Present (Task_Def) then
Vis_Decl := First (Visible_Declarations (Task_Def));
while Present (Vis_Decl) loop
Loc := Sloc (Vis_Decl);
if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
if Get_Attribute_Id (Chars (Vis_Decl)) =
Attribute_Address
then
Ent := Entity (Name (Vis_Decl));
if Ekind (Ent) = E_Entry then
Append_To (Statement_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
RTE (RE_Bind_Interrupt_To_Entry), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uInit),
Selector_Name =>
Make_Identifier (Loc, Name_uTask_Id)),
Entry_Index_Expression (
Loc, Ent, Empty, Task_Type),
Expression (Vis_Decl))));
end if;
end if;
end if;
Next (Vis_Decl);
end loop;
end if;
end;
end if;
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Statement_List,
Make_Initialize_Protection (Rec_Type));
end if;
if Is_Empty_List (Statement_List) then
Append (New_Node (N_Null_Statement, Loc), Statement_List);
end if;
return Statement_List;
end Build_Init_Statements;
procedure Build_Record_Checks
(S : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id)
is
P : Node_Id;
Subtype_Mark_Id : Entity_Id;
begin
if Nkind (S) = N_Subtype_Indication then
Find_Type (Subtype_Mark (S));
P := Parent (S);
Subtype_Mark_Id := Entity (Subtype_Mark (S));
case Ekind (Subtype_Mark_Id) is
when Array_Kind =>
Constrain_Array (S, Related_Nod, Check_List);
when others =>
null;
end case;
end if;
end Build_Record_Checks;
function Component_Needs_Simple_Initialization
(T : Entity_Id)
return Boolean
is
begin
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
and then not Is_RTE (T, RE_Vtable_Ptr);
end Component_Needs_Simple_Initialization;
procedure Constrain_Array
(SI : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id)
is
C : constant Node_Id := Constraint (SI);
Number_Of_Constraints : Nat := 0;
Index : Node_Id;
S, T : Entity_Id;
begin
T := Entity (Subtype_Mark (SI));
if Ekind (T) in Access_Kind then
T := Designated_Type (T);
end if;
S := First (Constraints (C));
while Present (S) loop
Number_Of_Constraints := Number_Of_Constraints + 1;
Next (S);
end loop;
S := First (Constraints (C));
Index := First_Index (T);
Analyze (Index);
for J in 1 .. Number_Of_Constraints loop
Constrain_Index (Index, S, Related_Nod, Check_List);
Next (Index);
Next (S);
end loop;
end Constrain_Array;
procedure Constrain_Index
(Index : Node_Id;
S : Node_Id;
Related_Nod : Node_Id;
Check_List : List_Id)
is
T : constant Entity_Id := Etype (Index);
begin
if Nkind (S) = N_Range then
Process_Range_Expr_In_Decl (S, T, Related_Nod, Check_List);
end if;
end Constrain_Index;
function Parent_Subtype_Renaming_Discrims return Boolean is
De : Entity_Id;
Dp : Entity_Id;
begin
if Base_Type (Pe) /= Pe then
return False;
end if;
if Etype (Pe) = Pe
or else not Has_Discriminants (Pe)
or else Is_Constrained (Pe)
or else Is_Tagged_Type (Pe)
then
return False;
end if;
if First_Discriminant (Pe) = First_Girder_Discriminant (Pe) then
return False;
end if;
De := First_Discriminant (Pe);
Dp := First_Discriminant (Etype (Pe));
while Present (De) loop
pragma Assert (Present (Dp));
if Corresponding_Discriminant (De) /= Dp then
return True;
end if;
Next_Discriminant (De);
Next_Discriminant (Dp);
end loop;
return Present (Dp);
end Parent_Subtype_Renaming_Discrims;
function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
Comp_Decl : Node_Id;
Id : Entity_Id;
Typ : Entity_Id;
begin
if Suppress_Init_Proc (Rec_Id) then
return False;
end if;
if Is_CPP_Class (Rec_Id) then
return False;
elsif Is_Public (Rec_Id) then
return True;
elsif (Has_Discriminants (Rec_Id)
and then not Is_Unchecked_Union (Rec_Id))
or else Is_Tagged_Type (Rec_Id)
or else Is_Concurrent_Record_Type (Rec_Id)
or else Has_Task (Rec_Id)
then
return True;
end if;
Id := First_Component (Rec_Id);
while Present (Id) loop
Comp_Decl := Parent (Id);
Typ := Etype (Id);
if Present (Expression (Comp_Decl))
or else Has_Non_Null_Base_Init_Proc (Typ)
or else Component_Needs_Simple_Initialization (Typ)
then
return True;
end if;
Next_Component (Id);
end loop;
return False;
end Requires_Init_Proc;
begin
Rec_Type := Defining_Identifier (N);
if Is_Incomplete_Or_Private_Type (Rec_Type) then
Rec_Type := Underlying_Type (Rec_Type);
end if;
if Is_Concurrent_Record_Type (Rec_Type)
and then Has_Discriminants (Rec_Type)
then
declare
Disc : Entity_Id;
begin
Disc := First_Discriminant (Rec_Type);
while Present (Disc) loop
Append_Elmt (Disc, Discr_Map);
Append_Elmt (Discriminal (Disc), Discr_Map);
Next_Discriminant (Disc);
end loop;
end;
end if;
if Is_Derived_Type (Rec_Type)
and then not Is_Tagged_Type (Rec_Type)
and then not Has_New_Non_Standard_Rep (Rec_Type)
and then not Parent_Subtype_Renaming_Discrims
and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
then
Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
elsif Requires_Init_Proc (Rec_Type) then
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
if not Is_Protected_Record_Type (Rec_Type)
and then not Controlled_Type (Rec_Type)
then
Set_Is_Inlined (Proc_Id);
end if;
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Proc_Id);
end if;
end if;
end Build_Record_Init_Proc;
procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
F : constant Entity_Id := Make_Defining_Identifier (Loc,
Name_uEquality);
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
Def : constant Node_Id := Parent (Typ);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
Function_Body : Node_Id;
Stmts : List_Id := New_List;
begin
if Is_Derived_Type (Typ)
and then not Has_New_Non_Standard_Rep (Typ)
then
declare
Parent_Eq : Entity_Id := TSS (Root_Type (Typ), Name_uEquality);
begin
if Present (Parent_Eq) then
Copy_TSS (Parent_Eq, Typ);
return;
end if;
end;
end if;
Function_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
Parameter_Specifications => 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))),
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
if Has_Unchecked_Union (Typ) then
Append_To (Stmts,
Make_Raise_Program_Error (Loc));
else
Append_To (Stmts,
Make_Eq_If (Typ,
Discriminant_Specifications (Def)));
Append_List_To (Stmts,
Make_Eq_Case (Typ, Comps));
end if;
Append_To (Stmts,
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc)));
Set_TSS (Typ, F);
Set_Is_Pure (F);
if not Debug_Generated_Code then
Set_Debug_Info_Off (F);
end if;
end Build_Variant_Record_Equality;
procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (Def);
Loc : constant Source_Ptr := Sloc (Def);
Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
Par_Subtype : Entity_Id;
Comp_List : Node_Id;
Comp_Decl : Node_Id;
Parent_N : Node_Id;
D : Entity_Id;
List_Constr : constant List_Id := New_List;
begin
if not Expander_Active then
return;
end if;
if No (Rec_Ext_Part) then
Rec_Ext_Part :=
Make_Record_Definition (Loc,
End_Label => Empty,
Component_List => Empty,
Null_Present => True);
Set_Record_Extension_Part (Def, Rec_Ext_Part);
Mark_Rewrite_Insertion (Rec_Ext_Part);
end if;
Comp_List := Component_List (Rec_Ext_Part);
Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
if Has_Discriminants (T)
and then Nkind (Indic) /= N_Subtype_Indication
and then not Is_Constrained (Entity (Indic))
then
D := First_Discriminant (T);
while (Present (D)) loop
Append_To (List_Constr, New_Occurrence_Of (D, Loc));
Next_Discriminant (D);
end loop;
Par_Subtype :=
Process_Subtype (
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Entity (Indic), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => List_Constr)),
Def);
else
Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
end if;
Set_Parent_Subtype (T, Par_Subtype);
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Parent_N,
Subtype_Indication => New_Reference_To (Par_Subtype, Loc));
if Null_Present (Rec_Ext_Part) then
Set_Component_List (Rec_Ext_Part,
Make_Component_List (Loc,
Component_Items => New_List (Comp_Decl),
Variant_Part => Empty,
Null_Present => False));
Set_Null_Present (Rec_Ext_Part, False);
elsif Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
then
Set_Component_Items (Comp_List, New_List (Comp_Decl));
Set_Null_Present (Comp_List, False);
else
Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
end if;
Analyze (Comp_Decl);
end Expand_Derived_Record;
procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
B_Id : Entity_Id := Base_Type (Def_Id);
Par_Id : Entity_Id;
FN : Node_Id;
begin
if Is_Access_Type (Def_Id) then
if Has_Task (Designated_Type (Def_Id))
and then Comes_From_Source (N)
then
Build_Master_Entity (Def_Id);
Build_Master_Renaming (Parent (Def_Id), Def_Id);
elsif Is_Class_Wide_Type (Designated_Type (Def_Id))
and then Is_Limited_Type (Designated_Type (Def_Id))
and then Tasking_Allowed
and then Convention (Designated_Type (Def_Id)) /= Convention_Java
then
Build_Class_Wide_Master (Def_Id);
elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
Expand_Access_Protected_Subprogram_Type (N);
end if;
elsif Has_Task (Def_Id) then
Expand_Previous_Access_Type (N, Def_Id);
end if;
Par_Id := Etype (B_Id);
if Ekind (Par_Id) in Private_Kind
and then Present (Full_View (Par_Id))
then
Par_Id := Base_Type (Full_View (Par_Id));
end if;
if Nkind (Type_Definition (Original_Node (N)))
= N_Derived_Type_Definition
and then not Is_Tagged_Type (Def_Id)
and then Present (Freeze_Node (Par_Id))
and then Present (TSS_Elist (Freeze_Node (Par_Id)))
then
Ensure_Freeze_Node (B_Id);
FN := Freeze_Node (B_Id);
if No (TSS_Elist (FN)) then
Set_TSS_Elist (FN, New_Elmt_List);
end if;
declare
T_E : Elist_Id := TSS_Elist (FN);
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
while Present (Elmt) loop
if Chars (Node (Elmt)) /= Name_uInit then
Append_Elmt (Node (Elmt), T_E);
end if;
Next_Elmt (Elmt);
end loop;
if Ekind (B_Id) in Private_Kind
and then Present (Full_View (B_Id))
then
Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
Set_TSS_Elist
(Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
end if;
end;
end if;
end Expand_N_Full_Type_Declaration;
procedure Expand_N_Object_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Typ : constant Entity_Id := Etype (Def_Id);
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id := Expression (N);
New_Ref : Node_Id;
Id_Ref : Node_Id;
Expr_Q : Node_Id;
begin
if No (Expr) and Constant_Present (N) then
return;
end if;
if Is_Shared_Passive (Def_Id) then
Make_Shared_Var_Procs (N);
end if;
if Has_Task (Typ) then
Build_Activation_Chain_Entity (N);
Build_Master_Entity (Def_Id);
end if;
if No (Expr) then
if not Controlled_Type (Typ)
or else No_Initialization (N)
then
null;
elsif not Abort_Allowed
or else not Comes_From_Source (N)
then
Insert_Actions_After (N,
Make_Init_Call (
Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ),
Flist_Ref => Find_Final_List (Def_Id),
With_Attach => Make_Integer_Literal (Loc, 1)));
else
declare
L : constant List_Id :=
Make_Init_Call (
Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ),
Flist_Ref => Find_Final_List (Def_Id),
With_Attach => Make_Integer_Literal (Loc, 1));
Blk : constant Node_Id :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, L));
begin
Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
Set_At_End_Proc (Handled_Statement_Sequence (Blk),
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
Insert_Actions_After (N, New_List (Blk));
Expand_At_End_Handler
(Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
end;
end if;
if Has_Non_Null_Base_Init_Proc (Typ)
and then not No_Initialization (N)
then
Id_Ref := New_Reference_To (Def_Id, Loc);
Set_Must_Not_Freeze (Id_Ref);
Set_Assignment_OK (Id_Ref);
Insert_Actions_After (N,
Build_Initialization_Call (Loc, Id_Ref, Typ));
elsif Needs_Simple_Initialization (Typ) then
Set_No_Initialization (N, False);
Set_Expression (N, Get_Simple_Init_Val (Typ, Loc));
Analyze_And_Resolve (Expression (N), Typ);
end if;
else
if Nkind (Expr) = N_Qualified_Expression then
Expr_Q := Expression (Expr);
else
Expr_Q := Expr;
end if;
if Is_Delayed_Aggregate (Expr_Q) then
Convert_Aggr_In_Object_Decl (N);
else
if not Is_Constr_Subt_For_U_Nominal (Typ) then
if Nkind (Expr) = N_Allocator
and then No_Initialization (Expr)
then
null;
else
Apply_Constraint_Check (Expr, Typ);
end if;
end if;
if Controlled_Type (Typ) then
declare
Flist : Node_Id;
F : Entity_Id;
begin
if Delay_Finalize_Attach (N) then
F :=
Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
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);
else
Flist := Find_Final_List (Def_Id);
end if;
Insert_Actions_After (N,
Make_Adjust_Call (
Ref => New_Reference_To (Def_Id, Loc),
Typ => Base_Type (Typ),
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, 1)));
end;
end if;
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then not Java_VM
then
New_Ref :=
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Def_Id, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc));
Set_Assignment_OK (New_Ref);
Insert_After (N,
Make_Assignment_Statement (Loc,
Name => New_Ref,
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Access_Disp_Table (Base_Type (Typ)), Loc))));
elsif Is_Discrete_Type (Typ)
and then Expr_Known_Valid (Expr)
then
Set_Is_Known_Valid (Def_Id);
end if;
if Validity_Checks_On
and then Validity_Check_Copies
then
Ensure_Valid (Expr);
Set_Is_Known_Valid (Def_Id);
end if;
end if;
end if;
if Is_Array_Type (Typ) then
Apply_Array_Size_Check (N, Typ);
end if;
end Expand_N_Object_Declaration;
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : Node_Id := Range_Expression (Constraint (N));
Typ : Entity_Id := Entity (Subtype_Mark (N));
begin
if Nkind (Parent (N)) = N_Constrained_Array_Definition or else
Nkind (Parent (N)) = N_Slice
then
Resolve (Ran, Typ);
Apply_Range_Check (Ran, Typ);
end if;
end Expand_N_Subtype_Indication;
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
begin
if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Last_Var));
Set_Others_Discrete_Choices
(Others_Node, Discrete_Choices (Last_Var));
Set_Discrete_Choices (Last_Var, New_List (Others_Node));
end if;
end Expand_N_Variant_Part;
procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is
T : Entity_Id := First_Entity (Current_Scope);
begin
while Present (T) loop
if Is_Access_Type (T)
and then Designated_Type (T) = Def_Id
then
Build_Master_Entity (Def_Id);
Build_Master_Renaming (Parent (Def_Id), T);
end if;
Next_Entity (T);
end loop;
end Expand_Previous_Access_Type;
procedure Expand_Record_Controller (T : Entity_Id) is
Def : Node_Id := Type_Definition (Parent (T));
Comp_List : Node_Id;
Comp_Decl : Node_Id;
Loc : Source_Ptr;
First_Comp : Node_Id;
Controller_Type : Entity_Id;
Ent : Entity_Id;
begin
if Nkind (Def) = N_Derived_Type_Definition then
Def := Record_Extension_Part (Def);
end if;
if Null_Present (Def) then
Set_Component_List (Def,
Make_Component_List (Sloc (Def),
Component_Items => Empty_List,
Variant_Part => Empty,
Null_Present => True));
end if;
Comp_List := Component_List (Def);
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
then
Loc := Sloc (Comp_List);
else
Loc := Sloc (First (Component_Items (Comp_List)));
end if;
if Is_Return_By_Reference_Type (T) then
Controller_Type := RTE (RE_Limited_Record_Controller);
else
Controller_Type := RTE (RE_Record_Controller);
end if;
Ent := Make_Defining_Identifier (Loc, Name_uController);
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Ent,
Subtype_Indication => New_Reference_To (Controller_Type, Loc));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
then
Set_Component_Items (Comp_List, New_List (Comp_Decl));
Set_Null_Present (Comp_List, False);
else
First_Comp := First (Component_Items (Comp_List));
if Chars (Defining_Identifier (First_Comp)) /= Name_uParent
and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag
then
Insert_Before (First_Comp, Comp_Decl);
else
Insert_After (First_Comp, Comp_Decl);
end if;
end if;
New_Scope (T);
Analyze (Comp_Decl);
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
declare
E : Entity_Id := Last_Entity (T);
Comp : Entity_Id;
begin
pragma Assert (Chars (E) = Name_uController);
Set_Next_Entity (E, First_Entity (T));
Set_First_Entity (T, E);
Comp := Next_Entity (E);
while Next_Entity (Comp) /= E loop
Next_Entity (Comp);
end loop;
Set_Next_Entity (Comp, Empty);
Set_Last_Entity (T, Comp);
end;
End_Scope;
end Expand_Record_Controller;
procedure Expand_Tagged_Root (T : Entity_Id) is
Def : constant Node_Id := Type_Definition (Parent (T));
Comp_List : Node_Id;
Comp_Decl : Node_Id;
Sloc_N : Source_Ptr;
begin
if Null_Present (Def) then
Set_Component_List (Def,
Make_Component_List (Sloc (Def),
Component_Items => Empty_List,
Variant_Part => Empty,
Null_Present => True));
end if;
Comp_List := Component_List (Def);
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
then
Sloc_N := Sloc (Comp_List);
else
Sloc_N := Sloc (First (Component_Items (Comp_List)));
end if;
Comp_Decl :=
Make_Component_Declaration (Sloc_N,
Defining_Identifier => Tag_Component (T),
Subtype_Indication =>
New_Reference_To (RTE (RE_Tag), Sloc_N));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
then
Set_Component_Items (Comp_List, New_List (Comp_Decl));
Set_Null_Present (Comp_List, False);
else
Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
end if;
Find_Type (Subtype_Indication (Comp_Decl));
end Expand_Tagged_Root;
procedure Freeze_Array_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Base : constant Entity_Id := Base_Type (Typ);
begin
if not Is_Bit_Packed_Array (Typ) then
Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
Set_Has_Controlled_Component (Base,
Has_Controlled_Component (Component_Type (Typ))
or else Is_Controlled (Component_Type (Typ)));
if No (Init_Proc (Base)) then
if Is_Itype (Base)
and then Nkind (Associated_Node_For_Itype (Base)) =
N_Object_Declaration
and then (Present (Expression (Associated_Node_For_Itype (Base)))
or else
No_Initialization (Associated_Node_For_Itype (Base)))
then
null;
elsif Base = Standard_String
or else Base = Standard_Wide_String
then
null;
else
Build_Array_Init_Proc (Base, N);
end if;
end if;
if Typ = Base and then Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
end if;
end if;
end Freeze_Array_Type;
procedure Freeze_Enumeration_Type (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Entity (N);
Ent : Entity_Id;
Lst : List_Id;
Num : Nat;
Arr : Entity_Id;
Fent : Entity_Id;
Func : Entity_Id;
Ityp : Entity_Id;
begin
Lst := New_List;
Num := 0;
Ent := First_Literal (Typ);
while Present (Ent) loop
Append_To (Lst, New_Reference_To (Ent, Sloc (Ent)));
Num := Num + 1;
Next_Literal (Ent);
end loop;
Arr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'A'));
Append_Freeze_Action (Typ,
Make_Object_Declaration (Loc,
Defining_Identifier => Arr,
Constant_Present => True,
Object_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
Low_Bound =>
Make_Integer_Literal (Loc, 0),
High_Bound =>
Make_Integer_Literal (Loc, Num - 1))))),
Subtype_Indication => New_Reference_To (Typ, Loc)),
Expression =>
Make_Aggregate (Loc,
Expressions => Lst)));
Set_Enum_Pos_To_Rep (Typ, Arr);
Lst := New_List;
Ent := First_Literal (Typ);
while Present (Ent) loop
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (
Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
Intval => Enumeration_Rep (Ent))),
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc,
Intval => Enumeration_Pos (Ent))))));
Next_Literal (Ent);
end loop;
if Enumeration_Rep (First_Literal (Typ)) < 0 then
if Esize (Typ) <= Standard_Integer_Size then
Ityp := Standard_Integer;
else
Ityp := Universal_Integer;
end if;
else
if Esize (Typ) <= Standard_Integer_Size then
Ityp := RTE (RE_Unsigned);
else
Ityp := RTE (RE_Long_Long_Unsigned);
end if;
end if;
if not (No_Run_Time or Restrictions (No_Exceptions)) then
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_Raise_Program_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF)),
Make_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
else
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
end if;
Fent :=
Make_Defining_Identifier (Loc, Name_uRep_To_Pos);
Func :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Fent,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uA),
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Case_Statement (Loc,
Expression =>
Unchecked_Convert_To (Ityp,
Make_Identifier (Loc, Name_uA)),
Alternatives => Lst))));
Set_TSS (Typ, Fent);
Set_Is_Pure (Fent);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Fent);
end if;
end Freeze_Enumeration_Type;
procedure Freeze_Record_Type (N : Node_Id) is
Def_Id : constant Node_Id := Entity (N);
Comp : Entity_Id;
Type_Decl : constant Node_Id := Parent (Def_Id);
Predef_List : List_Id;
Renamed_Eq : Node_Id := Empty;
begin
if not Is_Derived_Type (Def_Id)
or else Has_New_Non_Standard_Rep (Def_Id)
or else Is_Tagged_Type (Def_Id)
then
Build_Discr_Checking_Funcs (Type_Decl);
elsif Is_Derived_Type (Def_Id)
and then not Is_Tagged_Type (Def_Id)
and then Has_Discriminants (Def_Id)
then
declare
Old_Comp : Entity_Id;
begin
Old_Comp :=
First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
Comp := First_Component (Def_Id);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Chars (Comp) = Chars (Old_Comp)
then
Set_Discriminant_Checking_Func (Comp,
Discriminant_Checking_Func (Old_Comp));
end if;
Next_Component (Old_Comp);
Next_Component (Comp);
end loop;
end;
end if;
Comp := First_Component (Def_Id);
while Present (Comp) loop
if Has_Task (Etype (Comp)) then
Set_Has_Task (Def_Id);
elsif Has_Controlled_Component (Etype (Comp))
or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp)))
then
Set_Has_Controlled_Component (Def_Id);
end if;
Next_Component (Comp);
end loop;
if Is_Tagged_Type (Def_Id) then
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id);
Set_Default_Constructor (Def_Id);
else
if Is_CPP_Class (Etype (Def_Id)) then
declare
Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
Subp : Entity_Id;
begin
while Present (Elmt) loop
Subp := Node (Elmt);
if Present (Alias (Subp)) then
Set_Has_Delayed_Freeze (Subp);
end if;
Next_Elmt (Elmt);
end loop;
end;
end if;
if Underlying_Type (Etype (Def_Id)) = Def_Id then
Expand_Tagged_Root (Def_Id);
end if;
Set_Is_Frozen (Def_Id, False);
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
Set_Is_Frozen (Def_Id, True);
Set_All_DT_Position (Def_Id);
if Has_New_Controlled_Component (Def_Id) then
Expand_Record_Controller (Def_Id);
end if;
if not Java_VM then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
if Is_Controlled (Def_Id) then
if not Is_Limited_Type (Def_Id) then
Append_Freeze_Actions (Def_Id,
Freeze_Entity
(Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id)));
end if;
Append_Freeze_Actions (Def_Id,
Freeze_Entity
(Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id)));
Append_Freeze_Actions (Def_Id,
Freeze_Entity
(Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id)));
end if;
Append_Freeze_Actions
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
end if;
elsif Has_Discriminants (Def_Id)
and then not Is_Limited_Type (Def_Id)
then
declare
Comps : constant Node_Id :=
Component_List (Type_Definition (Type_Decl));
begin
if Present (Comps)
and then Present (Variant_Part (Comps))
and then not Is_Unchecked_Union (Def_Id)
then
Build_Variant_Record_Equality (Def_Id);
end if;
end;
end if;
if Is_Concurrent_Record_Type (Def_Id)
and then Has_Discriminants (Def_Id)
then
declare
Ctyp : constant Entity_Id :=
Corresponding_Concurrent_Type (Def_Id);
Conc_Discr : Entity_Id;
Rec_Discr : Entity_Id;
Temp : Entity_Id;
begin
Conc_Discr := First_Discriminant (Ctyp);
Rec_Discr := First_Discriminant (Def_Id);
while Present (Conc_Discr) loop
Temp := Discriminal (Conc_Discr);
Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
Set_Discriminal (Rec_Discr, Temp);
Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
Next_Discriminant (Conc_Discr);
Next_Discriminant (Rec_Discr);
end loop;
end;
end if;
if Has_Controlled_Component (Def_Id) then
if No (Controller_Component (Def_Id)) then
Expand_Record_Controller (Def_Id);
end if;
Build_Controlling_Procs (Def_Id);
end if;
Adjust_Discriminants (Def_Id);
Build_Record_Init_Proc (Type_Decl, Def_Id);
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
end if;
end Freeze_Record_Type;
procedure Freeze_Type (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (N);
begin
if Present (Access_Types_To_Process (N)) then
declare
E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
begin
while Present (E) loop
if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
Remote_Types_Tagged_Full_View_Encountered (Def_Id);
end if;
E := Next_Elmt (E);
end loop;
end;
end if;
if Is_Record_Type (Def_Id) then
if Ekind (Def_Id) = E_Record_Type then
Freeze_Record_Type (N);
elsif Ekind (Def_Id) = E_Record_Subtype
and then Has_Discriminants (Def_Id)
and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id))
and then Present (Controller_Component (Def_Id))
then
declare
Old_C : Entity_Id := Controller_Component (Def_Id);
New_C : Entity_Id;
begin
if Scope (Old_C) = Base_Type (Def_Id) then
New_C := New_Copy (Old_C);
Set_Parent (New_C, Parent (Old_C));
New_Scope (Def_Id);
Enter_Name (New_C);
End_Scope;
end if;
end;
end if;
elsif Is_Array_Type (Def_Id) then
Freeze_Array_Type (N);
elsif Ekind (Def_Id) = E_Access_Type
or else Ekind (Def_Id) = E_General_Access_Type
then
declare
Loc : constant Source_Ptr := Sloc (N);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Pool_Object : Entity_Id;
Siz_Exp : Node_Id;
Freeze_Action_Typ : Entity_Id;
begin
if Has_Storage_Size_Clause (Def_Id) then
Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
else
Siz_Exp := Empty;
end if;
if Has_Storage_Size_Clause (Def_Id)
and then Compile_Time_Known_Value (Siz_Exp)
and then Expr_Value (Siz_Exp) = 0
then
null;
elsif Has_Storage_Size_Clause (Def_Id) then
declare
DT_Size : Node_Id;
DT_Align : Node_Id;
begin
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
then
DT_Size :=
Make_Integer_Literal (Loc, 0);
DT_Align :=
Make_Integer_Literal (Loc, Maximum_Alignment);
else
DT_Size :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Desig_Type, Loc),
Attribute_Name => Name_Max_Size_In_Storage_Elements);
DT_Align :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Desig_Type, Loc),
Attribute_Name => Name_Alignment);
end if;
Pool_Object :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Def_Id), 'P'));
if Is_Frozen (Desig_Type)
and then (not Present (Freeze_Node (Desig_Type))
or else Analyzed (Freeze_Node (Desig_Type)))
then
Freeze_Action_Typ := Def_Id;
elsif Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
then
Freeze_Action_Typ := Def_Id;
else
Freeze_Action_Typ := Desig_Type;
end if;
Append_Freeze_Action (Freeze_Action_Typ,
Make_Object_Declaration (Loc,
Defining_Identifier => Pool_Object,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Reference_To
(RTE (RE_Stack_Bounded_Pool), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
New_Reference_To (
Storage_Size_Variable (Def_Id), Loc),
DT_Size,
DT_Align)))));
end;
Set_Associated_Storage_Pool (Def_Id, Pool_Object);
elsif Present (Associated_Storage_Pool (Def_Id)) then
null;
end if;
if not Comes_From_Source (Def_Id)
and then not Has_Private_Declaration (Def_Id)
then
null;
elsif (Controlled_Type (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java)
or else (Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
and then not In_Runtime (Def_Id)
and then not No_Run_Time)
or else (Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
and then Controlled_Type (Component_Type (Desig_Type)))
then
Set_Associated_Final_Chain (Def_Id,
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Def_Id), 'L')));
Append_Freeze_Action (Def_Id,
Make_Object_Declaration (Loc,
Defining_Identifier => Associated_Final_Chain (Def_Id),
Object_Definition =>
New_Reference_To (RTE (RE_List_Controller), Loc)));
end if;
end;
elsif Ekind (Def_Id) = E_Enumeration_Type then
if Has_Non_Standard_Rep (Def_Id) then
Freeze_Enumeration_Type (N);
end if;
elsif Is_Private_Type (Def_Id)
and then Is_Derived_Type (Def_Id)
and then Present (Full_View (Def_Id))
and then Is_Itype (Full_View (Def_Id))
and then Has_Private_Declaration (Full_View (Def_Id))
and then Freeze_Node (Full_View (Def_Id)) = N
then
Set_Entity (N, Full_View (Def_Id));
Freeze_Type (N);
Set_Entity (N, Def_Id);
end if;
end Freeze_Type;
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr)
return Node_Id
is
Val : Node_Id;
Typ : Node_Id;
Result : Node_Id;
Val_RE : RE_Id;
begin
if Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
if Normalize_Scalars then
if Is_Real_Type (T) or else Is_Integer_Type (T) then
Val :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Base_Type (T), Loc),
Attribute_Name => Name_First);
elsif Is_Modular_Integer_Type (T) then
Val :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Base_Type (T), Loc),
Attribute_Name => Name_Last);
else
pragma Assert (Is_Enumeration_Type (T));
if Esize (T) <= 8 then
Typ := RTE (RE_Unsigned_8);
elsif Esize (T) <= 16 then
Typ := RTE (RE_Unsigned_16);
elsif Esize (T) <= 32 then
Typ := RTE (RE_Unsigned_32);
else
Typ := RTE (RE_Unsigned_64);
end if;
Val :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Last);
end if;
else
if Is_Floating_Point_Type (T) then
if Root_Type (T) = Standard_Short_Float then
Val_RE := RE_IS_Isf;
elsif Root_Type (T) = Standard_Float then
Val_RE := RE_IS_Ifl;
elsif Esize (Root_Type (T)) = Esize (Standard_Long_Float) then
Val_RE := RE_IS_Ilf;
else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
Val_RE := RE_IS_Ill;
end if;
elsif Is_Unsigned_Type (Base_Type (T)) then
if Esize (T) = 8 then
Val_RE := RE_IS_Iu1;
elsif Esize (T) = 16 then
Val_RE := RE_IS_Iu2;
elsif Esize (T) = 32 then
Val_RE := RE_IS_Iu4;
else pragma Assert (Esize (T) = 64);
Val_RE := RE_IS_Iu8;
end if;
else if Esize (T) = 8 then
Val_RE := RE_IS_Is1;
elsif Esize (T) = 16 then
Val_RE := RE_IS_Is2;
elsif Esize (T) = 32 then
Val_RE := RE_IS_Is4;
else pragma Assert (Esize (T) = 64);
Val_RE := RE_IS_Is8;
end if;
end if;
Val := New_Occurrence_Of (RTE (Val_RE), Loc);
end if;
Result := Unchecked_Convert_To (Base_Type (T), Val);
if Nkind (Result) = N_Unchecked_Type_Conversion then
Set_Kill_Range_Check (Result, True);
end if;
return Result;
elsif Root_Type (T) = Standard_String
or else
Root_Type (T) = Standard_Wide_String
then
pragma Assert (Init_Or_Norm_Scalars);
return
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val (Component_Type (T), Loc))));
elsif Is_Access_Type (T) then
return
Make_Null (Loc);
elsif Is_Bit_Packed_Array (T) then
declare
PAT : constant Entity_Id := Packed_Array_Type (T);
Nod : Node_Id;
begin
pragma Assert (Is_Modular_Integer_Type (PAT));
Nod :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Expression => Make_Integer_Literal (Loc, 0));
Set_Etype (Expression (Nod), PAT);
return Nod;
end;
else
pragma Assert
(Is_Private_Type (T)
and then Present (Underlying_Type (T)));
Val := Get_Simple_Init_Val (Underlying_Type (T), Loc);
if Nkind (Val) = N_Null
or else Nkind (Val) = N_Aggregate
then
Val :=
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Occurrence_Of (Underlying_Type (T), Loc),
Expression => Val);
end if;
return Unchecked_Convert_To (T, Val);
end if;
end Get_Simple_Init_Val;
function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
begin
if not Is_Derived_Type (T) then
return Has_Non_Standard_Rep (T)
or else Has_Non_Standard_Rep (Root_Type (T));
elsif not Has_Non_Standard_Rep (T) then
return False;
else
return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
end if;
end Has_New_Non_Standard_Rep;
function In_Runtime (E : Entity_Id) return Boolean is
S1 : Entity_Id := Scope (E);
begin
while Scope (S1) /= Standard_Standard loop
S1 := Scope (S1);
end loop;
return Chars (S1) = Name_System or else Chars (S1) = Name_Ada;
end In_Runtime;
function Init_Formals (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Formals : List_Id;
begin
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Reference_To (Typ, Loc)));
if Has_Task (Typ)
or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
then
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc)));
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uChain),
In_Present => True,
Out_Present => True,
Parameter_Type =>
New_Reference_To (RTE (RE_Activation_Chain), Loc)));
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uTask_Id),
In_Present => True,
Parameter_Type =>
New_Reference_To (RTE (RE_Task_Image_Type), Loc)));
end if;
return Formals;
end Init_Formals;
function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Node);
Variant : Node_Id;
Alt_List : List_Id;
Result : List_Id := New_List;
begin
Append_To (Result, Make_Eq_If (Node, Component_Items (CL)));
if No (Variant_Part (CL)) then
return Result;
end if;
Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
if No (Variant) then
return Result;
end if;
Alt_List := New_List;
while Present (Variant) loop
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
Statements => Make_Eq_Case (Node, Component_List (Variant))));
Next_Non_Pragma (Variant);
end loop;
Append_To (Result,
Make_Case_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Selector_Name => New_Copy (Name (Variant_Part (CL)))),
Alternatives => Alt_List));
return Result;
end Make_Eq_Case;
function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Node);
C : Node_Id;
Field_Name : Name_Id;
Cond : Node_Id;
begin
if No (L) then
return Make_Null_Statement (Loc);
else
Cond := Empty;
C := First_Non_Pragma (L);
while Present (C) loop
Field_Name := Chars (Defining_Identifier (C));
if Field_Name /= Name_uTag then
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Selector_Name =>
Make_Identifier (Loc, Field_Name)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_Y),
Selector_Name =>
Make_Identifier (Loc, Field_Name))));
end if;
Next_Non_Pragma (C);
end loop;
if No (Cond) then
return Make_Null_Statement (Loc);
else
return
Make_Implicit_If_Statement (Node,
Condition => Cond,
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end if;
end if;
end Make_Eq_If;
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_Id;
Renamed_Eq : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : List_Id := New_List;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
Eq_Name : Name_Id := Name_Op_Eq;
function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
begin
return Chars (Prim) /= Name_Op_Eq
and then Present (Alias (Prim))
and then Comes_From_Source (Prim)
and then Is_Intrinsic_Subprogram (Alias (Prim))
and then Chars (Alias (Prim)) = Name_Op_Eq;
end Is_Predefined_Eq_Renaming;
begin
Renamed_Eq := Empty;
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uSize,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Long_Long_Integer));
if not (No_Run_Time or else Is_Limited_Type (Tag_Typ)) then
Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uRead));
Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uWrite));
Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uInput));
Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uOutput));
end if;
if not Is_Limited_Type (Tag_Typ) then
Eq_Needed := True;
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
if Is_Predefined_Eq_Renaming (Node (Prim)) then
Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
elsif Chars (Node (Prim)) = Name_Op_Eq
and then (No (Alias (Node (Prim)))
or else Nkind (Unit_Declaration_Node (Node (Prim))) =
N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
then
Eq_Needed := False;
exit;
elsif Chars (Node (Prim)) = Name_Op_Eq
and then Present (Alias (Node (Prim)))
and then Is_Abstract (Alias (Node (Prim)))
then
Eq_Needed := False;
exit;
end if;
Next_Elmt (Prim);
end loop;
if Eq_Name /= Name_Op_Eq then
if Eq_Needed then
Eq_Name := Name_Op_Eq;
else
Eq_Needed := True;
end if;
end if;
if Eq_Needed then
Eq_Spec := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Eq_Name,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean);
Append_To (Res, Eq_Spec);
if Eq_Name /= Name_Op_Eq then
Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
if Is_Predefined_Eq_Renaming (Node (Prim)) then
Set_Alias (Node (Prim), Renamed_Eq);
elsif Chars (Node (Prim)) = Name_Op_Eq
and then No (Alias (Node (Prim)))
then
exit;
end if;
Next_Elmt (Prim);
end loop;
end if;
end if;
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAssign,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
end if;
if In_Finalization_Root (Tag_Typ) then
null;
elsif No_Run_Time then
null;
elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
if not Is_Limited_Type (Tag_Typ) then
Append_To (Res,
Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust));
end if;
Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize));
end if;
Predef_List := Res;
end Make_Predefined_Primitive_Specs;
function Needs_Simple_Initialization (T : Entity_Id) return Boolean is
begin
if Is_Access_Type (T)
or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
or else (Is_Bit_Packed_Array (T)
and then Is_Modular_Integer_Type (Packed_Array_Type (T)))
then
return True;
elsif Init_Or_Norm_Scalars
and then
(Root_Type (T) = Standard_String
or else Root_Type (T) = Standard_Wide_String)
and then
(not Is_Itype (T)
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
then
return True;
elsif Is_Private_Type (T) then
declare
RT : constant Entity_Id := Underlying_Type (T);
begin
if Present (RT) then
return Needs_Simple_Initialization (RT);
else
return False;
end if;
end;
else
return False;
end if;
end Needs_Simple_Initialization;
function Predef_Deep_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
For_Body : Boolean := False)
return Node_Id
is
Prof : List_Id;
Type_B : Entity_Id;
begin
if Name = Name_uDeep_Finalize then
Prof := New_List;
Type_B := Standard_Boolean;
else
Prof := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
In_Present => True,
Out_Present => True,
Parameter_Type =>
New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
Type_B := Standard_Short_Short_Integer;
end if;
Append_To (Prof,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)));
Append_To (Prof,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
Parameter_Type => New_Reference_To (Type_B, Loc)));
return Predef_Spec_Or_Body (Loc,
Name => Name,
Tag_Typ => Tag_Typ,
Profile => Prof,
For_Body => For_Body);
end Predef_Deep_Spec;
function Predef_Spec_Or_Body
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
For_Body : Boolean := False)
return Node_Id
is
Id : Entity_Id := Make_Defining_Identifier (Loc, Name);
Spec : Node_Id;
begin
Set_Is_Public (Id, Is_Public (Tag_Typ));
Set_Is_Internal (Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Id);
end if;
if No (Ret_Type) then
Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile);
else
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
Subtype_Mark =>
New_Reference_To (Ret_Type, Loc));
end if;
if For_Body then
return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
elsif (Name = Name_uInput or else Name = Name_uOutput)
and then Is_Abstract (Tag_Typ)
then
return Make_Abstract_Subprogram_Declaration (Loc, Spec);
else
return Make_Subprogram_Declaration (Loc, Spec);
end if;
end Predef_Spec_Or_Body;
function Predef_Stream_Attr_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : Name_Id;
For_Body : Boolean := False)
return Node_Id
is
Ret_Type : Entity_Id;
begin
if Name = Name_uInput then
Ret_Type := Tag_Typ;
else
Ret_Type := Empty;
end if;
return Predef_Spec_Or_Body (Loc,
Name => Name,
Tag_Typ => Tag_Typ,
Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
Ret_Type => Ret_Type,
For_Body => For_Body);
end Predef_Stream_Attr_Spec;
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
Renamed_Eq : Node_Id)
return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Decl : Node_Id;
Res : List_Id := New_List;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Name : Name_Id;
Ent : Entity_Id;
begin
if Present (Renamed_Eq) then
Eq_Needed := True;
Eq_Name := Chars (Renamed_Eq);
else
Eq_Needed := False;
Eq_Name := No_Name;
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
if Chars (Node (Prim)) = Name_Op_Eq
and then Is_Internal (Node (Prim))
then
Eq_Needed := True;
Eq_Name := Name_Op_Eq;
end if;
Next_Elmt (Prim);
end loop;
end if;
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uSize,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Long_Long_Integer,
For_Body => True);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Attribute_Name => Name_Size)))));
Append_To (Res, Decl);
if not (Is_Limited_Type (Tag_Typ) or else No_Run_Time) then
if No (TSS (Tag_Typ, Name_uRead)) then
Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
if No (TSS (Tag_Typ, Name_uWrite)) then
Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
if not Is_Abstract (Tag_Typ) then
if No (TSS (Tag_Typ, Name_uInput)) then
Build_Record_Or_Elementary_Input_Function
(Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
if No (TSS (Tag_Typ, Name_uOutput)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
end if;
end if;
if not Is_Limited_Type (Tag_Typ) then
if Eq_Needed then
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Eq_Name,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean,
For_Body => True);
declare
Def : constant Node_Id := Parent (Tag_Typ);
Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
Comps : Node_Id := Empty;
Typ_Def : Node_Id := Type_Definition (Def);
Stmts : List_Id := New_List;
begin
if Variant_Case then
if Nkind (Typ_Def) = N_Derived_Type_Definition then
Typ_Def := Record_Extension_Part (Typ_Def);
end if;
if Present (Typ_Def) then
Comps := Component_List (Typ_Def);
end if;
Variant_Case := Present (Comps)
and then Present (Variant_Part (Comps));
end if;
if Variant_Case then
Append_To (Stmts,
Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
Append_To (Stmts,
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc)));
else
Append_To (Stmts,
Make_Return_Statement (Loc,
Expression =>
Expand_Record_Equality (Tag_Typ,
Typ => Tag_Typ,
Lhs => Make_Identifier (Loc, Name_X),
Rhs => Make_Identifier (Loc, Name_Y),
Bodies => Declarations (Decl))));
end if;
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end;
Append_To (Res, Decl);
end if;
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAssign,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
For_Body => True);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_X),
Expression => Make_Identifier (Loc, Name_Y)))));
Append_To (Res, Decl);
end if;
if In_Finalization_Root (Tag_Typ) then
null;
elsif No_Run_Time then
null;
elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
and then not Has_Controlled_Component (Tag_Typ)
then
if not Is_Limited_Type (Tag_Typ) then
Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust, True);
if Is_Controlled (Tag_Typ) then
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Make_Adjust_Call (
Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ,
Flist_Ref => Make_Identifier (Loc, Name_L),
With_Attach => Make_Identifier (Loc, Name_B))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Null_Statement (Loc))));
end if;
Append_To (Res, Decl);
end if;
Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize, True);
if Is_Controlled (Tag_Typ) then
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Make_Final_Call (
Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ,
With_Detach => Make_Identifier (Loc, Name_B))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Null_Statement (Loc))));
end if;
Append_To (Res, Decl);
end if;
return Res;
end Predefined_Primitive_Bodies;
function Predefined_Primitive_Freeze
(Tag_Typ : Entity_Id)
return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : List_Id := New_List;
Prim : Elmt_Id;
Frnodes : List_Id;
begin
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
if Is_Internal (Node (Prim)) then
Frnodes := Freeze_Entity (Node (Prim), Loc);
if Present (Frnodes) then
Append_List_To (Res, Frnodes);
end if;
end if;
Next_Elmt (Prim);
end loop;
return Res;
end Predefined_Primitive_Freeze;
end Exp_Ch3;