with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
function Backend_Processing_Possible (N : Node_Id) return Boolean;
-- This function checks if array aggregate N can be processed directly
- -- by Gigi. If this is the case True is returned.
+ -- by the backend. If this is the case True is returned.
function Build_Array_Aggr_Code
(N : Node_Id;
-- 10. No controlled actions need to be generated for components
+ -- 11. For a VM back end, the array should have no aliased components
+
function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate
return False;
end if;
+ -- Checks 11: Array aggregates with aliased components are currently
+ -- not well supported by the VM backend; disable temporarily this
+ -- backend processing until it is definitely supported.
+
+ if VM_Target /= No_VM
+ and then Has_Aliased_Components (Base_Type (Typ))
+ then
+ return False;
+ end if;
+
-- Backend processing is possible
Set_Size_Known_At_Compile_Time (Etype (N), True);
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
L_J : Node_Id;
+ L_L : Node_Id;
+ -- Index_Base'(L)
+
+ L_H : Node_Id;
+ -- Index_Base'(H)
+
L_Range : Node_Id;
-- Index_Base'(L) .. Index_Base'(H)
L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
- -- Construct "L .. H"
+ -- Construct "L .. H" in Index_Base. We use a qualified expression
+ -- for the bound to convert to the index base, but we don't need
+ -- to do that if we already have the base type at hand.
+
+ if Etype (L) = Index_Base then
+ L_L := L;
+ else
+ L_L :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Index_Base_Name,
+ Expression => L);
+ end if;
+
+ if Etype (H) = Index_Base then
+ L_H := H;
+ else
+ L_H :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Index_Base_Name,
+ Expression => H);
+ end if;
L_Range :=
- Make_Range
- (Loc,
- Low_Bound => Make_Qualified_Expression
- (Loc,
- Subtype_Mark => Index_Base_Name,
- Expression => L),
- High_Bound => Make_Qualified_Expression
- (Loc,
- Subtype_Mark => Index_Base_Name,
- Expression => H));
+ Make_Range (Loc,
+ Low_Bound => L_L,
+ High_Bound => L_H);
-- Construct "for L_J in Index_Base range L .. H"
end if;
end Gen_Ctrl_Actions_For_Aggr;
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
+ -- If default expression of a component mentions a discriminant of the
+ -- type, it must be rewritten as the discriminant of the target object.
+
function Replace_Type (Expr : Node_Id) return Traverse_Result;
-- If the aggregate contains a self-reference, traverse each expression
-- to replace a possible self-reference with a reference to the proper
-- component of the target of the assignment.
+ --------------------------
+ -- Rewrite_Discriminant --
+ --------------------------
+
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (Expr) = N_Identifier
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (Expr)))
+ then
+ Rewrite (Expr,
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj, Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ end if;
+ return OK;
+ end Rewrite_Discriminant;
+
------------------
-- Replace_Type --
------------------
procedure Replace_Self_Reference is
new Traverse_Proc (Replace_Type);
+ procedure Replace_Discriminants is
+ new Traverse_Proc (Rewrite_Discriminant);
+
-- Start of processing for Build_Record_Aggr_Code
begin
Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
Set_Assignment_OK (Ref);
- Append_List_To (L,
- Build_Initialization_Call (Loc,
- Id_Ref => Ref,
- Typ => Init_Typ,
- In_Init_Proc => Within_Init_Proc,
- With_Default_Init => Has_Default_Init_Comps (N)
- or else
- Has_Task (Base_Type (Init_Typ))));
-
- if Is_Constrained (Entity (A))
- and then Has_Discriminants (Entity (A))
- then
- Check_Ancestor_Discriminants (Entity (A));
+ if not Is_Interface (Init_Typ) then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => Init_Typ,
+ In_Init_Proc => Within_Init_Proc,
+ With_Default_Init => Has_Default_Init_Comps (N)
+ or else
+ Has_Task (Base_Type (Init_Typ))));
+
+ if Is_Constrained (Entity (A))
+ and then Has_Discriminants (Entity (A))
+ then
+ Check_Ancestor_Discriminants (Entity (A));
+ end if;
end if;
-- Handle calls to C++ constructors
elsif Is_CPP_Constructor_Call (A) then
- Init_Typ := Etype (Etype (A));
+ Init_Typ := Etype (A);
Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
Set_Assignment_OK (Ref);
declare
SubE : constant Entity_Id :=
Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
+ Chars => New_Internal_Name ('T'));
SubD : constant Node_Id :=
Make_Subtype_Declaration (Loc,
- Defining_Identifier =>
- SubE,
+ Defining_Identifier => SubE,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (
- Etype (Comp_Type), Loc),
+ Subtype_Mark =>
+ New_Reference_To
+ (Etype (Comp_Type), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (
- Loc, Constraints => New_List (
- New_Copy_Tree (Aggregate_Bounds (
- Expr_Q))))));
+ Make_Index_Or_Discriminant_Constraint
+ (Loc,
+ Constraints => New_List (
+ New_Copy_Tree
+ (Aggregate_Bounds (Expr_Q))))));
-- Create a temporary array of the above subtype which
-- will be used to capture the aggregate assignments.
- TmpE : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
+ TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
TmpD : constant Node_Id :=
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- TmpE,
+ Defining_Identifier => TmpE,
Object_Definition =>
New_Reference_To (SubE, Loc));
-- Expr_Q is not delayed aggregate
else
+ if Has_Discriminants (Typ) then
+ Replace_Discriminants (Expr_Q);
+ end if;
+
Instr :=
Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr,
- Expression => Expression (Comp));
+ Expression => Expr_Q);
Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
N_Discriminant_Specification
then
Flist := Empty;
- else
+
+ elsif Needs_Finalization (Typ) then
Flist := Find_Final_List (Access_Type);
+
+ -- Otherwise there are no controlled actions to be performed.
+
+ else
+ Flist := Empty;
end if;
if Is_Array_Type (Typ) then
Rewrite (Parent (N), Make_Null_Statement (Loc));
else
- Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Temp := Make_Temporary (Loc, 'A', N);
-- If the type inherits unknown discriminants, use the view with
-- known discriminants if available.
-- total number of components is safe enough to expand.
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
- -- Return True iff the array N is flat (which is not rivial in the case
+ -- Return True iff the array N is flat (which is not trivial in the case
-- of multidimensionsl aggregates).
-----------------------------
end if;
end if;
- -- Range cases merge with Lo,Hi said
+ -- Range cases merge with Lo,Hi set
if not Compile_Time_Known_Value (Lo)
or else
end if;
Aggr_In := First_Index (Etype (N));
+
if Nkind (Parent (N)) = N_Assignment_Statement then
Obj_In := First_Index (Etype (Name (Parent (N))));
else
Maybe_In_Place_OK := False;
- Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Tmp := Make_Temporary (Loc, 'A', N);
Tmp_Decl :=
Make_Object_Declaration
(Loc,
-- an atomic move for it.
if Is_Atomic (Typ)
- and then Nkind_In (Parent (N), N_Object_Declaration,
- N_Assignment_Statement)
and then Comes_From_Source (Parent (N))
+ and then Is_Atomic_Aggregate (N, Typ)
then
- Expand_Atomic_Aggregate (N, Typ);
return;
-- No special management required for aggregates used to initialize