-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
-with Fname; use Fname;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Exp_Aggr is
-- expression with actions, which becomes the Initialization_Statements for
-- Obj.
+ procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
+ procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
+
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
-- initialization (<>) in any component (Ada 2005: AI-287).
- function In_Object_Declaration (N : Node_Id) return Boolean;
- -- Return True if N is part of an object declaration, False otherwise
+ function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
+ -- Return True if aggregate N is located in a context supported by the
+ -- CCG backend; False otherwise.
function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
-- Returns true if N is an aggregate used to initialize the components
-- of a statically allocated dispatch table.
+ function Late_Expansion
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id) return List_Id;
+ -- This routine implements top-down expansion of nested aggregates. In
+ -- doing so, it avoids the generation of temporaries at each level. N is
+ -- a nested record or array aggregate with the Expansion_Delayed flag.
+ -- Typ is the expected type of the aggregate. Target is a (duplicatable)
+ -- expression that will hold the result of the aggregate expansion.
+
+ function Make_OK_Assignment_Statement
+ (Sloc : Source_Ptr;
+ Name : Node_Id;
+ Expression : Node_Id) return Node_Id;
+ -- This is like Make_Assignment_Statement, except that Assignment_OK
+ -- is set in the left operand. All assignments built by this unit use
+ -- this routine. This is needed to deal with assignments to initialized
+ -- constants that are done in place.
+
function Must_Slide
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean;
-- when a component may be given with bounds that differ from those of the
-- component type.
+ function Number_Of_Choices (N : Node_Id) return Nat;
+ -- Returns the number of discrete choices (not including the others choice
+ -- if present) contained in (sub-)aggregate N.
+
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression of the
+ -- component which is always a function call. Fin_Call is the finalization
+ -- call used to clean up the transient function result. Hook_Clear is the
+ -- hook reset statement. Aggr and Stmts both control the placement of the
+ -- generated code. Aggr is the related aggregate. If present, all code is
+ -- inserted prior to Aggr using Insert_Action. Stmts is the initialization
+ -- statements of the component. If present, all code is added to Stmts.
+
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Aggr is
+ -- the related aggregate. Fin_Clear is the finalization call used to clean
+ -- up the transient component. Hook_Clear is the hook reset statment. Stmts
+ -- is the initialization statement list for the component. All generated
+ -- code is added to Stmts.
+
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-- Sort the Case Table using the Lower Bound of each Choice as the key.
-- A simple insertion sort is used since the number of choices in a case
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
+ -- True if N is an aggregate (possibly qualified or converted) that is
+ -- being returned from a build-in-place function.
+
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
-- types.
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
- -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
- -- aggregate (which can only be a record type, this procedure is only used
- -- for record types). Transform the given aggregate into a sequence of
- -- assignments performed component by component.
+ -- Transform a record aggregate into a sequence of assignments performed
+ -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
+ -- Typ is the type of the record aggregate.
procedure Expand_Record_Aggregate
(N : Node_Id;
-- defaults. An aggregate for a type with mutable components must be
-- expanded into individual assignments.
+ function In_Place_Assign_OK (N : Node_Id) return Boolean;
+ -- Predicate to determine whether an aggregate assignment can be done in
+ -- place, because none of the new values can depend on the components of
+ -- the target of the assignment.
+
procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
-- If the type of the aggregate is a type extension with renamed discrimi-
-- nants, we must initialize the hidden discriminants of the parent.
-- calling Flatten.
--
-- This function also detects and warns about one-component aggregates that
- -- appear in a non-static context. Even if the component value is static,
+ -- appear in a nonstatic context. Even if the component value is static,
-- such an aggregate must be expanded into an assignment.
function Backend_Processing_Possible (N : Node_Id) return Boolean;
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 32;
Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
-- conversion is possible only in some static cases. If the conversion is
-- possible, then N is rewritten with the analyzed converted aggregate.
-- The parameter Max_Others_Replicate controls the maximum number of
-- values corresponding to an others choice that will be converted to
- -- positional notation (the default of 5 is the normal limit, and reflects
+ -- positional notation (the default of 32 is the normal limit, and reflects
-- the fact that normally the loop is better than a lot of separate
-- assignments). Note that this limit gets overridden in any case if
-- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
-- these are cases we handle in there.
- -- It would seem useful to have a higher default for Max_Others_Replicate,
- -- but aggregates in the compiler make this impossible: the compiler
- -- bootstrap fails if Max_Others_Replicate is greater than 25. This
- -- is unexpected ???
-
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
-- N is the N_Aggregate node to be expanded.
-- an array that is suitable for this optimization: it returns True if Typ
-- is a two dimensional bit packed array with component size 1, 2, or 4.
- function Late_Expansion
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id) return List_Id;
- -- This routine implements top-down expansion of nested aggregates. In
- -- doing so, it avoids the generation of temporaries at each level. N is
- -- a nested record or array aggregate with the Expansion_Delayed flag.
- -- Typ is the expected type of the aggregate. Target is a (duplicatable)
- -- expression that will hold the result of the aggregate expansion.
-
- function Make_OK_Assignment_Statement
- (Sloc : Source_Ptr;
- Name : Node_Id;
- Expression : Node_Id) return Node_Id;
- -- This is like Make_Assignment_Statement, except that Assignment_OK
- -- is set in the left operand. All assignments built by this unit use
- -- this routine. This is needed to deal with assignments to initialized
- -- constants that are done in place.
-
- function Number_Of_Choices (N : Node_Id) return Nat;
- -- Returns the number of discrete choices (not including the others choice
- -- if present) contained in (sub-)aggregate N.
-
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
-- array aggregate with all constant values, where the aggregate can be
Lo : Node_Id;
Hi : Node_Id;
Indx : Node_Id;
- Siz : Int;
+ Size : Uint;
Lov : Uint;
Hiv : Uint;
-- which hit memory limits in the backend.
function Component_Count (T : Entity_Id) return Nat;
- -- The limit is applied to the total number of components that the
+ -- The limit is applied to the total number of subcomponents that the
-- aggregate will have, which is the number of static expressions
-- that will appear in the flattened array. This requires a recursive
-- computation of the number of scalar components of the structure.
return 0;
else
- return
- Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);
+ -- If the number of components is greater than Int'Last,
+ -- then return Int'Last, so caller will return False (Aggr
+ -- size is not OK). Otherwise, UI_To_Int will crash.
+
+ declare
+ UI : constant Uint :=
+ Expr_Value (Hi) - Expr_Value (Lo) + 1;
+ begin
+ if UI_Is_In_Int_Range (UI) then
+ return Siz * UI_To_Int (UI);
+ else
+ return Int'Last;
+ end if;
+ end;
end if;
end;
-- Start of processing for Aggr_Size_OK
begin
- -- The normal aggregate limit is 50000, but we increase this limit to
+ -- The normal aggregate limit is 500000, but we increase this limit to
-- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or
-- Restrictions (No_Implicit_Loops) is specified, since in either case
-- we are at risk of declaring the program illegal because of this
-- Finally, we use a small limit in CodePeer mode where we favor loops
-- instead of thousands of single assignments (from large aggregates).
- Max_Aggr_Size := 50000;
+ Max_Aggr_Size := 500000;
if CodePeer_Mode then
Max_Aggr_Size := 100;
Max_Aggr_Size := 5000;
end if;
- Siz := Component_Count (Component_Type (Typ));
+ Size := UI_From_Int (Component_Count (Component_Type (Typ)));
Indx := First_Index (Typ);
while Present (Indx) loop
end if;
-- One-component aggregates are suspicious, and if the context type
- -- is an object declaration with non-static bounds it will trip gcc;
+ -- is an object declaration with nonstatic bounds it will trip gcc;
-- such an aggregate must be expanded into a single assignment.
if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then
then
if Present (Component_Associations (N)) then
Indx :=
- First (Choices (First (Component_Associations (N))));
+ First
+ (Choice_List (First (Component_Associations (N))));
if Is_Entity_Name (Indx)
and then not Is_Type (Entity (Indx))
return False;
end if;
- Siz := Siz * UI_To_Int (Rng);
- end;
+ -- Compute the size using universal arithmetic to avoid the
+ -- possibility of overflow on very large aggregates.
- if Siz <= 0
- or else Siz > Max_Aggr_Size
- then
- return False;
- end if;
+ Size := Size * Rng;
+
+ if Size <= 0
+ or else Size > Max_Aggr_Size
+ then
+ return False;
+ end if;
+ end;
-- Bounds must be in integer range, for later array construction
return False;
end if;
- -- Checks 11: (part of an object declaration)
+ -- Checks 11: The C code generator cannot handle aggregates that are
+ -- not part of an object declaration.
- if Modify_Tree_For_C
- and then Nkind (Parent (N)) /= N_Object_Declaration
- and then
- (Nkind (Parent (N)) /= N_Qualified_Expression
- or else Nkind (Parent (Parent (N))) /= N_Object_Declaration)
- then
+ if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
return False;
end if;
-- Recurse to check subaggregates, which may appear in qualified
-- expressions. If delayed, the front-end will have to expand.
- -- If the component is a discriminated record, treat as non-static,
+ -- If the component is a discriminated record, treat as nonstatic,
-- as the back-end cannot handle this properly.
Expr := First (Expressions (N));
-- Checks 5 (if the component type is tagged, then we may need to do
-- tag adjustments. Perhaps this should be refined to check for any
-- component associations that actually need tag adjustment, similar
- -- to the test in Component_Not_OK_For_Backend for record aggregates
- -- with tagged components, but not clear whether it's worthwhile ???;
- -- in the case of virtual machines (no Tagged_Type_Expansion), object
- -- tags are handled implicitly).
+ -- to the test in Component_OK_For_Backend for record aggregates with
+ -- tagged components, but not clear whether it's worthwhile ???; in the
+ -- case of virtual machines (no Tagged_Type_Expansion), object tags are
+ -- handled implicitly).
if Is_Tagged_Type (Component_Type (Typ))
and then Tagged_Type_Expansion
function Index_Base_Name return Node_Id;
-- Returns a new reference to the index type name
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id;
-- Ind must be a side-effect-free expression. If the input aggregate N
-- to Build_Loop contains no subaggregates, then this function returns
-- the assignment statement:
--
-- Into (Indexes, Ind) := Expr;
--
- -- Otherwise we call Build_Code recursively
+ -- Otherwise we call Build_Code recursively. Flag In_Loop should be set
+ -- when the assignment appears within a generated loop.
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
-- Into (Indexes, J) := Expr;
-- end loop;
--
- -- Otherwise we call Build_Code recursively.
- -- As an optimization if the loop covers 3 or fewer scalar elements we
- -- generate a sequence of assignments.
+ -- Otherwise we call Build_Code recursively. As an optimization if the
+ -- loop covers 3 or fewer scalar elements we generate a sequence of
+ -- assignments.
+ -- If the component association that generates the loop comes from an
+ -- Iterated_Component_Association, the loop parameter has the name of
+ -- the corresponding parameter in the original construct.
function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
-- Nodes L and H must be side-effect-free expressions. If the input
-- Gen_Assign --
----------------
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id
+ is
function Add_Loop_Actions (Lis : List_Id) return List_Id;
- -- Collect insert_actions generated in the construction of a
- -- loop, and prepend them to the sequence of assignments to
- -- complete the eventual body of the loop.
-
- function Ctrl_Init_Expression
- (Comp_Typ : Entity_Id;
- Stmts : List_Id) return Node_Id;
- -- Perform in-place side effect removal if expression Expr denotes a
- -- controlled function call. Return a reference to the entity which
- -- captures the result of the call. Comp_Typ is the expected type of
- -- the component. Stmts is the list of initialization statmenets. Any
- -- generated code is added to Stmts.
+ -- Collect insert_actions generated in the construction of a loop,
+ -- and prepend them to the sequence of assignments to complete the
+ -- eventual body of the loop.
+
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp with
+ -- expected type Comp_Typ. Init_Expr denotes the initialization
+ -- expression of the array component. All generated code is added
+ -- to list Stmts.
+
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp when its
+ -- expected type Comp_Typ needs finalization actions. Init_Expr is
+ -- the initialization expression of the array component. All hook-
+ -- related declarations are inserted prior to aggregate N. Remaining
+ -- code is added to list Stmts.
----------------------
-- Add_Loop_Actions --
end if;
end Add_Loop_Actions;
- --------------------------
- -- Ctrl_Init_Expression --
- --------------------------
+ --------------------------------
+ -- Initialize_Array_Component --
+ --------------------------------
- function Ctrl_Init_Expression
- (Comp_Typ : Entity_Id;
- Stmts : List_Id) return Node_Id
- is
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
Init_Expr : Node_Id;
- Obj_Id : Entity_Id;
- Ptr_Typ : Entity_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active
+ (No_Exception_Propagation);
+
+ Finalization_OK : constant Boolean :=
+ Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ);
+
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
+ Blk_Stmts : List_Id;
+ Init_Stmt : Node_Id;
begin
- Init_Expr := New_Copy_Tree (Expr);
+ -- Protect the initialization statements from aborts. Generate:
- -- Perform a preliminary analysis and resolution to determine
- -- what the expression denotes. Note that a function call may
- -- appear as an identifier or an indexed component.
+ -- Abort_Defer;
- Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
- -- The initialization expression is a controlled function call.
- -- Perform in-place removal of side effects to avoid creating a
- -- transient scope. In the end the temporary function result is
- -- finalized by the general finalization machinery.
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
- if Nkind (Init_Expr) = N_Function_Call then
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
- -- Suppress the removal of side effects by generatal analysis
- -- because this behavior is emulated here.
+ else
+ Blk_Stmts := Stmts;
+ end if;
- Set_No_Side_Effect_Removal (Init_Expr);
+ -- Initialize the array element. Generate:
- -- Generate:
- -- type Ptr_Typ is access all Comp_Typ;
+ -- Arr_Comp := Init_Expr;
- Ptr_Typ := Make_Temporary (Loc, 'A');
+ -- Note that the initialization expression is replicated because
+ -- it has to be reevaluated within a generated loop.
- Append_To (Stmts,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Comp_Typ, Loc))));
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Arr_Comp),
+ Expression => New_Copy_Tree (Init_Expr));
+ Set_No_Ctrl_Actions (Init_Stmt);
- -- Generate:
- -- Obj : constant Ptr_Typ := Init_Expr'Reference;
+ -- If this is an aggregate for an array of arrays, each
+ -- subaggregate will be expanded as well, and even with
+ -- No_Ctrl_Actions the assignments of inner components will
+ -- require attachment in their assignments to temporaries. These
+ -- temporaries must be finalized for each subaggregate. Generate:
- Obj_Id := Make_Temporary (Loc, 'R');
+ -- begin
+ -- Arr_Comp := Init_Expr;
+ -- end;
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression => Make_Reference (Loc, Init_Expr)));
+ if Finalization_OK and then Is_Array_Type (Comp_Typ) then
+ Init_Stmt :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Init_Stmt)));
+ end if;
- -- Generate:
- -- Obj.all;
+ Append_To (Blk_Stmts, Init_Stmt);
- return
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc));
+ -- Adjust the tag due to a possible view conversion. Generate:
- -- Otherwise the initialization expression denotes a controlled
- -- object. There is nothing special to be done here as there is
- -- no possible transient scope involvement.
+ -- Arr_Comp._tag := Full_TypP;
- else
- return Init_Expr;
+ if Tagged_Type_Expansion
+ and then Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
+ then
+ Append_To (Blk_Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Arr_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the array component. Controlled subaggregates are not
+ -- considered because each of their individual elements will
+ -- receive an adjustment of its own. Generate:
+
+ -- [Deep_]Adjust (Arr_Comp);
+
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
+ and then not
+ (Is_Array_Type (Comp_Typ)
+ and then Is_Controlled (Component_Type (Comp_Typ))
+ and then Nkind (Expr) = N_Aggregate)
+ then
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Arr_Comp),
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component
+ -- type was not frozen properly.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
+ end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+ end Initialize_Array_Component;
+
+ -------------------------------------
+ -- Initialize_Ctrl_Array_Component --
+ -------------------------------------
+
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Act_Aggr : Node_Id;
+ Act_Stmts : List_Id;
+ Expr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
+
+ begin
+ -- Duplicate the initialization expression in case the context is
+ -- a multi choice list or an "others" choice which plugs various
+ -- holes in the aggregate. As a result the expression is no longer
+ -- shared between the various components and is reevaluated for
+ -- each such component.
+
+ Expr := New_Copy_Tree (Init_Expr);
+ Set_Parent (Expr, Parent (Init_Expr));
+
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. An unanalyzed function
+ -- call may appear as an identifier or an indexed component.
+
+ if Nkind_In (Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Expr)
+ then
+ Preanalyze_And_Resolve (Expr, Comp_Typ);
+ end if;
+
+ In_Place_Expansion :=
+ Nkind (Expr) = N_Function_Call
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
+
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope, which leads to premature finalization.
+
+ -- This in-place expansion is not performed for limited transient
+ -- objects, because the initialization is already done in place.
+
+ if In_Place_Expansion then
+
+ -- Suppress the removal of side effects by general analysis,
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
+ Set_No_Side_Effect_Removal (Expr);
+
+ -- When the transient component initialization is related to a
+ -- range or an "others", keep all generated statements within
+ -- the enclosing loop. This way the controlled function call
+ -- will be evaluated at each iteration, and its result will be
+ -- finalized at the end of each iteration.
+
+ if In_Loop then
+ Act_Aggr := Empty;
+ Act_Stmts := Stmts;
+
+ -- Otherwise this is a single component initialization. Hook-
+ -- related statements are inserted prior to the aggregate.
+
+ else
+ Act_Aggr := N;
+ Act_Stmts := No_List;
+ end if;
+
+ -- Install all hook-related declarations and prepare the clean
+ -- up statements.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => Act_Aggr,
+ Stmts => Act_Stmts);
+ end if;
+
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the array element.
+ -- This also performs subaggregate wrapping, tag adjustment, and
+ -- [deep] adjustment of the array element.
+
+ Initialize_Array_Component
+ (Arr_Comp => Arr_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+
+ -- At this point the array element is fully initialized. Complete
+ -- the processing of the controlled array component by finalizing
+ -- the transient function result.
+
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
end if;
- end Ctrl_Init_Expression;
+ end Initialize_Ctrl_Array_Component;
-- Local variables
Comp_Typ : Entity_Id := Empty;
Expr_Q : Node_Id;
Indexed_Comp : Node_Id;
+ Init_Call : Node_Id;
New_Indexes : List_Id;
- Stmt : Node_Id;
- Stmt_Expr : Node_Id;
-- Start of processing for Gen_Assign
-- the analysis of non-array aggregates now in order to get the
-- value of Expansion_Delayed flag for the inner aggregate ???
+ -- In the case of an iterated component association, the analysis
+ -- of the generated loop will analyze the expression in the
+ -- proper context, in which the loop parameter is visible.
+
if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
- Analyze_And_Resolve (Expr_Q, Comp_Typ);
+ if Nkind (Parent (Expr_Q)) = N_Iterated_Component_Association
+ or else Nkind (Parent (Parent ((Expr_Q)))) =
+ N_Iterated_Component_Association
+ then
+ null;
+ else
+ Analyze_And_Resolve (Expr_Q, Comp_Typ);
+ end if;
end if;
if Is_Delayed_Aggregate (Expr_Q) then
-- component associations that provide different bounds from
-- those of the component type, and sliding must occur. Instead
-- of decomposing the current aggregate assignment, force the
- -- re-analysis of the assignment, so that a temporary will be
+ -- reanalysis of the assignment, so that a temporary will be
-- generated in the usual fashion, and sliding will take place.
if Nkind (Parent (N)) = N_Assignment_Statement
end if;
end if;
+ if Present (Expr) then
+
+ -- Handle an initialization expression of a controlled type in
+ -- case it denotes a function call. In general such a scenario
+ -- will produce a transient scope, but this will lead to wrong
+ -- order of initialization, adjustment, and finalization in the
+ -- context of aggregates.
+
+ -- Target (1) := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target (1) := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+
+ -- In the example above, the call to Finalize occurs too early
+ -- and as a result it may leave the array component in a bad
+ -- state. Finalization of the transient object should really
+ -- happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect removal
+ -- of the function call. This eliminates the transient property
+ -- of the function result and ensures correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target (1) := Res;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+ -- Finalize (Res);
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Nkind (Expr) /= N_Aggregate
+ then
+ Initialize_Ctrl_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+
+ -- Otherwise perform simple component initialization
+
+ else
+ Initialize_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end if;
+
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
-- If the component type is an access type, add an explicit null
-- its Initialize procedure explicitly, because there is no explicit
-- object creation that will invoke it otherwise.
- if No (Expr) then
+ else
if Present (Base_Init_Proc (Base_Type (Ctype)))
or else Has_Task (Base_Type (Ctype))
then
end if;
if Needs_Finalization (Ctype) then
- Append_To (Stmts,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype));
+ Typ => Ctype);
+
+ -- Guard against a missing [Deep_]Initialize when the component
+ -- type was not properly frozen.
+
+ if Present (Init_Call) then
+ Append_To (Stmts, Init_Call);
+ end if;
end if;
+ end if;
- else
- -- Handle an initialization expression of a controlled type in
- -- case it denotes a function call. In general such a scenario
- -- will produce a transient scope, but this will lead to wrong
- -- order of initialization, adjustment, and finalization in the
- -- context of aggregates.
+ return Add_Loop_Actions (Stmts);
+ end Gen_Assign;
- -- Arr_Comp (1) := Ctrl_Func_Call;
+ --------------
+ -- Gen_Loop --
+ --------------
- -- begin -- transient scope
- -- Trans_Obj : ... := Ctrl_Func_Call; -- transient object
- -- Arr_Comp (1) := Trans_Obj;
- -- Finalize (Trans_Obj);
- -- end;
- -- Arr_Comp (1)._tag := ...;
- -- Adjust (Arr_Comp (1));
+ function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
+ Is_Iterated_Component : constant Boolean :=
+ Nkind (Parent (Expr)) = N_Iterated_Component_Association;
- -- In the example above, the call to Finalize occurs too early
- -- and as a result it may leave the array component in a bad
- -- state. Finalization of the transient object should really
- -- happen after adjustment.
+ L_J : Node_Id;
- -- To avoid this scenario, perform in-place side effect removal
- -- of the function call. This eliminates the transient property
- -- of the function result and ensures correct order of actions.
- -- Note that the function result behaves as a source controlled
- -- object and is finalized by the general finalization mechanism.
+ L_L : Node_Id;
+ -- Index_Base'(L)
- -- begin
- -- Res : ... := Ctrl_Func_Call;
- -- Arr_Comp (1) := Res;
- -- Arr_Comp (1)._tag := ...;
- -- Adjust (Arr_Comp (1));
- -- at end
- -- Finalize (Res);
- -- end;
+ L_H : Node_Id;
+ -- Index_Base'(H)
- -- There is no need to perform this kind of light expansion when
- -- the component type is limited controlled because everything is
- -- already done in place.
+ L_Range : Node_Id;
+ -- Index_Base'(L) .. Index_Base'(H)
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then not Is_Limited_Type (Comp_Typ)
- and then Nkind (Expr) /= N_Aggregate
- then
- Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts);
+ L_Iteration_Scheme : Node_Id;
+ -- L_J in Index_Base'(L) .. Index_Base'(H)
- -- Otherwise use the initialization expression directly
+ L_Body : List_Id;
+ -- The statements to execute in the loop
- else
- Stmt_Expr := New_Copy_Tree (Expr);
- end if;
+ S : constant List_Id := New_List;
+ -- List of statements
- Stmt :=
- Make_OK_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Indexed_Comp),
- Expression => Stmt_Expr);
+ Tcopy : Node_Id;
+ -- Copy of expression tree, used for checking purposes
- -- The target of the assignment may not have been initialized,
- -- so it is not possible to call Finalize as expected in normal
- -- controlled assignments. We must also avoid using the primitive
- -- _assign (which depends on a valid target, and may for example
- -- perform discriminant checks on it).
+ begin
+ -- If loop bounds define an empty range return the null statement
- -- Both Finalize and usage of _assign are disabled by setting
- -- No_Ctrl_Actions on the assignment. The rest of the controlled
- -- actions are done manually with the proper finalization list
- -- coming from the context.
+ if Empty_Range (L, H) then
+ Append_To (S, Make_Null_Statement (Loc));
- Set_No_Ctrl_Actions (Stmt);
+ -- Ada 2005 (AI-287): Nothing else need to be done in case of
+ -- default initialized component.
- -- If this is an aggregate for an array of arrays, each
- -- subaggregate will be expanded as well, and even with
- -- No_Ctrl_Actions the assignments of inner components will
- -- require attachment in their assignments to temporaries. These
- -- temporaries must be finalized for each subaggregate, to prevent
- -- multiple attachments of the same temporary location to same
- -- finalization chain (and consequently circular lists). To ensure
- -- that finalization takes place for each subaggregate we wrap the
- -- assignment in a block.
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then Is_Array_Type (Comp_Typ)
- and then Present (Expr)
- then
- Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
- end if;
-
- Append_To (Stmts, Stmt);
-
- -- Adjust the tag due to a possible view conversion
-
- if Present (Comp_Typ)
- and then Is_Tagged_Type (Comp_Typ)
- and then Tagged_Type_Expansion
- then
- declare
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
-
- begin
- Append_To (Stmts,
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_Typ), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc))));
- end;
- end if;
-
- -- Adjust and attach the component to the proper final list, which
- -- can be the controller of the outer record object or the final
- -- list associated with the scope.
-
- -- If the component is itself an array of controlled types, whose
- -- value is given by a subaggregate, then the attach calls have
- -- been generated when individual subcomponent are assigned, and
- -- must not be done again to prevent malformed finalization chains
- -- (see comments above, concerning the creation of a block to hold
- -- inner finalization actions).
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then not Is_Limited_Type (Comp_Typ)
- and then not
- (Is_Array_Type (Comp_Typ)
- and then Is_Controlled (Component_Type (Comp_Typ))
- and then Nkind (Expr) = N_Aggregate)
- then
- Append_To (Stmts,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Typ));
- end if;
- end if;
-
- return Add_Loop_Actions (Stmts);
- end Gen_Assign;
-
- --------------
- -- Gen_Loop --
- --------------
-
- 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_Iteration_Scheme : Node_Id;
- -- L_J in Index_Base'(L) .. Index_Base'(H)
-
- L_Body : List_Id;
- -- The statements to execute in the loop
-
- S : constant List_Id := New_List;
- -- List of statements
-
- Tcopy : Node_Id;
- -- Copy of expression tree, used for checking purposes
-
- begin
- -- If loop bounds define an empty range return the null statement
-
- if Empty_Range (L, H) then
- Append_To (S, Make_Null_Statement (Loc));
-
- -- Ada 2005 (AI-287): Nothing else need to be done in case of
- -- default initialized component.
-
- if No (Expr) then
- null;
+ if No (Expr) then
+ null;
else
-- The expression must be type-checked even though no component
return S;
- -- If loop bounds are the same then generate an assignment
+ -- If loop bounds are the same then generate an assignment, unless
+ -- the parent construct is an Iterated_Component_Association.
- elsif Equal (L, H) then
+ elsif Equal (L, H) and then not Is_Iterated_Component then
return Gen_Assign (New_Copy_Tree (L), Expr);
-- If H - L <= 2 then generate a sequence of assignments when we are
and then Local_Compile_Time_Known_Value (L)
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
+ and then not Is_Iterated_Component
then
-
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
-- Otherwise construct the loop, starting with the loop index L_J
- L_J := Make_Temporary (Loc, 'J', L);
+ if Is_Iterated_Component then
+ L_J :=
+ Make_Defining_Identifier (Loc,
+ Chars => (Chars (Defining_Identifier (Parent (Expr)))));
+
+ else
+ L_J := Make_Temporary (Loc, 'J', L);
+ end if;
-- 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
L_L :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Index_Base_Name,
- Expression => L);
+ Expression => New_Copy_Tree (L));
end if;
if Etype (H) = Index_Base then
L_H :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Index_Base_Name,
- Expression => H);
+ Expression => New_Copy_Tree (H));
end if;
L_Range :=
-- Construct the statements to execute in the loop body
- L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr);
+ L_Body :=
+ Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True);
-- Construct the final loop
Expression => W_Index_Succ);
Append_To (W_Body, W_Increment);
+
Append_List_To (W_Body,
- Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr));
+ Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True));
-- Construct the final loop
end if;
end Local_Expr_Value;
- -- Build_Array_Aggr_Code Variables
-
- Assoc : Node_Id;
- Choice : Node_Id;
- Expr : Node_Id;
- Typ : Entity_Id;
+ -- Local variables
- Others_Assoc : Node_Id := Empty;
+ New_Code : constant List_Id := New_List;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free
- Low : Node_Id;
- High : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+ High : Node_Id;
+ Low : Node_Id;
+ Typ : Entity_Id;
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
Nb_Elements : Int;
-- Number of elements in the positional aggregate
- New_Code : constant List_Id := New_List;
+ Others_Assoc : Node_Id := Empty;
-- Start of processing for Build_Array_Aggr_Code
and then Is_Bit_Packed_Array (Typ)
and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))
then
- Append_To (New_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Into),
- Expression =>
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, Uint_0))));
+ declare
+ Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0);
+ begin
+ Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ));
+ Append_To (New_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Into),
+ Expression => Unchecked_Convert_To (Typ, Zero)));
+ end;
end if;
-- If the component type contains tasks, we need to build a Master
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
- Set_Loop_Actions (Assoc, New_List);
Others_Assoc := Assoc;
exit;
end if;
if Present (Others_Assoc) then
declare
- First : Boolean := True;
+ First : Boolean := True;
+ Dup_Expr : Node_Id;
begin
for J in 0 .. Nb_Choices loop
or else not Empty_Range (Low, High)
then
First := False;
+
+ -- Duplicate the expression in case we will be generating
+ -- several loops. As a result the expression is no longer
+ -- shared between the loops and is reevaluated for each
+ -- such loop.
+
+ Expr := Get_Assoc_Expr (Others_Assoc);
+ Dup_Expr := New_Copy_Tree (Expr);
+ Set_Parent (Dup_Expr, Parent (Expr));
+
+ Set_Loop_Actions (Others_Assoc, New_List);
Append_List
- (Gen_Loop (Low, High,
- Get_Assoc_Expr (Others_Assoc)), To => New_Code);
+ (Gen_Loop (Low, High, Dup_Expr), To => New_Code);
end if;
end loop;
end;
-- The type of the aggregate is a subtype created ealier using the
-- given values of the discriminant components of the aggregate.
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of controlled record component Rec_Comp.
+ -- Comp_Typ is the component type. Init_Expr is the initialization
+ -- expression for the record component. Hook-related declarations are
+ -- inserted prior to aggregate N using Insert_Action. All remaining
+ -- generated code is added to list Stmts.
+
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of record component Rec_Comp. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression
+ -- of the record component. All generated code is added to list Stmts.
+
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
-- are integers literals.
+ 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.
+
+ 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.
+
---------------------------------
-- Ancestor_Discriminant_Value --
---------------------------------
return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
end Compatible_Int_Bounds;
+ -----------------------------------
+ -- Generate_Finalization_Actions --
+ -----------------------------------
+
+ procedure Generate_Finalization_Actions is
+ begin
+ -- Do the work only the first time this is called
+
+ if Finalization_Done then
+ return;
+ end if;
+
+ Finalization_Done := True;
+
+ -- Determine the external finalization list. It is either the
+ -- finalization list of the outer scope or the one coming from an
+ -- outer aggregate. When the target is not a temporary, the proper
+ -- scope is the scope of the target rather than the potentially
+ -- transient current scope.
+
+ if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
+ Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
+ Set_Assignment_OK (Ref);
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ end if;
+ end Generate_Finalization_Actions;
+
--------------------------------
-- Get_Constraint_Association --
--------------------------------
Discr_Constr :=
First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
+ -- Otherwise, no discriminant to process
+
else
- Discr_Constr := First_Elmt (Stored_Constraint (Typ));
+ Discr_Constr := No_Elmt;
end if;
while Present (Discr) and then Present (Discr_Constr) loop
Selector_Name => New_Occurrence_Of (Discr, Loc)),
Expression => New_Copy_Tree (Discr_Val));
- Set_No_Ctrl_Actions (Discr_Init);
Append_To (List, Discr_Init);
end if;
Name => Comp_Expr,
Expression => New_Copy_Tree (Discriminant_Value));
- Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
Next_Discriminant (Discriminant);
Name => Comp_Expr,
Expression => New_Copy_Tree (Discriminant_Value));
- Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
Next_Stored_Discriminant (Discriminant);
end loop;
end Init_Stored_Discriminants;
- -------------------------
- -- Is_Int_Range_Bounds --
- -------------------------
+ --------------------------------------
+ -- Initialize_Ctrl_Record_Component --
+ --------------------------------------
- function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
- begin
- return Nkind (Bounds) = N_Range
- and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
- and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
- end Is_Int_Range_Bounds;
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
- -----------------------------------
- -- Generate_Finalization_Actions --
- -----------------------------------
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
- procedure Generate_Finalization_Actions is
begin
- -- Do the work only the first time this is called
-
- if Finalization_Done then
- return;
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. Unanalyzed function calls
+ -- may appear as identifiers or indexed components.
+
+ if Nkind_In (Init_Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Init_Expr)
+ then
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
end if;
- Finalization_Done := True;
+ In_Place_Expansion :=
+ Nkind (Init_Expr) = N_Function_Call
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
- -- Determine the external finalization list. It is either the
- -- finalization list of the outer-scope or the one coming from an
- -- outer aggregate. When the target is not a temporary, the proper
- -- scope is the scope of the target rather than the potentially
- -- transient current scope.
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope.
- if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
- Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
- Set_Assignment_OK (Ref);
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in place.
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Ref))));
- end if;
- end Generate_Finalization_Actions;
+ if In_Place_Expansion then
- 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.
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
- 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.
+ Set_No_Side_Effect_Removal (Init_Expr);
- --------------------------
- -- Rewrite_Discriminant --
- --------------------------
+ -- Install all hook-related declarations and prepare the clean up
+ -- statements. The generated code follows the initialization order
+ -- of individual components and discriminants, rather than being
+ -- inserted prior to the aggregate. This ensures that a transient
+ -- component which mentions a discriminant has proper visibility
+ -- of the discriminant.
- function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (Expr)
- and then Present (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_In_Parameter
- and then Present (Discriminal_Link (Entity (Expr)))
- and then Scope (Discriminal_Link (Entity (Expr))) =
- Base_Type (Etype (N))
- then
- Rewrite (Expr,
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
end if;
- return OK;
- end Rewrite_Discriminant;
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the record component.
+ -- This also performs tag adjustment and [deep] adjustment of the
+ -- record component.
+
+ Initialize_Record_Component
+ (Rec_Comp => Rec_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
+
+ -- At this point the record component is fully initialized. Complete
+ -- the processing of the controlled record component by finalizing
+ -- the transient function result.
+
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Ctrl_Record_Component;
- ------------------
- -- Replace_Type --
- ------------------
+ ---------------------------------
+ -- Initialize_Record_Component --
+ ---------------------------------
- function Replace_Type (Expr : Node_Id) return Traverse_Result is
- begin
- -- Note regarding the Root_Type test below: Aggregate components for
- -- self-referential types include attribute references to the current
- -- instance, of the form: Typ'access, etc.. These references are
- -- rewritten as references to the target of the aggregate: the
- -- left-hand side of an assignment, the entity in a declaration,
- -- or a temporary. Without this test, we would improperly extended
- -- this rewriting to attribute references whose prefix was not the
- -- type of the aggregate.
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
- if Nkind (Expr) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Expr))
- and then Is_Type (Entity (Prefix (Expr)))
- and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
- then
- if Is_Entity_Name (Lhs) then
- Rewrite (Prefix (Expr),
- New_Occurrence_Of (Entity (Lhs), Loc));
+ Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
- elsif Nkind (Lhs) = N_Selected_Component then
- Rewrite (Expr,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => New_Copy_Tree (Lhs)));
- Set_Analyzed (Parent (Expr), False);
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
+ Blk_Stmts : List_Id;
+ Init_Stmt : Node_Id;
+
+ begin
+ -- Protect the initialization statements from aborts. Generate:
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
else
- Rewrite (Expr,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => New_Copy_Tree (Lhs)));
- Set_Analyzed (Parent (Expr), False);
+ Blk_Stmts := Stmts;
end if;
- end if;
- return OK;
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ -- Initialize the record component. Generate:
+
+ -- Rec_Comp := Init_Expr;
+
+ -- Note that the initialization expression is NOT replicated because
+ -- only a single component may be initialized by it.
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Rec_Comp),
+ Expression => Init_Expr);
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ Append_To (Blk_Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Rec_Comp._tag := Full_TypeP;
+
+ if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
+ Append_To (Blk_Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Rec_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the component. Generate:
+
+ -- [Deep_]Adjust (Rec_Comp);
+
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
+ then
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Rec_Comp),
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
+ end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+ end Initialize_Record_Component;
+
+ -------------------------
+ -- Is_Int_Range_Bounds --
+ -------------------------
+
+ function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
+ begin
+ return Nkind (Bounds) = N_Range
+ and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
+ and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
+ end Is_Int_Range_Bounds;
+
+ ------------------
+ -- Replace_Type --
+ ------------------
+
+ function Replace_Type (Expr : Node_Id) return Traverse_Result is
+ begin
+ -- Note regarding the Root_Type test below: Aggregate components for
+ -- self-referential types include attribute references to the current
+ -- instance, of the form: Typ'access, etc.. These references are
+ -- rewritten as references to the target of the aggregate: the
+ -- left-hand side of an assignment, the entity in a declaration,
+ -- or a temporary. Without this test, we would improperly extended
+ -- this rewriting to attribute references whose prefix was not the
+ -- type of the aggregate.
+
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expr))
+ and then Is_Type (Entity (Prefix (Expr)))
+ and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
+ then
+ if Is_Entity_Name (Lhs) then
+ Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc));
+
+ else
+ Rewrite (Expr,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => New_Copy_Tree (Lhs)));
+ Set_Analyzed (Parent (Expr), False);
+ end if;
+ end if;
+
+ return OK;
end Replace_Type;
- procedure Replace_Self_Reference is
- new Traverse_Proc (Replace_Type);
+ --------------------------
+ -- Rewrite_Discriminant --
+ --------------------------
+
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (Expr)))
+ and then Scope (Discriminal_Link (Entity (Expr))) =
+ Base_Type (Etype (N))
+ then
+ Rewrite (Expr,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+
+ -- The generated code will be reanalyzed, but if the reference
+ -- to the discriminant appears within an already analyzed
+ -- expression (e.g. a conditional) we must set its proper entity
+ -- now. Context is an initialization procedure.
+
+ Analyze (Expr);
+ end if;
+
+ return OK;
+ end Rewrite_Discriminant;
procedure Replace_Discriminants is
new Traverse_Proc (Rewrite_Discriminant);
+ procedure Replace_Self_Reference is
+ new Traverse_Proc (Replace_Type);
+
-- Start of processing for Build_Record_Aggr_Code
begin
if Nkind (N) = N_Extension_Aggregate then
declare
Ancestor : constant Node_Id := Ancestor_Part (N);
+ Adj_Call : Node_Id;
Assign : List_Id;
begin
-- Ada 2005 (AI-287): If the ancestor part is an aggregate of
-- limited type, a recursive call expands the ancestor. Note that
-- in the limited case, the ancestor part must be either a
- -- function call (possibly qualified, or wrapped in an unchecked
- -- conversion) or aggregate (definitely qualified).
-
- -- The ancestor part can also be a function call (that may be
- -- transformed into an explicit dereference) or a qualification
- -- of one such.
+ -- function call (possibly qualified) or aggregate (definitely
+ -- qualified).
elsif Is_Limited_Type (Etype (Ancestor))
and then Nkind_In (Unqualify (Ancestor), N_Aggregate,
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
- (Typ => Base_Type (Typ),
- Target => Target,
- Stmts_List => Assign);
+ (Typ => Base_Type (Typ),
+ Target => Target,
+ Stmts_List => Assign,
+ Init_Tags_List => Assign);
end if;
end if;
if Needs_Finalization (Etype (Ancestor))
and then not Is_Limited_Type (Etype (Ancestor))
+ and then not Is_Build_In_Place_Function_Call (Ancestor)
then
- Append_To (Assign,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Ref),
- Typ => Etype (Ancestor)));
+ Typ => Etype (Ancestor));
+
+ -- Guard against a missing [Deep_]Adjust when the ancestor
+ -- type was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Assign, Adj_Call);
+ end if;
end if;
Append_To (L,
Check_Ancestor_Discriminants (Init_Typ);
end if;
end if;
+
+ pragma Assert (Nkind (N) = N_Extension_Aggregate);
+ pragma Assert
+ (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
end;
-- Generate assignments of hidden discriminants. If the base type is
end if;
end if;
- if Generate_C_Code
+ if Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Aggregate
and then Is_Array_Type (Etype (Expr_Q))
and then Present (First_Index (Etype (Expr_Q)))
Ctype => Component_Type (Expr_Q_Type),
Index => First_Index (Expr_Q_Type),
Into => Comp_Expr,
- Scalar_Comp => Is_Scalar_Type
- (Component_Type (Expr_Q_Type))));
+ Scalar_Comp =>
+ Is_Scalar_Type (Component_Type (Expr_Q_Type))));
end;
else
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name => Comp_Expr,
- Expression => Expr_Q);
-
- Set_No_Ctrl_Actions (Instr);
- Append_To (L, Instr);
- end if;
-
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for a VM where tags are
- -- implicit.
-
- -- tmp.comp._tag := comp_typ'tag;
-
- if Is_Tagged_Type (Comp_Type)
- and then Tagged_Type_Expansion
- then
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Comp_Expr),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Comp_Type), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
- Loc)));
-
- Append_To (L, Instr);
- end if;
+ -- Handle an initialization expression of a controlled type
+ -- in case it denotes a function call. In general such a
+ -- scenario will produce a transient scope, but this will
+ -- lead to wrong order of initialization, adjustment, and
+ -- finalization in the context of aggregates.
+
+ -- Target.Comp := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target.Comp := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
+
+ -- In the example above, the call to Finalize occurs too
+ -- early and as a result it may leave the record component
+ -- in a bad state. Finalization of the transient object
+ -- should really happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect
+ -- removal of the function call. This eliminates the
+ -- transient property of the function result and ensures
+ -- correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target.Comp := Res;
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
+ -- Finalize (Res);
+
+ if Needs_Finalization (Comp_Type)
+ and then Nkind (Expr_Q) /= N_Aggregate
+ then
+ Initialize_Ctrl_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
- -- Generate:
- -- Adjust (tmp.comp);
+ -- Otherwise perform single component initialization
- if Needs_Finalization (Comp_Type)
- and then not Is_Limited_Type (Comp_Type)
- then
- Append_To (L,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Comp_Expr),
- Typ => Comp_Type));
+ else
+ Initialize_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
end if;
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
- (Typ => Base_Type (Typ),
- Target => Target,
- Stmts_List => L);
+ (Typ => Base_Type (Typ),
+ Target => Target,
+ Stmts_List => L,
+ Init_Tags_List => L);
end if;
end if;
Next_Elmt (Disc2);
end loop;
- -- If any discriminant constraint is non-static, emit a check
+ -- If any discriminant constraint is nonstatic, emit a check
if Present (Cond) then
Insert_Action (N,
and then Ekind (Current_Scope) /= E_Return_Statement
and then not Is_Limited_Type (Typ)
then
- Establish_Transient_Scope
- (Aggr,
- Sec_Stack =>
- Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
end if;
declare
- Node_After : constant Node_Id := Next (N);
+ Node_After : constant Node_Id := Next (N);
begin
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
Collect_Initialization_Statements (Obj, N, Node_After);
end;
+
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
Insert_Actions_After (Decl, Aggr_Code);
end Convert_Array_Aggr_In_Allocator;
- ----------------------------
- -- Convert_To_Assignments --
- ----------------------------
+ ------------------------
+ -- In_Place_Assign_OK --
+ ------------------------
- procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- T : Entity_Id;
- Temp : Entity_Id;
+ function In_Place_Assign_OK (N : Node_Id) return Boolean is
+ Is_Array : constant Boolean := Is_Array_Type (Etype (N));
- Aggr_Code : List_Id;
- Instr : Node_Id;
- Target_Expr : Node_Id;
- Parent_Kind : Node_Kind;
- Unc_Decl : Boolean := False;
- Parent_Node : Node_Id;
+ Aggr_In : Node_Id;
+ Aggr_Lo : Node_Id;
+ Aggr_Hi : Node_Id;
+ Obj_In : Node_Id;
+ Obj_Lo : Node_Id;
+ Obj_Hi : Node_Id;
- begin
- pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
- pragma Assert (Is_Record_Type (Typ));
+ function Safe_Aggregate (Aggr : Node_Id) return Boolean;
+ -- Check recursively that each component of a (sub)aggregate does not
+ -- depend on the variable being assigned to.
- Parent_Node := Parent (N);
- Parent_Kind := Nkind (Parent_Node);
+ function Safe_Component (Expr : Node_Id) return Boolean;
+ -- Verify that an expression cannot depend on the variable being
+ -- assigned to. Room for improvement here (but less than before).
- if Parent_Kind = N_Qualified_Expression then
+ --------------------
+ -- Safe_Aggregate --
+ --------------------
- -- Check if we are in a unconstrained declaration because in this
- -- case the current delayed expansion mechanism doesn't work when
- -- the declared object size depend on the initializing expr.
+ function Safe_Aggregate (Aggr : Node_Id) return Boolean is
+ Expr : Node_Id;
- begin
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
+ begin
+ if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then
+ return False;
+ end if;
- if Parent_Kind = N_Object_Declaration then
- Unc_Decl :=
- not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
- or else Is_Class_Wide_Type
- (Entity (Object_Definition (Parent_Node)));
- end if;
- end;
- end if;
+ if Present (Expressions (Aggr)) then
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Aggregate then
+ if not Safe_Aggregate (Expr) then
+ return False;
+ end if;
- -- Just set the Delay flag in the cases where the transformation will be
- -- done top down from above.
+ elsif not Safe_Component (Expr) then
+ return False;
+ end if;
- if False
+ Next (Expr);
+ end loop;
+ end if;
- -- Internal aggregate (transformed when expanding the parent)
+ if Present (Component_Associations (Aggr)) then
+ Expr := First (Component_Associations (Aggr));
+ while Present (Expr) loop
+ if Nkind (Expression (Expr)) = N_Aggregate then
+ if not Safe_Aggregate (Expression (Expr)) then
+ return False;
+ end if;
- or else Parent_Kind = N_Aggregate
- or else Parent_Kind = N_Extension_Aggregate
- or else Parent_Kind = N_Component_Association
+ -- If association has a box, no way to determine yet whether
+ -- default can be assigned in place.
- -- Allocator (see Convert_Aggr_In_Allocator)
+ elsif Box_Present (Expr) then
+ return False;
- or else Parent_Kind = N_Allocator
+ elsif not Safe_Component (Expression (Expr)) then
+ return False;
+ end if;
- -- Object declaration (see Convert_Aggr_In_Object_Decl)
+ Next (Expr);
+ end loop;
+ end if;
- or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
+ return True;
+ end Safe_Aggregate;
- -- Safe assignment (see Convert_Aggr_Assignments). So far only the
- -- assignments in init procs are taken into account.
+ --------------------
+ -- Safe_Component --
+ --------------------
- or else (Parent_Kind = N_Assignment_Statement
- and then Inside_Init_Proc)
+ function Safe_Component (Expr : Node_Id) return Boolean is
+ Comp : Node_Id := Expr;
- -- (Ada 2005) An inherently limited type in a return statement, which
- -- will be handled in a build-in-place fashion, and may be rewritten
- -- as an extended return and have its own finalization machinery.
- -- In the case of a simple return, the aggregate needs to be delayed
- -- until the scope for the return statement has been created, so
- -- that any finalization chain will be associated with that scope.
- -- For extended returns, we delay expansion to avoid the creation
- -- of an unwanted transient scope that could result in premature
- -- finalization of the return object (which is built in place
- -- within the caller's scope).
+ function Check_Component (Comp : Node_Id) return Boolean;
+ -- Do the recursive traversal, after copy
- or else
- (Is_Limited_View (Typ)
- and then
- (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
- or else Nkind (Parent_Node) = N_Simple_Return_Statement))
- then
- Set_Expansion_Delayed (N);
- return;
- end if;
+ ---------------------
+ -- Check_Component --
+ ---------------------
- -- Otherwise, if a transient scope is required, create it now. If we
- -- are within an initialization procedure do not create such, because
- -- the target of the assignment must not be declared within a local
- -- block, and because cleanup will take place on return from the
- -- initialization procedure.
- -- Should the condition be more restrictive ???
+ function Check_Component (Comp : Node_Id) return Boolean is
+ begin
+ if Is_Overloaded (Comp) then
+ return False;
+ end if;
- if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
- Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ));
- end if;
+ return Compile_Time_Known_Value (Comp)
- -- If the aggregate is non-limited, create a temporary. If it is limited
- -- and context is an assignment, this is a subaggregate for an enclosing
- -- aggregate being expanded. It must be built in place, so use target of
- -- the current assignment.
+ or else (Is_Entity_Name (Comp)
+ and then Present (Entity (Comp))
+ and then Ekind (Entity (Comp)) not in Type_Kind
+ and then No (Renamed_Object (Entity (Comp))))
- if Is_Limited_Type (Typ)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- then
- Target_Expr := New_Copy_Tree (Name (Parent (N)));
- Insert_Actions (Parent (N),
- Build_Record_Aggr_Code (N, Typ, Target_Expr));
- Rewrite (Parent (N), Make_Null_Statement (Loc));
+ or else (Nkind (Comp) = N_Attribute_Reference
+ and then Check_Component (Prefix (Comp)))
- else
- Temp := Make_Temporary (Loc, 'A', N);
+ or else (Nkind (Comp) in N_Binary_Op
+ and then Check_Component (Left_Opnd (Comp))
+ and then Check_Component (Right_Opnd (Comp)))
- -- If the type inherits unknown discriminants, use the view with
- -- known discriminants if available.
+ or else (Nkind (Comp) in N_Unary_Op
+ and then Check_Component (Right_Opnd (Comp)))
- if Has_Unknown_Discriminants (Typ)
- and then Present (Underlying_Record_View (Typ))
- then
- T := Underlying_Record_View (Typ);
- else
- T := Typ;
- end if;
+ or else (Nkind (Comp) = N_Selected_Component
+ and then Is_Array
+ and then Check_Component (Prefix (Comp)))
- Instr :=
- Make_Object_Declaration (Loc,
+ or else (Nkind_In (Comp, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ and then Check_Component (Expression (Comp)));
+ end Check_Component;
+
+ -- Start of processing for Safe_Component
+
+ begin
+ -- If the component appears in an association that may correspond
+ -- to more than one element, it is not analyzed before expansion
+ -- into assignments, to avoid side effects. We analyze, but do not
+ -- resolve the copy, to obtain sufficient entity information for
+ -- the checks that follow. If component is overloaded we assume
+ -- an unsafe function call.
+
+ if not Analyzed (Comp) then
+ if Is_Overloaded (Expr) then
+ return False;
+
+ elsif Nkind (Expr) = N_Aggregate
+ and then not Is_Others_Aggregate (Expr)
+ then
+ return False;
+
+ elsif Nkind (Expr) = N_Allocator then
+
+ -- For now, too complex to analyze
+
+ return False;
+
+ elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then
+
+ -- Ditto for iterated component associations, which in general
+ -- require an enclosing loop and involve nonstatic expressions.
+
+ return False;
+ end if;
+
+ Comp := New_Copy_Tree (Expr);
+ Set_Parent (Comp, Parent (Expr));
+ Analyze (Comp);
+ end if;
+
+ if Nkind (Comp) = N_Aggregate then
+ return Safe_Aggregate (Comp);
+ else
+ return Check_Component (Comp);
+ end if;
+ end Safe_Component;
+
+ -- Start of processing for In_Place_Assign_OK
+
+ begin
+ -- By-copy semantic cannot be guaranteed for controlled objects or
+ -- objects with discriminants.
+
+ if Needs_Finalization (Etype (N))
+ or else Has_Discriminants (Etype (N))
+ then
+ return False;
+
+ elsif Is_Array and then Present (Component_Associations (N)) then
+
+ -- On assignment, sliding can take place, so we cannot do the
+ -- assignment in place unless the bounds of the aggregate are
+ -- statically equal to those of the target.
+
+ -- If the aggregate is given by an others choice, the bounds are
+ -- derived from the left-hand side, and the assignment is safe if
+ -- the expression is.
+
+ if Is_Others_Aggregate (N) then
+ return
+ Safe_Component
+ (Expression (First (Component_Associations (N))));
+ 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
+ -- Context is an allocator. Check bounds of aggregate against
+ -- given type in qualified expression.
+
+ pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
+ Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
+ end if;
+
+ while Present (Aggr_In) loop
+ Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
+ Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
+
+ if not Compile_Time_Known_Value (Aggr_Lo)
+ or else not Compile_Time_Known_Value (Obj_Lo)
+ or else not Compile_Time_Known_Value (Obj_Hi)
+ or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
+ then
+ return False;
+
+ -- For an assignment statement we require static matching of
+ -- bounds. Ditto for an allocator whose qualified expression
+ -- is a constrained type. If the expression in the allocator
+ -- is an unconstrained array, we accept an upper bound that
+ -- is not static, to allow for nonstatic expressions of the
+ -- base type. Clearly there are further possibilities (with
+ -- diminishing returns) for safely building arrays in place
+ -- here.
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ or else Is_Constrained (Etype (Parent (N)))
+ then
+ if not Compile_Time_Known_Value (Aggr_Hi)
+ or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
+ then
+ return False;
+ end if;
+ end if;
+
+ Next_Index (Aggr_In);
+ Next_Index (Obj_In);
+ end loop;
+ end if;
+
+ -- Now check the component values themselves
+
+ return Safe_Aggregate (N);
+ end In_Place_Assign_OK;
+
+ ----------------------------
+ -- Convert_To_Assignments --
+ ----------------------------
+
+ procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ T : Entity_Id;
+ Temp : Entity_Id;
+
+ Aggr_Code : List_Id;
+ Instr : Node_Id;
+ Target_Expr : Node_Id;
+ Parent_Kind : Node_Kind;
+ Unc_Decl : Boolean := False;
+ Parent_Node : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
+ pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
+ pragma Assert (Is_Record_Type (Typ));
+
+ Parent_Node := Parent (N);
+ Parent_Kind := Nkind (Parent_Node);
+
+ if Parent_Kind = N_Qualified_Expression then
+ -- Check if we are in an unconstrained declaration because in this
+ -- case the current delayed expansion mechanism doesn't work when
+ -- the declared object size depends on the initializing expr.
+
+ Parent_Node := Parent (Parent_Node);
+ Parent_Kind := Nkind (Parent_Node);
+
+ if Parent_Kind = N_Object_Declaration then
+ Unc_Decl :=
+ not Is_Entity_Name (Object_Definition (Parent_Node))
+ or else (Nkind (N) = N_Aggregate
+ and then
+ Has_Discriminants
+ (Entity (Object_Definition (Parent_Node))))
+ or else Is_Class_Wide_Type
+ (Entity (Object_Definition (Parent_Node)));
+ end if;
+ end if;
+
+ -- Just set the Delay flag in the cases where the transformation will be
+ -- done top down from above.
+
+ if False
+
+ -- Internal aggregate (transformed when expanding the parent)
+
+ or else Parent_Kind = N_Aggregate
+ or else Parent_Kind = N_Extension_Aggregate
+ or else Parent_Kind = N_Component_Association
+
+ -- Allocator (see Convert_Aggr_In_Allocator)
+
+ or else Parent_Kind = N_Allocator
+
+ -- Object declaration (see Convert_Aggr_In_Object_Decl)
+
+ or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
+
+ -- Safe assignment (see Convert_Aggr_Assignments). So far only the
+ -- assignments in init procs are taken into account.
+
+ or else (Parent_Kind = N_Assignment_Statement
+ and then Inside_Init_Proc)
+
+ -- (Ada 2005) An inherently limited type in a return statement, which
+ -- will be handled in a build-in-place fashion, and may be rewritten
+ -- as an extended return and have its own finalization machinery.
+ -- In the case of a simple return, the aggregate needs to be delayed
+ -- until the scope for the return statement has been created, so
+ -- that any finalization chain will be associated with that scope.
+ -- For extended returns, we delay expansion to avoid the creation
+ -- of an unwanted transient scope that could result in premature
+ -- finalization of the return object (which is built in place
+ -- within the caller's scope).
+
+ or else Is_Build_In_Place_Aggregate_Return (N)
+ then
+ Set_Expansion_Delayed (N);
+ return;
+ end if;
+
+ -- Otherwise, if a transient scope is required, create it now. If we
+ -- are within an initialization procedure do not create such, because
+ -- the target of the assignment must not be declared within a local
+ -- block, and because cleanup will take place on return from the
+ -- initialization procedure.
+
+ -- Should the condition be more restrictive ???
+
+ if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
+ end if;
+
+ -- If the aggregate is nonlimited, create a temporary, since aggregates
+ -- have "by copy" semantics. If it is limited and context is an
+ -- assignment, this is a subaggregate for an enclosing aggregate being
+ -- expanded. It must be built in place, so use target of the current
+ -- assignment.
+
+ if Is_Limited_Type (Typ)
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ then
+ Target_Expr := New_Copy_Tree (Name (Parent (N)));
+ Insert_Actions (Parent (N),
+ Build_Record_Aggr_Code (N, Typ, Target_Expr));
+ Rewrite (Parent (N), Make_Null_Statement (Loc));
+
+ -- Do not declare a temporary to initialize an aggregate assigned to an
+ -- identifier when in-place assignment is possible, preserving the
+ -- by-copy semantic of aggregates. This avoids large stack usage and
+ -- generates more efficient code.
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ and then Nkind (Name (Parent (N))) = N_Identifier
+ and then In_Place_Assign_OK (N)
+ then
+ Target_Expr := New_Copy_Tree (Name (Parent (N)));
+ Insert_Actions (Parent (N),
+ Build_Record_Aggr_Code (N, Typ, Target_Expr));
+ Rewrite (Parent (N), Make_Null_Statement (Loc));
+
+ else
+ Temp := Make_Temporary (Loc, 'A', N);
+
+ -- If the type inherits unknown discriminants, use the view with
+ -- known discriminants if available.
+
+ if Has_Unknown_Discriminants (Typ)
+ and then Present (Underlying_Record_View (Typ))
+ then
+ T := Underlying_Record_View (Typ);
+ else
+ T := Typ;
+ end if;
+
+ Instr :=
+ Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (T, Loc));
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 32;
Handle_Bit_Packed : Boolean := False)
is
Typ : constant Entity_Id := Etype (N);
-- Return True iff the array N is flat (which is not trivial in the case
-- of multidimensional aggregates).
+ function Is_Static_Element (N : Node_Id) return Boolean;
+ -- Return True if N, an element of a component association list, i.e.
+ -- N_Component_Association or N_Iterated_Component_Association, has a
+ -- compile-time known value and can be passed as is to the back-end
+ -- without further expansion.
+ -- An Iterated_Component_Association is treated as nonstatic in most
+ -- cases for now, so there are possibilities for optimization.
+
-----------------------------
-- Check_Static_Components --
-----------------------------
-- Could use some comments in this body ???
procedure Check_Static_Components is
- Expr : Node_Id;
+ Assoc : Node_Id;
+ Expr : Node_Id;
begin
Static_Components := True;
if Nkind (N) = N_Aggregate
and then Present (Component_Associations (N))
then
- Expr := First (Component_Associations (N));
- while Present (Expr) loop
- if Nkind_In (Expression (Expr), N_Integer_Literal,
- N_Real_Literal)
- then
- null;
-
- elsif Is_Entity_Name (Expression (Expr))
- and then Present (Entity (Expression (Expr)))
- and then Ekind (Entity (Expression (Expr))) =
- E_Enumeration_Literal
- then
- null;
-
- elsif Nkind (Expression (Expr)) /= N_Aggregate
- or else not Compile_Time_Known_Aggregate (Expression (Expr))
- or else Expansion_Delayed (Expression (Expr))
- then
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ if not Is_Static_Element (Assoc) then
Static_Components := False;
exit;
end if;
- Next (Expr);
+ Next (Assoc);
end loop;
end if;
end Check_Static_Components;
if Box_Present (Assoc) then
return False;
+
+ elsif Nkind (Assoc) = N_Iterated_Component_Association then
+ return False;
end if;
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
return False;
end if;
- Vals (Num) := Relocate_Node (Elmt);
+ -- Duplicate expression for each index it covers
+
+ Vals (Num) := New_Copy_Tree (Elmt);
Num := Num + 1;
Next (Elmt);
end if;
Component_Loop : while Present (Elmt) loop
- Choice := First (Choices (Elmt));
+ Choice := First (Choice_List (Elmt));
Choice_Loop : while Present (Choice) loop
-- If we have an others choice, fill in the missing elements
if Nkind (Choice) = N_Others_Choice then
Rep_Count := 0;
+ -- If the expression involves a construct that generates
+ -- a loop, we must generate individual assignments and
+ -- no flattening is possible.
+
+ if Nkind (Expression (Elmt)) = N_Quantified_Expression
+ then
+ return False;
+ end if;
+
for J in Vals'Range loop
if No (Vals (J)) then
- Vals (J) := New_Copy_Tree (Expression (Elmt));
+ Vals (J) := New_Copy_Tree (Expression (Elmt));
Rep_Count := Rep_Count + 1;
-- Check for maximum others replication. Note that
declare
P : constant Entity_Id :=
- Cunit_Entity (Current_Sem_Unit);
+ Cunit_Entity (Current_Sem_Unit);
begin
- -- Check if duplication OK and if so continue
- -- processing.
+ -- Check if duplication is always OK and, if so,
+ -- continue processing.
if Restriction_Active (No_Elaboration_Code)
or else Restriction_Active (No_Implicit_Loops)
and then
Is_Preelaborated (Spec_Entity (P)))
or else
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (P)))
+ Is_Predefined_Unit (Get_Source_Unit (P))
then
null;
- -- If duplication not OK, then we return False
- -- if the replication count is too high
+ -- If duplication is not always OK, continue
+ -- only if either the element is static or is
+ -- an aggregate which can itself be flattened,
+ -- and the replication count is not too high.
- elsif Rep_Count > Max_Others_Replicate then
- return False;
+ elsif (Is_Static_Element (Elmt)
+ or else
+ (Nkind (Expression (Elmt)) = N_Aggregate
+ and then Present (Next_Index (Ix))))
+ and then Rep_Count <= Max_Others_Replicate
+ then
+ null;
- -- Continue on if duplication not OK, but the
- -- replication count is not excessive.
+ -- Return False in all the other cases
else
- null;
+ return False;
end if;
end;
end if;
end loop;
+ if Rep_Count = 0
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_N ("there are no others?r?", Elmt);
+ end if;
+
exit Component_Loop;
-- Case of a subtype mark, identifier or expanded name
end if;
end Is_Flat;
+ -------------------------
+ -- Is_Static_Element --
+ -------------------------
+
+ function Is_Static_Element (N : Node_Id) return Boolean is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
+ return True;
+
+ elsif Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_Enumeration_Literal
+ then
+ return True;
+
+ elsif Nkind (N) = N_Iterated_Component_Association then
+ return False;
+
+ elsif Nkind (Expr) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (Expr)
+ and then not Expansion_Delayed (Expr)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Static_Element;
+
-- Start of processing for Convert_To_Positional
begin
-- object declaration, this is the only case where aggregates are
-- supported in C.
- if Modify_Tree_For_C and then not In_Object_Declaration (N) then
+ if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
return;
end if;
return;
end if;
+ -- A subaggregate may have been flattened but is not known to be
+ -- Compile_Time_Known. Set that flag in cases that cannot require
+ -- elaboration code, so that the aggregate can be used as the
+ -- initial value of a thread-local variable.
+
if Is_Flat (N, Number_Dimensions (Typ)) then
+ if Static_Array_Aggregate (N) then
+ Set_Compile_Time_Known_Aggregate (N);
+ end if;
+
return;
end if;
-- case pass it as is to Gigi. Note that a necessary condition for
-- static processing is that the aggregate be fully positional.
- -- 5. If in place aggregate expansion is possible (i.e. no need to create
+ -- 5. If in-place aggregate expansion is possible (i.e. no need to create
-- a temporary) then mark the aggregate as such and return. Otherwise
-- create a new temporary and generate the appropriate initialization
-- code.
-- The type of each index
In_Place_Assign_OK_For_Declaration : Boolean := False;
- -- True if we are to generate an in place assignment for a declaration
+ -- True if we are to generate an in-place assignment for a declaration
Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate
-- subaggregate we start the computation from. Dim is the dimension
-- corresponding to the subaggregate.
- function In_Place_Assign_OK return Boolean;
- -- Simple predicate to determine whether an aggregate assignment can
- -- be done in place, because none of the new values can depend on the
- -- components of the target of the assignment.
-
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
-- Checks that if an others choice is present in any subaggregate, no
-- aggregate index is outside the bounds of the index constraint.
-- 1. N consists of a single OTHERS choice, possibly recursively
- -- 2. The array type is not packed
+ -- 2. The array type has no null ranges (the purpose of this is to
+ -- avoid a bogus warning for an out-of-range value).
-- 3. The array type has no atomic components
- -- 4. The array type has no null ranges (the purpose of this is to
- -- avoid a bogus warning for an out-of-range value).
+ -- 4. The component type is elementary
- -- 5. The component type is discrete
+ -- 5. The component size is a multiple of Storage_Unit
-- 6. The component size is Storage_Unit or the value is of the form
-- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
-- specifically optimized for the target.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
+ Csiz : Uint := No_Uint;
Ctyp : Entity_Id;
+ Expr : Node_Id;
+ High : Node_Id;
Index : Entity_Id;
- Expr : Node_Id := N;
Low : Node_Id;
- High : Node_Id;
+ Nunits : Int;
Remainder : Uint;
Value : Uint;
- Nunits : Nat;
begin
+ -- Back end doesn't know about <>
+
+ if Has_Default_Init_Comps (N) then
+ return False;
+ end if;
+
-- Recurse as far as possible to find the innermost component type
Ctyp := Etype (N);
+ Expr := N;
while Is_Array_Type (Ctyp) loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
return False;
end if;
- if Present (Packed_Array_Impl_Type (Ctyp)) then
- return False;
- end if;
-
- if Has_Atomic_Components (Ctyp) then
- return False;
- end if;
-
Index := First_Index (Ctyp);
while Present (Index) loop
Get_Index_Bounds (Index, Low, High);
Expr := Expression (First (Component_Associations (Expr)));
end loop;
+ if Has_Atomic_Components (Ctyp) then
+ return False;
+ end if;
+
+ Csiz := Component_Size (Ctyp);
Ctyp := Component_Type (Ctyp);
if Is_Atomic_Or_VFA (Ctyp) then
end if;
end loop;
- if not Is_Discrete_Type (Ctyp) then
+ -- An Iterated_Component_Association involves a loop (in most cases)
+ -- and is never static.
+
+ if Nkind (Parent (Expr)) = N_Iterated_Component_Association then
return False;
end if;
- -- The expression needs to be analyzed if True is returned
+ -- Access types need to be dealt with specially
- Analyze_And_Resolve (Expr, Ctyp);
+ if Is_Access_Type (Ctyp) then
- -- The back end uses the Esize as the precision of the type
+ -- Component_Size is not set by Layout_Type if the component
+ -- type is an access type ???
- Nunits := UI_To_Int (Esize (Ctyp)) / System_Storage_Unit;
+ Csiz := Esize (Ctyp);
- if Nunits = 1 then
- return True;
+ -- Fat pointers are rejected as they are not really elementary
+ -- for the backend.
+
+ if Csiz /= System_Address_Size then
+ return False;
+ end if;
+
+ -- The supported expressions are NULL and constants, others are
+ -- rejected upfront to avoid being analyzed below, which can be
+ -- problematic for some of them, for example allocators.
+
+ if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
+ return False;
+ end if;
+
+ -- Scalar types are OK if their size is a multiple of Storage_Unit
+
+ elsif Is_Scalar_Type (Ctyp) then
+ pragma Assert (Csiz /= No_Uint);
+
+ if Csiz mod System_Storage_Unit /= 0 then
+ return False;
+ end if;
+
+ -- Composite types are rejected
+
+ else
+ return False;
+ end if;
+
+ -- If the expression has side effects (e.g. contains calls with
+ -- potential side effects) reject as well. We only preanalyze the
+ -- expression to prevent the removal of intended side effects.
+
+ Preanalyze_And_Resolve (Expr, Ctyp);
+
+ if not Side_Effect_Free (Expr) then
+ return False;
+ end if;
+
+ -- The expression needs to be analyzed if True is returned
+
+ Analyze_And_Resolve (Expr, Ctyp);
+
+ -- Strip away any conversions from the expression as they simply
+ -- qualify the real expression.
+
+ while Nkind_In (Expr, N_Unchecked_Type_Conversion,
+ N_Type_Conversion)
+ loop
+ Expr := Expression (Expr);
+ end loop;
+
+ Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
+
+ if Nunits = 1 then
+ return True;
end if;
if not Compile_Time_Known_Value (Expr) then
return False;
end if;
+ -- The only supported value for floating point is 0.0
+
+ if Is_Floating_Point_Type (Ctyp) then
+ return Expr_Value_R (Expr) = Ureal_0;
+ end if;
+
+ -- For other types, we can look into the value as an integer
+
Value := Expr_Value (Expr);
if Has_Biased_Representation (Ctyp) then
if Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
- if Nkind (First (Choices (Assoc))) = N_Others_Choice then
+ if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then
Others_Present (Dim) := True;
end if;
end if;
end if;
end Compute_Others_Present;
- ------------------------
- -- In_Place_Assign_OK --
- ------------------------
-
- function In_Place_Assign_OK return Boolean is
- Aggr_In : Node_Id;
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
- Obj_In : Node_Id;
- Obj_Lo : Node_Id;
- Obj_Hi : Node_Id;
-
- function Safe_Aggregate (Aggr : Node_Id) return Boolean;
- -- Check recursively that each component of a (sub)aggregate does not
- -- depend on the variable being assigned to.
-
- function Safe_Component (Expr : Node_Id) return Boolean;
- -- Verify that an expression cannot depend on the variable being
- -- assigned to. Room for improvement here (but less than before).
-
- --------------------
- -- Safe_Aggregate --
- --------------------
-
- function Safe_Aggregate (Aggr : Node_Id) return Boolean is
- Expr : Node_Id;
-
- begin
- if Present (Expressions (Aggr)) then
- Expr := First (Expressions (Aggr));
- while Present (Expr) loop
- if Nkind (Expr) = N_Aggregate then
- if not Safe_Aggregate (Expr) then
- return False;
- end if;
-
- elsif not Safe_Component (Expr) then
- return False;
- end if;
-
- Next (Expr);
- end loop;
- end if;
-
- if Present (Component_Associations (Aggr)) then
- Expr := First (Component_Associations (Aggr));
- while Present (Expr) loop
- if Nkind (Expression (Expr)) = N_Aggregate then
- if not Safe_Aggregate (Expression (Expr)) then
- return False;
- end if;
-
- -- If association has a box, no way to determine yet
- -- whether default can be assigned in place.
-
- elsif Box_Present (Expr) then
- return False;
-
- elsif not Safe_Component (Expression (Expr)) then
- return False;
- end if;
-
- Next (Expr);
- end loop;
- end if;
-
- return True;
- end Safe_Aggregate;
-
- --------------------
- -- Safe_Component --
- --------------------
-
- function Safe_Component (Expr : Node_Id) return Boolean is
- Comp : Node_Id := Expr;
-
- function Check_Component (Comp : Node_Id) return Boolean;
- -- Do the recursive traversal, after copy
-
- ---------------------
- -- Check_Component --
- ---------------------
-
- function Check_Component (Comp : Node_Id) return Boolean is
- begin
- if Is_Overloaded (Comp) then
- return False;
- end if;
-
- return Compile_Time_Known_Value (Comp)
-
- or else (Is_Entity_Name (Comp)
- and then Present (Entity (Comp))
- and then No (Renamed_Object (Entity (Comp))))
-
- or else (Nkind (Comp) = N_Attribute_Reference
- and then Check_Component (Prefix (Comp)))
-
- or else (Nkind (Comp) in N_Binary_Op
- and then Check_Component (Left_Opnd (Comp))
- and then Check_Component (Right_Opnd (Comp)))
-
- or else (Nkind (Comp) in N_Unary_Op
- and then Check_Component (Right_Opnd (Comp)))
-
- or else (Nkind (Comp) = N_Selected_Component
- and then Check_Component (Prefix (Comp)))
-
- or else (Nkind (Comp) = N_Unchecked_Type_Conversion
- and then Check_Component (Expression (Comp)));
- end Check_Component;
-
- -- Start of processing for Safe_Component
-
- begin
- -- If the component appears in an association that may correspond
- -- to more than one element, it is not analyzed before expansion
- -- into assignments, to avoid side effects. We analyze, but do not
- -- resolve the copy, to obtain sufficient entity information for
- -- the checks that follow. If component is overloaded we assume
- -- an unsafe function call.
-
- if not Analyzed (Comp) then
- if Is_Overloaded (Expr) then
- return False;
-
- elsif Nkind (Expr) = N_Aggregate
- and then not Is_Others_Aggregate (Expr)
- then
- return False;
-
- elsif Nkind (Expr) = N_Allocator then
-
- -- For now, too complex to analyze
-
- return False;
- end if;
-
- Comp := New_Copy_Tree (Expr);
- Set_Parent (Comp, Parent (Expr));
- Analyze (Comp);
- end if;
-
- if Nkind (Comp) = N_Aggregate then
- return Safe_Aggregate (Comp);
- else
- return Check_Component (Comp);
- end if;
- end Safe_Component;
-
- -- Start of processing for In_Place_Assign_OK
-
- begin
- if Present (Component_Associations (N)) then
-
- -- On assignment, sliding can take place, so we cannot do the
- -- assignment in place unless the bounds of the aggregate are
- -- statically equal to those of the target.
-
- -- If the aggregate is given by an others choice, the bounds are
- -- derived from the left-hand side, and the assignment is safe if
- -- the expression is.
-
- if Is_Others_Aggregate (N) then
- return
- Safe_Component
- (Expression (First (Component_Associations (N))));
- 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
- -- Context is an allocator. Check bounds of aggregate against
- -- given type in qualified expression.
-
- pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
- Obj_In :=
- First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
- end if;
-
- while Present (Aggr_In) loop
- Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
- Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
-
- if not Compile_Time_Known_Value (Aggr_Lo)
- or else not Compile_Time_Known_Value (Aggr_Hi)
- or else not Compile_Time_Known_Value (Obj_Lo)
- or else not Compile_Time_Known_Value (Obj_Hi)
- or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
- or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
- then
- return False;
- end if;
-
- Next_Index (Aggr_In);
- Next_Index (Obj_In);
- end loop;
- end if;
-
- -- Now check the component values themselves
-
- return Safe_Aggregate (N);
- end In_Place_Assign_OK;
-
------------------
-- Others_Check --
------------------
elsif Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
- if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
+ if Nkind (First (Choice_List (Assoc))) /= N_Others_Choice then
Need_To_Check := False;
else
Nb_Choices := -1;
Assoc := First (Component_Associations (Sub_Aggr));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Nb_Choices := Nb_Choices + 1;
Next (Choice);
begin
Assoc := First (Component_Associations (Sub_Aggr));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
exit;
-- raise Constraint_Error;
-- end if;
+ -- in the general case, but the following simpler test:
+
+ -- [constraint_error when
+ -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
+
+ -- instead if the index type is a signed integer.
+
elsif Nb_Elements > Uint_0 then
- Cond :=
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions =>
- New_List
- (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
- Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ if Nb_Elements = Uint_1 then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
+
+ elsif Is_Signed_Integer_Type (Ind_Typ) then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (
- Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ else
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions =>
+ New_List
+ (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
+ Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ end if;
-- If we are dealing with an aggregate containing an others choice
-- and discrete choices we generate the following test:
-- that Convert_To_Positional succeeded and reanalyzed the rewritten
-- aggregate.
- elsif Analyzed (N) and then N /= Original_Node (N) then
+ elsif Analyzed (N) and then Is_Rewrite_Substitution (N) then
return;
end if;
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
- if Static_Array_Aggregate (N)
- or else Compile_Time_Known_Aggregate (N)
- then
- Set_Expansion_Delayed (N, False);
- return;
- else
- Set_Expansion_Delayed (N);
- return;
- end if;
+ Set_Expansion_Delayed (N, not Static_Array_Aggregate (N));
+ return;
end if;
-- STEP 4
- -- Look if in place aggregate expansion is possible
+ -- Check whether in-place aggregate expansion is possible
-- For object declarations we build the aggregate in place, unless
- -- the array is bit-packed or the component is controlled.
+ -- the array is bit-packed.
-- For assignments we do the assignment in place if all the component
- -- associations have compile-time known values. For other cases we
+ -- associations have compile-time known values, or are default-
+ -- initialized limited components, e.g. tasks. For other cases we
-- create a temporary. The analysis for safety of on-line assignment
-- is delicate, i.e. we don't know how to do it fully yet ???
-- for default initialization, e.g. with Initialize_Scalars.
if Requires_Transient_Scope (Typ) then
- Establish_Transient_Scope
- (N, Sec_Stack => Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
- if Has_Default_Init_Comps (N) then
+ -- An array of limited components is built in place
+
+ if Is_Limited_Type (Typ) then
+ Maybe_In_Place_OK := True;
+
+ elsif Has_Default_Init_Comps (N) then
Maybe_In_Place_OK := False;
elsif Is_Bit_Packed_Array (Typ)
else
Maybe_In_Place_OK :=
(Nkind (Parent (N)) = N_Assignment_Statement
- and then In_Place_Assign_OK)
+ and then In_Place_Assign_OK (N))
or else
(Nkind (Parent (Parent (N))) = N_Allocator
- and then In_Place_Assign_OK);
+ and then In_Place_Assign_OK (N));
end if;
-- If this is an array of tasks, it will be expanded into build-in-place
-- expected to appear in qualified form. In-place expansion eliminates
-- the qualification and eventually violates this SPARK 05 restiction.
- -- Should document the rest of the guards ???
+ -- Arrays of limited components must be built in place. The code
+ -- previously excluded controlled components but this is an old
+ -- oversight: the rules in 7.6 (17) are clear.
- if not Has_Default_Init_Comps (N)
- and then Comes_From_Source (Parent_Node)
+ if Comes_From_Source (Parent_Node)
and then Parent_Kind = N_Object_Declaration
and then Present (Expression (Parent_Node))
and then not
Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
- and then not Has_Controlled_Component (Typ)
and then not Is_Bit_Packed_Array (Typ)
and then not Restriction_Check_Required (SPARK_05)
then
Set_Expansion_Delayed (N);
return;
+ -- Limited arrays in return statements are expanded when
+ -- enclosing construct is expanded.
+
+ elsif Maybe_In_Place_OK
+ and then Nkind (Parent (N)) = N_Simple_Return_Statement
+ then
+ Set_Expansion_Delayed (N);
+ return;
+
-- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
-- Step 5
- -- In place aggregate expansion is not possible
+ -- In-place aggregate expansion is not possible
else
Maybe_In_Place_OK := False;
Defining_Identifier => Tmp,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Set_No_Initialization (Tmp_Decl, True);
+ Set_Warnings_Off (Tmp);
-- If we are within a loop, the temporary will be pushed on the
- -- stack at each iteration. If the aggregate is the expression for an
- -- allocator, it will be immediately copied to the heap and can
- -- be reclaimed at once. We create a transient scope around the
- -- aggregate for this purpose.
+ -- stack at each iteration. If the aggregate is the expression
+ -- for an allocator, it will be immediately copied to the heap
+ -- and can be reclaimed at once. We create a transient scope
+ -- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
and then Nkind (Parent (Parent (N))) = N_Allocator
then
- Establish_Transient_Scope (N, False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
Insert_Action (N, Tmp_Decl);
Target := New_Occurrence_Of (Tmp, Loc);
else
- if Has_Default_Init_Comps (N) then
-
+ if Has_Default_Init_Comps (N)
+ and then not Maybe_In_Place_OK
+ then
-- Ada 2005 (AI-287): This case has not been analyzed???
raise Program_Error;
Target := New_Copy (Tmp);
end if;
- -- If we are to generate an in place assignment for a declaration or
+ -- If we are to generate an in-place assignment for a declaration or
-- an assignment statement, and the assignment can be done directly
-- by the back end, then do not expand further.
- -- ??? We can also do that if in place expansion is not possible but
+ -- ??? We can also do that if in-place expansion is not possible but
-- then we could go into an infinite recursion.
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
- and then not AAMP_On_Target
and then not CodePeer_Mode
- and then not Generate_C_Code
+ and then not Modify_Tree_For_C
and then not Possible_Bit_Aligned_Component (Target)
and then not Is_Possibly_Unaligned_Slice (Target)
and then Aggr_Assignment_OK_For_Backend (N)
New_List (
Make_Assignment_Statement (Loc,
Name => Target,
- Expression => New_Copy (N)));
+ Expression => New_Copy_Tree (N)));
else
Aggr_Code :=
MX : constant := 80;
begin
- if Nkind (First (Choices (CA))) = N_Others_Choice
+ if Nkind (First (Choice_List (CA))) = N_Others_Choice
and then Nkind (Expression (CA)) = N_Character_Literal
and then No (Expressions (N))
then
return;
end Expand_N_Aggregate;
+ ------------------------------
+ -- Expand_N_Delta_Aggregate --
+ ------------------------------
+
+ procedure Expand_N_Delta_Aggregate (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => New_Copy_Tree (Expression (N)));
+
+ if Is_Array_Type (Etype (N)) then
+ Expand_Delta_Array_Aggregate (N, New_List (Decl));
+ else
+ Expand_Delta_Record_Aggregate (N, New_List (Decl));
+ end if;
+ end Expand_N_Delta_Aggregate;
+
+ ----------------------------------
+ -- Expand_Delta_Array_Aggregate --
+ ----------------------------------
+
+ procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
+ Assoc : Node_Id;
+
+ function Generate_Loop (C : Node_Id) return Node_Id;
+ -- Generate a loop containing individual component assignments for
+ -- choices that are ranges, subtype indications, subtype names, and
+ -- iterated component associations.
+
+ -------------------
+ -- Generate_Loop --
+ -------------------
+
+ function Generate_Loop (C : Node_Id) return Node_Id is
+ Sl : constant Source_Ptr := Sloc (C);
+ Ix : Entity_Id;
+
+ begin
+ if Nkind (Parent (C)) = N_Iterated_Component_Association then
+ Ix :=
+ Make_Defining_Identifier (Loc,
+ Chars => (Chars (Defining_Identifier (Parent (C)))));
+ else
+ Ix := Make_Temporary (Sl, 'I');
+ end if;
+
+ return
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Sl,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Sl,
+ Defining_Identifier => Ix,
+ Discrete_Subtype_Definition => New_Copy_Tree (C))),
+
+ Statements => New_List (
+ Make_Assignment_Statement (Sl,
+ Name =>
+ Make_Indexed_Component (Sl,
+ Prefix => New_Occurrence_Of (Temp, Sl),
+ Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
+ Expression => New_Copy_Tree (Expression (Assoc)))),
+ End_Label => Empty);
+ end Generate_Loop;
+
+ -- Local variables
+
+ Choice : Node_Id;
+
+ -- Start of processing for Expand_Delta_Array_Aggregate
+
+ begin
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ while Present (Choice) loop
+ Append_To (Deltas, Generate_Loop (Choice));
+ Next (Choice);
+ end loop;
+
+ else
+ while Present (Choice) loop
+
+ -- Choice can be given by a range, a subtype indication, a
+ -- subtype name, a scalar value, or an entity.
+
+ if Nkind (Choice) = N_Range
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice)))
+ then
+ Append_To (Deltas, Generate_Loop (Choice));
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Append_To (Deltas,
+ Generate_Loop (Range_Expression (Constraint (Choice))));
+
+ else
+ Append_To (Deltas,
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Indexed_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Expressions => New_List (New_Copy_Tree (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Deltas);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ end Expand_Delta_Array_Aggregate;
+
+ -----------------------------------
+ -- Expand_Delta_Record_Aggregate --
+ -----------------------------------
+
+ procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
+ Assoc : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Assoc := First (Component_Associations (N));
+
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ Append_To (Deltas,
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Selected_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Deltas);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ end Expand_Delta_Record_Aggregate;
+
----------------------------------
-- Expand_N_Extension_Aggregate --
----------------------------------
-- If the ancestor part is an expression, add a component association for
-- the parent field. If the type of the ancestor part is not the direct
- -- parent of the expected type, build recursively the needed ancestors.
- -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
- -- ration for a temporary of the expected type, followed by individual
- -- assignments to the given components.
+ -- parent of the expected type, build recursively the needed ancestors.
+ -- If the ancestor part is a subtype_mark, replace aggregate with a
+ -- declaration for a temporary of the expected type, followed by
+ -- individual assignments to the given components.
procedure Expand_N_Extension_Aggregate (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
A : constant Node_Id := Ancestor_Part (N);
+ Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Static_Components : Boolean := True;
-- Flag to indicate whether all components are compile-time known,
-- and the aggregate can be constructed statically and handled by
- -- the back-end.
+ -- the back-end. Set to False by Component_OK_For_Backend.
+
+ procedure Build_Back_End_Aggregate;
+ -- Build a proper aggregate to be handled by the back-end
function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean;
-- Returns true if N is an expression of composite type which can be
-- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
-- set and constants whose expression is such an aggregate, recursively.
- function Component_Not_OK_For_Backend return Boolean;
+ function Component_OK_For_Backend return Boolean;
-- Check for presence of a component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- of assignment statements. Cases checked for are a nested aggregate
-- in order to minimize elaboration code. This is one case where the
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ --
+ -- NOTE: This sets the global Static_Components to False in most, but
+ -- not all, cases when it returns False.
function Has_Per_Object_Constraint (L : List_Id) return Boolean;
-- Return True if any element of L has Has_Per_Object_Constraint set.
-- For nested aggregates return the ultimate enclosing aggregate; for
-- non-nested aggregates return N.
- ----------------------------------------
- -- Compile_Time_Known_Composite_Value --
- ----------------------------------------
+ ------------------------------
+ -- Build_Back_End_Aggregate --
+ ------------------------------
+
+ procedure Build_Back_End_Aggregate is
+ Comp : Entity_Id;
+ New_Comp : Node_Id;
+ Tag_Value : Node_Id;
- function Compile_Time_Known_Composite_Value
- (N : Node_Id) return Boolean
- is
begin
- -- If we have an entity name, then see if it is the name of a
- -- constant and if so, test the corresponding constant value.
+ if Nkind (N) = N_Aggregate then
- if Is_Entity_Name (N) then
- declare
- E : constant Entity_Id := Entity (N);
- V : Node_Id;
- begin
- if Ekind (E) /= E_Constant then
- return False;
- else
- V := Constant_Value (E);
- return Present (V)
- and then Compile_Time_Known_Composite_Value (V);
- end if;
- end;
-
- -- We have a value, see if it is compile time known
+ -- If the aggregate is static and can be handled by the back-end,
+ -- nothing left to do.
- else
- if Nkind (N) = N_Aggregate then
- return Compile_Time_Known_Aggregate (N);
+ if Static_Components then
+ Set_Compile_Time_Known_Aggregate (N);
+ Set_Expansion_Delayed (N, False);
end if;
-
- -- All other types of values are not known at compile time
-
- return False;
end if;
- end Compile_Time_Known_Composite_Value;
-
- ----------------------------------
- -- Component_Not_OK_For_Backend --
- ----------------------------------
-
- function Component_Not_OK_For_Backend return Boolean is
- C : Node_Id;
- Expr_Q : Node_Id;
+ -- If no discriminants, nothing special to do
- begin
- if No (Comps) then
- return False;
- end if;
+ if not Has_Discriminants (Typ) then
+ null;
- C := First (Comps);
- while Present (C) loop
+ -- Case of discriminants present
- -- If the component has box initialization, expansion is needed
- -- and component is not ready for backend.
+ elsif Is_Derived_Type (Typ) then
- if Box_Present (C) then
- return True;
- end if;
+ -- For untagged types, non-stored discriminants are replaced with
+ -- stored discriminants, which are the ones that gigi uses to
+ -- describe the type and its components.
- if Nkind (Expression (C)) = N_Qualified_Expression then
- Expr_Q := Expression (Expression (C));
- else
- Expr_Q := Expression (C);
- end if;
+ Generate_Aggregate_For_Derived_Type : declare
+ procedure Prepend_Stored_Values (T : Entity_Id);
+ -- Scan the list of stored discriminants of the type, and add
+ -- their values to the aggregate being built.
- -- Return true if the aggregate has any associations for tagged
- -- components that may require tag adjustment.
+ ---------------------------
+ -- Prepend_Stored_Values --
+ ---------------------------
- -- These are cases where the source expression may have a tag that
- -- could differ from the component tag (e.g., can occur for type
- -- conversions and formal parameters). (Tag adjustment not needed
- -- if Tagged_Type_Expansion because object tags are implicit in
- -- the machine.)
+ procedure Prepend_Stored_Values (T : Entity_Id) is
+ Discr : Entity_Id;
+ First_Comp : Node_Id := Empty;
- if Is_Tagged_Type (Etype (Expr_Q))
- and then (Nkind (Expr_Q) = N_Type_Conversion
- or else (Is_Entity_Name (Expr_Q)
- and then
- Ekind (Entity (Expr_Q)) in Formal_Kind))
- and then Tagged_Type_Expansion
- then
- Static_Components := False;
- return True;
+ begin
+ Discr := First_Stored_Discriminant (T);
+ while Present (Discr) loop
+ New_Comp :=
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (Discr, Loc)),
+ Expression =>
+ New_Copy_Tree
+ (Get_Discriminant_Value
+ (Discr,
+ Typ,
+ Discriminant_Constraint (Typ))));
- elsif Is_Delayed_Aggregate (Expr_Q) then
- Static_Components := False;
- return True;
+ if No (First_Comp) then
+ Prepend_To (Component_Associations (N), New_Comp);
+ else
+ Insert_After (First_Comp, New_Comp);
+ end if;
- elsif Possible_Bit_Aligned_Component (Expr_Q) then
- Static_Components := False;
- return True;
+ First_Comp := New_Comp;
+ Next_Stored_Discriminant (Discr);
+ end loop;
+ end Prepend_Stored_Values;
- elsif Modify_Tree_For_C
- and then Nkind (C) = N_Component_Association
- and then Has_Per_Object_Constraint (Choices (C))
- then
- Static_Components := False;
- return True;
+ -- Local variables
- elsif Modify_Tree_For_C
- and then Nkind (Expr_Q) = N_Identifier
- and then Is_Array_Type (Etype (Expr_Q))
- then
- Static_Components := False;
- return True;
- end if;
+ Constraints : constant List_Id := New_List;
- if Is_Elementary_Type (Etype (Expr_Q)) then
- if not Compile_Time_Known_Value (Expr_Q) then
- Static_Components := False;
- end if;
+ Discr : Entity_Id;
+ Decl : Node_Id;
+ Num_Disc : Nat := 0;
+ Num_Gird : Nat := 0;
- elsif not Compile_Time_Known_Composite_Value (Expr_Q) then
- Static_Components := False;
+ -- Start of processing for Generate_Aggregate_For_Derived_Type
- if Is_Private_Type (Etype (Expr_Q))
- and then Has_Discriminants (Etype (Expr_Q))
- then
- return True;
- end if;
- end if;
+ begin
+ -- Remove the associations for the discriminant of derived type
- Next (C);
- end loop;
+ declare
+ First_Comp : Node_Id;
- return False;
- end Component_Not_OK_For_Backend;
+ begin
+ First_Comp := First (Component_Associations (N));
+ while Present (First_Comp) loop
+ Comp := First_Comp;
+ Next (First_Comp);
- -------------------------------
- -- Has_Per_Object_Constraint --
- -------------------------------
+ if Ekind (Entity (First (Choices (Comp)))) =
+ E_Discriminant
+ then
+ Remove (Comp);
+ Num_Disc := Num_Disc + 1;
+ end if;
+ end loop;
+ end;
- function Has_Per_Object_Constraint (L : List_Id) return Boolean is
- N : Node_Id := First (L);
- begin
- while Present (N) loop
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Has_Per_Object_Constraint (Entity (N))
- then
- return True;
- end if;
+ -- Insert stored discriminant associations in the correct
+ -- order. If there are more stored discriminants than new
+ -- discriminants, there is at least one new discriminant that
+ -- constrains more than one of the stored discriminants. In
+ -- this case we need to construct a proper subtype of the
+ -- parent type, in order to supply values to all the
+ -- components. Otherwise there is one-one correspondence
+ -- between the constraints and the stored discriminants.
- Next (N);
- end loop;
+ Discr := First_Stored_Discriminant (Base_Type (Typ));
+ while Present (Discr) loop
+ Num_Gird := Num_Gird + 1;
+ Next_Stored_Discriminant (Discr);
+ end loop;
- return False;
- end Has_Per_Object_Constraint;
+ -- Case of more stored discriminants than new discriminants
- -----------------------------------
- -- Has_Visible_Private_Ancestor --
- -----------------------------------
+ if Num_Gird > Num_Disc then
- function Has_Visible_Private_Ancestor (Id : E) return Boolean is
- R : constant Entity_Id := Root_Type (Id);
- T1 : Entity_Id := Id;
+ -- Create a proper subtype of the parent type, which is the
+ -- proper implementation type for the aggregate, and convert
+ -- it to the intended target type.
- begin
- loop
- if Is_Private_Type (T1) then
- return True;
+ Discr := First_Stored_Discriminant (Base_Type (Typ));
+ while Present (Discr) loop
+ New_Comp :=
+ New_Copy_Tree
+ (Get_Discriminant_Value
+ (Discr,
+ Typ,
+ Discriminant_Constraint (Typ)));
- elsif T1 = R then
- return False;
+ Append (New_Comp, Constraints);
+ Next_Stored_Discriminant (Discr);
+ end loop;
- else
- T1 := Etype (T1);
- end if;
- end loop;
- end Has_Visible_Private_Ancestor;
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint
+ (Loc, Constraints)));
- -------------------------
- -- Top_Level_Aggregate --
- -------------------------
+ Insert_Action (N, Decl);
+ Prepend_Stored_Values (Base_Type (Typ));
- function Top_Level_Aggregate (N : Node_Id) return Node_Id is
- Aggr : Node_Id;
+ Set_Etype (N, Defining_Identifier (Decl));
+ Set_Analyzed (N);
- begin
- Aggr := N;
- while Present (Parent (Aggr))
- and then Nkind_In (Parent (Aggr), N_Component_Association,
- N_Aggregate)
- loop
- Aggr := Parent (Aggr);
- end loop;
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Analyze (N);
- return Aggr;
- end Top_Level_Aggregate;
+ -- Case where we do not have fewer new discriminants than
+ -- stored discriminants, so in this case we can simply use the
+ -- stored discriminants of the subtype.
- -- Local variables
+ else
+ Prepend_Stored_Values (Typ);
+ end if;
+ end Generate_Aggregate_For_Derived_Type;
+ end if;
- Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
- Tag_Value : Node_Id;
- Comp : Entity_Id;
- New_Comp : Node_Id;
+ if Is_Tagged_Type (Typ) then
- -- Start of processing for Expand_Record_Aggregate
+ -- In the tagged case, _parent and _tag component must be created
- begin
- -- If the aggregate is to be assigned to an atomic/VFA variable, we have
- -- to prevent a piecemeal assignment even if the aggregate is to be
- -- expanded. We create a temporary for the aggregate, and assign the
- -- temporary instead, so that the back end can generate an atomic move
- -- for it.
+ -- Reset Null_Present unconditionally. Tagged records always have
+ -- at least one field (the tag or the parent).
- if Is_Atomic_VFA_Aggregate (N) then
- return;
+ Set_Null_Record_Present (N, False);
- -- No special management required for aggregates used to initialize
- -- statically allocated dispatch tables
+ -- When the current aggregate comes from the expansion of an
+ -- extension aggregate, the parent expr is replaced by an
+ -- aggregate formed by selected components of this expr.
- elsif Is_Static_Dispatch_Table_Aggregate (N) then
- return;
- end if;
+ if Present (Parent_Expr) and then Is_Empty_List (Comps) then
+ Comp := First_Component_Or_Discriminant (Typ);
+ while Present (Comp) loop
- -- Ada 2005 (AI-318-2): We need to convert to assignments if components
- -- are build-in-place function calls. The assignments will each turn
- -- into a build-in-place function call. If components are all static,
- -- we can pass the aggregate to the backend regardless of limitedness.
+ -- Skip all expander-generated components
- -- Extension aggregates, aggregates in extended return statements, and
- -- aggregates for C++ imported types must be expanded.
-
- if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
- if not Nkind_In (Parent (N), N_Object_Declaration,
- N_Component_Association)
- then
- Convert_To_Assignments (N, Typ);
-
- elsif Nkind (N) = N_Extension_Aggregate
- or else Convention (Typ) = Convention_CPP
- then
- Convert_To_Assignments (N, Typ);
-
- elsif not Size_Known_At_Compile_Time (Typ)
- or else Component_Not_OK_For_Backend
- or else not Static_Components
- then
- Convert_To_Assignments (N, Typ);
-
- else
- Set_Compile_Time_Known_Aggregate (N);
- Set_Expansion_Delayed (N, False);
- end if;
-
- -- Gigi doesn't properly handle temporaries of variable size so we
- -- generate it in the front-end
-
- elsif not Size_Known_At_Compile_Time (Typ)
- and then Tagged_Type_Expansion
- then
- Convert_To_Assignments (N, Typ);
-
- -- An aggregate used to initialize a controlled object must be turned
- -- into component assignments as the components themselves may require
- -- finalization actions such as adjustment.
-
- elsif Needs_Finalization (Typ) then
- Convert_To_Assignments (N, Typ);
-
- -- Ada 2005 (AI-287): In case of default initialized components we
- -- convert the aggregate into assignments.
-
- elsif Has_Default_Init_Comps (N) then
- Convert_To_Assignments (N, Typ);
-
- -- Check components
-
- elsif Component_Not_OK_For_Backend then
- Convert_To_Assignments (N, Typ);
-
- -- If an ancestor is private, some components are not inherited and we
- -- cannot expand into a record aggregate.
-
- elsif Has_Visible_Private_Ancestor (Typ) then
- Convert_To_Assignments (N, Typ);
-
- -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
- -- is not able to handle the aggregate for Late_Request.
-
- elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
- Convert_To_Assignments (N, Typ);
-
- -- If the tagged types covers interface types we need to initialize all
- -- hidden components containing pointers to secondary dispatch tables.
-
- elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
- Convert_To_Assignments (N, Typ);
-
- -- If some components are mutable, the size of the aggregate component
- -- may be distinct from the default size of the type component, so
- -- we need to expand to insure that the back-end copies the proper
- -- size of the data. However, if the aggregate is the initial value of
- -- a constant, the target is immutable and might be built statically
- -- if components are appropriate.
-
- elsif Has_Mutable_Components (Typ)
- and then
- (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
- or else not Constant_Present (Parent (Top_Level_Aggr))
- or else not Static_Components)
- then
- Convert_To_Assignments (N, Typ);
-
- -- If the type involved has bit aligned components, then we are not sure
- -- that the back end can handle this case correctly.
-
- elsif Type_May_Have_Bit_Aligned_Components (Typ) then
- Convert_To_Assignments (N, Typ);
-
- -- When generating C, only generate an aggregate when declaring objects
- -- since C does not support aggregates in e.g. assignment statements.
-
- elsif Modify_Tree_For_C and then not In_Object_Declaration (N) then
- Convert_To_Assignments (N, Typ);
-
- -- In all other cases, build a proper aggregate to be handled by gigi
-
- else
- if Nkind (N) = N_Aggregate then
-
- -- If the aggregate is static and can be handled by the back-end,
- -- nothing left to do.
-
- if Static_Components then
- Set_Compile_Time_Known_Aggregate (N);
- Set_Expansion_Delayed (N, False);
- end if;
- end if;
-
- -- If no discriminants, nothing special to do
-
- if not Has_Discriminants (Typ) then
- null;
-
- -- Case of discriminants present
-
- elsif Is_Derived_Type (Typ) then
-
- -- For untagged types, non-stored discriminants are replaced
- -- with stored discriminants, which are the ones that gigi uses
- -- to describe the type and its components.
-
- Generate_Aggregate_For_Derived_Type : declare
- Constraints : constant List_Id := New_List;
- First_Comp : Node_Id;
- Discriminant : Entity_Id;
- Decl : Node_Id;
- Num_Disc : Nat := 0;
- Num_Gird : Nat := 0;
-
- procedure Prepend_Stored_Values (T : Entity_Id);
- -- Scan the list of stored discriminants of the type, and add
- -- their values to the aggregate being built.
-
- ---------------------------
- -- Prepend_Stored_Values --
- ---------------------------
-
- procedure Prepend_Stored_Values (T : Entity_Id) is
- begin
- Discriminant := First_Stored_Discriminant (T);
- while Present (Discriminant) loop
- New_Comp :=
- Make_Component_Association (Loc,
- Choices =>
- New_List (New_Occurrence_Of (Discriminant, Loc)),
-
- Expression =>
- New_Copy_Tree
- (Get_Discriminant_Value
- (Discriminant,
- Typ,
- Discriminant_Constraint (Typ))));
-
- if No (First_Comp) then
- Prepend_To (Component_Associations (N), New_Comp);
- else
- Insert_After (First_Comp, New_Comp);
- end if;
-
- First_Comp := New_Comp;
- Next_Stored_Discriminant (Discriminant);
- end loop;
- end Prepend_Stored_Values;
-
- -- Start of processing for Generate_Aggregate_For_Derived_Type
-
- begin
- -- Remove the associations for the discriminant of derived type
-
- First_Comp := First (Component_Associations (N));
- while Present (First_Comp) loop
- Comp := First_Comp;
- Next (First_Comp);
-
- if Ekind (Entity (First (Choices (Comp)))) = E_Discriminant
- then
- Remove (Comp);
- Num_Disc := Num_Disc + 1;
- end if;
- end loop;
-
- -- Insert stored discriminant associations in the correct
- -- order. If there are more stored discriminants than new
- -- discriminants, there is at least one new discriminant that
- -- constrains more than one of the stored discriminants. In
- -- this case we need to construct a proper subtype of the
- -- parent type, in order to supply values to all the
- -- components. Otherwise there is one-one correspondence
- -- between the constraints and the stored discriminants.
-
- First_Comp := Empty;
-
- Discriminant := First_Stored_Discriminant (Base_Type (Typ));
- while Present (Discriminant) loop
- Num_Gird := Num_Gird + 1;
- Next_Stored_Discriminant (Discriminant);
- end loop;
-
- -- Case of more stored discriminants than new discriminants
-
- if Num_Gird > Num_Disc then
-
- -- Create a proper subtype of the parent type, which is the
- -- proper implementation type for the aggregate, and convert
- -- it to the intended target type.
-
- Discriminant := First_Stored_Discriminant (Base_Type (Typ));
- while Present (Discriminant) loop
- New_Comp :=
- New_Copy_Tree
- (Get_Discriminant_Value
- (Discriminant,
- Typ,
- Discriminant_Constraint (Typ)));
- Append (New_Comp, Constraints);
- Next_Stored_Discriminant (Discriminant);
- end loop;
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'T'),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint
- (Loc, Constraints)));
-
- Insert_Action (N, Decl);
- Prepend_Stored_Values (Base_Type (Typ));
-
- Set_Etype (N, Defining_Identifier (Decl));
- Set_Analyzed (N);
-
- Rewrite (N, Unchecked_Convert_To (Typ, N));
- Analyze (N);
-
- -- Case where we do not have fewer new discriminants than
- -- stored discriminants, so in this case we can simply use the
- -- stored discriminants of the subtype.
-
- else
- Prepend_Stored_Values (Typ);
- end if;
- end Generate_Aggregate_For_Derived_Type;
- end if;
-
- if Is_Tagged_Type (Typ) then
-
- -- In the tagged case, _parent and _tag component must be created
-
- -- Reset Null_Present unconditionally. Tagged records always have
- -- at least one field (the tag or the parent).
-
- Set_Null_Record_Present (N, False);
-
- -- When the current aggregate comes from the expansion of an
- -- extension aggregate, the parent expr is replaced by an
- -- aggregate formed by selected components of this expr.
-
- if Present (Parent_Expr) and then Is_Empty_List (Comps) then
- Comp := First_Component_Or_Discriminant (Typ);
- while Present (Comp) loop
-
- -- Skip all expander-generated components
-
- if not Comes_From_Source (Original_Record_Component (Comp))
- then
- null;
+ if not Comes_From_Source (Original_Record_Component (Comp))
+ then
+ null;
else
New_Comp :=
Append_To (Comps,
Make_Component_Association (Loc,
- Choices =>
- New_List (New_Occurrence_Of (Comp, Loc)),
+ Choices => New_List (
+ New_Occurrence_Of (Comp, Loc)),
Expression => New_Comp));
Analyze_And_Resolve (New_Comp, Etype (Comp));
if Present (Orig_Tag) then
Tag_Value := Orig_Tag;
+
elsif not Tagged_Type_Expansion then
Tag_Value := Empty;
+
else
Tag_Value :=
New_Occurrence_Of
-- all the inherited components.
if Is_Derived_Type (Typ) then
-
declare
First_Comp : Node_Id;
Parent_Comps : List_Id;
-- Remove the inherited component association from the
-- aggregate and store them in the parent aggregate
- First_Comp := First (Component_Associations (N));
+ First_Comp := First (Component_Associations (N));
Parent_Comps := New_List;
while Present (First_Comp)
and then
-- The ancestor part may be a nested aggregate that has
-- delayed expansion: recheck now.
- if Component_Not_OK_For_Backend then
+ if not Component_OK_For_Backend then
Convert_To_Assignments (N, Typ);
end if;
end;
elsif Tagged_Type_Expansion then
declare
Tag_Name : constant Node_Id :=
- New_Occurrence_Of (First_Tag_Component (Typ), Loc);
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Loc);
Typ_Tag : constant Entity_Id := RTE (RE_Tag);
Conv_Node : constant Node_Id :=
- Unchecked_Convert_To (Typ_Tag, Tag_Value);
+ Unchecked_Convert_To (Typ_Tag, Tag_Value);
begin
Set_Etype (Conv_Node, Typ_Tag);
end;
end if;
end if;
- end if;
+ end Build_Back_End_Aggregate;
- end Expand_Record_Aggregate;
+ ----------------------------------------
+ -- Compile_Time_Known_Composite_Value --
+ ----------------------------------------
- ----------------------------
- -- Has_Default_Init_Comps --
- ----------------------------
+ function Compile_Time_Known_Composite_Value
+ (N : Node_Id) return Boolean
+ is
+ begin
+ -- If we have an entity name, then see if it is the name of a
+ -- constant and if so, test the corresponding constant value.
- function Has_Default_Init_Comps (N : Node_Id) return Boolean is
- Comps : constant List_Id := Component_Associations (N);
- C : Node_Id;
- Expr : Node_Id;
+ if Is_Entity_Name (N) then
+ declare
+ E : constant Entity_Id := Entity (N);
+ V : Node_Id;
+ begin
+ if Ekind (E) /= E_Constant then
+ return False;
+ else
+ V := Constant_Value (E);
+ return Present (V)
+ and then Compile_Time_Known_Composite_Value (V);
+ end if;
+ end;
+
+ -- We have a value, see if it is compile time known
+
+ else
+ if Nkind (N) = N_Aggregate then
+ return Compile_Time_Known_Aggregate (N);
+ end if;
+
+ -- All other types of values are not known at compile time
+
+ return False;
+ end if;
+
+ end Compile_Time_Known_Composite_Value;
+
+ ------------------------------
+ -- Component_OK_For_Backend --
+ ------------------------------
+
+ function Component_OK_For_Backend return Boolean is
+ C : Node_Id;
+ Expr_Q : Node_Id;
+
+ begin
+ if No (Comps) then
+ return True;
+ end if;
+
+ C := First (Comps);
+ while Present (C) loop
+
+ -- If the component has box initialization, expansion is needed
+ -- and component is not ready for backend.
+
+ if Box_Present (C) then
+ return False;
+ end if;
+
+ if Nkind (Expression (C)) = N_Qualified_Expression then
+ Expr_Q := Expression (Expression (C));
+ else
+ Expr_Q := Expression (C);
+ end if;
+
+ -- Return False for array components whose bounds raise
+ -- constraint error.
+
+ declare
+ Comp : constant Entity_Id := First (Choices (C));
+ Indx : Node_Id;
+
+ begin
+ if Present (Etype (Comp))
+ and then Is_Array_Type (Etype (Comp))
+ then
+ Indx := First_Index (Etype (Comp));
+ while Present (Indx) loop
+ if Nkind (Type_Low_Bound (Etype (Indx))) =
+ N_Raise_Constraint_Error
+ or else Nkind (Type_High_Bound (Etype (Indx))) =
+ N_Raise_Constraint_Error
+ then
+ return False;
+ end if;
+
+ Indx := Next_Index (Indx);
+ end loop;
+ end if;
+ end;
+
+ -- Return False if the aggregate has any associations for tagged
+ -- components that may require tag adjustment.
+
+ -- These are cases where the source expression may have a tag that
+ -- could differ from the component tag (e.g., can occur for type
+ -- conversions and formal parameters). (Tag adjustment not needed
+ -- if Tagged_Type_Expansion because object tags are implicit in
+ -- the machine.)
+
+ if Is_Tagged_Type (Etype (Expr_Q))
+ and then
+ (Nkind (Expr_Q) = N_Type_Conversion
+ or else
+ (Is_Entity_Name (Expr_Q)
+ and then Is_Formal (Entity (Expr_Q))))
+ and then Tagged_Type_Expansion
+ then
+ Static_Components := False;
+ return False;
+
+ elsif Is_Delayed_Aggregate (Expr_Q) then
+ Static_Components := False;
+ return False;
+
+ elsif Nkind (Expr_Q) = N_Quantified_Expression then
+ Static_Components := False;
+ return False;
+
+ elsif Possible_Bit_Aligned_Component (Expr_Q) then
+ Static_Components := False;
+ return False;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (C) = N_Component_Association
+ and then Has_Per_Object_Constraint (Choices (C))
+ then
+ Static_Components := False;
+ return False;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (Expr_Q) = N_Identifier
+ and then Is_Array_Type (Etype (Expr_Q))
+ then
+ Static_Components := False;
+ return False;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (Expr_Q) = N_Type_Conversion
+ and then Is_Array_Type (Etype (Expr_Q))
+ then
+ Static_Components := False;
+ return False;
+ end if;
+
+ if Is_Elementary_Type (Etype (Expr_Q)) then
+ if not Compile_Time_Known_Value (Expr_Q) then
+ Static_Components := False;
+ end if;
+
+ elsif not Compile_Time_Known_Composite_Value (Expr_Q) then
+ Static_Components := False;
+
+ if Is_Private_Type (Etype (Expr_Q))
+ and then Has_Discriminants (Etype (Expr_Q))
+ then
+ return False;
+ end if;
+ end if;
+
+ Next (C);
+ end loop;
+
+ return True;
+ end Component_OK_For_Backend;
+
+ -------------------------------
+ -- Has_Per_Object_Constraint --
+ -------------------------------
+
+ function Has_Per_Object_Constraint (L : List_Id) return Boolean is
+ N : Node_Id := First (L);
+ begin
+ while Present (N) loop
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Has_Per_Object_Constraint (Entity (N))
+ then
+ return True;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return False;
+ end Has_Per_Object_Constraint;
+
+ -----------------------------------
+ -- Has_Visible_Private_Ancestor --
+ -----------------------------------
+
+ function Has_Visible_Private_Ancestor (Id : E) return Boolean is
+ R : constant Entity_Id := Root_Type (Id);
+ T1 : Entity_Id := Id;
+
+ begin
+ loop
+ if Is_Private_Type (T1) then
+ return True;
+
+ elsif T1 = R then
+ return False;
+
+ else
+ T1 := Etype (T1);
+ end if;
+ end loop;
+ end Has_Visible_Private_Ancestor;
+
+ -------------------------
+ -- Top_Level_Aggregate --
+ -------------------------
+
+ function Top_Level_Aggregate (N : Node_Id) return Node_Id is
+ Aggr : Node_Id;
+
+ begin
+ Aggr := N;
+ while Present (Parent (Aggr))
+ and then Nkind_In (Parent (Aggr), N_Aggregate,
+ N_Component_Association)
+ loop
+ Aggr := Parent (Aggr);
+ end loop;
+
+ return Aggr;
+ end Top_Level_Aggregate;
+
+ -- Local variables
+
+ Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
+
+ -- Start of processing for Expand_Record_Aggregate
+
+ begin
+ -- If the aggregate is to be assigned to an atomic/VFA variable, we have
+ -- to prevent a piecemeal assignment even if the aggregate is to be
+ -- expanded. We create a temporary for the aggregate, and assign the
+ -- temporary instead, so that the back end can generate an atomic move
+ -- for it.
+
+ if Is_Atomic_VFA_Aggregate (N) then
+ return;
+
+ -- No special management required for aggregates used to initialize
+ -- statically allocated dispatch tables
+
+ elsif Is_Static_Dispatch_Table_Aggregate (N) then
+ return;
+ end if;
+
+ -- If the pragma Aggregate_Individually_Assign is set, always convert to
+ -- assignments.
+
+ if Aggregate_Individually_Assign then
+ Convert_To_Assignments (N, Typ);
+
+ -- Ada 2005 (AI-318-2): We need to convert to assignments if components
+ -- are build-in-place function calls. The assignments will each turn
+ -- into a build-in-place function call. If components are all static,
+ -- we can pass the aggregate to the back end regardless of limitedness.
+
+ -- Extension aggregates, aggregates in extended return statements, and
+ -- aggregates for C++ imported types must be expanded.
+
+ elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
+ if not Nkind_In (Parent (N), N_Component_Association,
+ N_Object_Declaration)
+ then
+ Convert_To_Assignments (N, Typ);
+
+ elsif Nkind (N) = N_Extension_Aggregate
+ or else Convention (Typ) = Convention_CPP
+ then
+ Convert_To_Assignments (N, Typ);
+
+ elsif not Size_Known_At_Compile_Time (Typ)
+ or else not Component_OK_For_Backend
+ or else not Static_Components
+ then
+ Convert_To_Assignments (N, Typ);
+
+ -- In all other cases, build a proper aggregate to be handled by
+ -- the back-end
+
+ else
+ Build_Back_End_Aggregate;
+ end if;
+
+ -- Gigi doesn't properly handle temporaries of variable size so we
+ -- generate it in the front-end
+
+ elsif not Size_Known_At_Compile_Time (Typ)
+ and then Tagged_Type_Expansion
+ then
+ Convert_To_Assignments (N, Typ);
+
+ -- An aggregate used to initialize a controlled object must be turned
+ -- into component assignments as the components themselves may require
+ -- finalization actions such as adjustment.
+
+ elsif Needs_Finalization (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- Ada 2005 (AI-287): In case of default initialized components we
+ -- convert the aggregate into assignments.
+
+ elsif Has_Default_Init_Comps (N) then
+ Convert_To_Assignments (N, Typ);
+
+ -- Check components
+
+ elsif not Component_OK_For_Backend then
+ Convert_To_Assignments (N, Typ);
+
+ -- If an ancestor is private, some components are not inherited and we
+ -- cannot expand into a record aggregate.
+
+ elsif Has_Visible_Private_Ancestor (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi
+ -- is not able to handle the aggregate for Late_Request.
+
+ elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- If the tagged types covers interface types we need to initialize all
+ -- hidden components containing pointers to secondary dispatch tables.
+
+ elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- If some components are mutable, the size of the aggregate component
+ -- may be distinct from the default size of the type component, so
+ -- we need to expand to insure that the back-end copies the proper
+ -- size of the data. However, if the aggregate is the initial value of
+ -- a constant, the target is immutable and might be built statically
+ -- if components are appropriate.
+
+ elsif Has_Mutable_Components (Typ)
+ and then
+ (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
+ or else not Constant_Present (Parent (Top_Level_Aggr))
+ or else not Static_Components)
+ then
+ Convert_To_Assignments (N, Typ);
+
+ -- If the type involved has bit aligned components, then we are not sure
+ -- that the back end can handle this case correctly.
+
+ elsif Type_May_Have_Bit_Aligned_Components (Typ) then
+ Convert_To_Assignments (N, Typ);
+
+ -- When generating C, only generate an aggregate when declaring objects
+ -- since C does not support aggregates in e.g. assignment statements.
+
+ elsif Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
+ Convert_To_Assignments (N, Typ);
+
+ -- In all other cases, build a proper aggregate to be handled by gigi
+
+ else
+ Build_Back_End_Aggregate;
+ end if;
+ end Expand_Record_Aggregate;
+
+ ----------------------------
+ -- Has_Default_Init_Comps --
+ ----------------------------
+
+ function Has_Default_Init_Comps (N : Node_Id) return Boolean is
+ Comps : constant List_Id := Component_Associations (N);
+ C : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
+
+ if No (Comps) then
+ return False;
+ end if;
+
+ if Has_Self_Reference (N) then
+ return True;
+ end if;
+
+ -- Check if any direct component has default initialized components
+
+ C := First (Comps);
+ while Present (C) loop
+ if Box_Present (C) then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+
+ -- Recursive call in case of aggregate expression
+
+ C := First (Comps);
+ while Present (C) loop
+ Expr := Expression (C);
+
+ if Present (Expr)
+ and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Has_Default_Init_Comps (Expr)
+ then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+
+ return False;
+ end Has_Default_Init_Comps;
+
+ ----------------------------------------
+ -- Is_Build_In_Place_Aggregate_Return --
+ ----------------------------------------
+
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
+ P : Node_Id := Parent (N);
+
+ begin
+ while Nkind (P) = N_Qualified_Expression loop
+ P := Parent (P);
+ end loop;
+
+ if Nkind (P) = N_Simple_Return_Statement then
+ null;
+
+ elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
+ P := Parent (P);
+
+ else
+ return False;
+ end if;
+
+ return
+ Is_Build_In_Place_Function
+ (Return_Applies_To (Return_Statement_Entity (P)));
+ end Is_Build_In_Place_Aggregate_Return;
+
+ --------------------------
+ -- Is_Delayed_Aggregate --
+ --------------------------
+
+ function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
+ Node : Node_Id := N;
+ Kind : Node_Kind := Nkind (Node);
+
+ begin
+ if Kind = N_Qualified_Expression then
+ Node := Expression (Node);
+ Kind := Nkind (Node);
+ end if;
+
+ if not Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) then
+ return False;
+ else
+ return Expansion_Delayed (Node);
+ end if;
+ end Is_Delayed_Aggregate;
+
+ --------------------------------
+ -- Is_CCG_Supported_Aggregate --
+ --------------------------------
+
+ function Is_CCG_Supported_Aggregate
+ (N : Node_Id) return Boolean
+ is
+ P : Node_Id := Parent (N);
+
+ begin
+ -- Aggregates are not supported for nonstandard rep clauses, since they
+ -- may lead to extra padding fields in CCG.
+
+ if Ekind (Etype (N)) in Record_Kind
+ and then Has_Non_Standard_Rep (Etype (N))
+ then
+ return False;
+ end if;
+
+ while Present (P) and then Nkind (P) = N_Aggregate loop
+ P := Parent (P);
+ end loop;
+
+ -- Check cases where aggregates are supported by the CCG backend
+
+ if Nkind (P) = N_Object_Declaration then
+ declare
+ P_Typ : constant Entity_Id := Etype (Defining_Identifier (P));
+
+ begin
+ if Is_Record_Type (P_Typ) then
+ return True;
+ else
+ return Compile_Time_Known_Bounds (P_Typ);
+ end if;
+ end;
+
+ elsif Nkind (P) = N_Qualified_Expression then
+ if Nkind (Parent (P)) = N_Object_Declaration then
+ declare
+ P_Typ : constant Entity_Id :=
+ Etype (Defining_Identifier (Parent (P)));
+ begin
+ if Is_Record_Type (P_Typ) then
+ return True;
+ else
+ return Compile_Time_Known_Bounds (P_Typ);
+ end if;
+ end;
+
+ elsif Nkind (Parent (P)) = N_Allocator then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_CCG_Supported_Aggregate;
+
+ ----------------------------------------
+ -- Is_Static_Dispatch_Table_Aggregate --
+ ----------------------------------------
+
+ function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Base_Type (Etype (N));
+
+ begin
+ return Building_Static_Dispatch_Tables
+ and then Tagged_Type_Expansion
+ and then RTU_Loaded (Ada_Tags)
+
+ -- Avoid circularity when rebuilding the compiler
+
+ and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
+ and then (Typ = RTE (RE_Dispatch_Table_Wrapper)
+ or else
+ Typ = RTE (RE_Address_Array)
+ or else
+ Typ = RTE (RE_Type_Specific_Data)
+ or else
+ Typ = RTE (RE_Tag_Table)
+ or else
+ (RTE_Available (RE_Interface_Data)
+ and then Typ = RTE (RE_Interface_Data))
+ or else
+ (RTE_Available (RE_Interfaces_Array)
+ and then Typ = RTE (RE_Interfaces_Array))
+ or else
+ (RTE_Available (RE_Interface_Data_Element)
+ and then Typ = RTE (RE_Interface_Data_Element)));
+ end Is_Static_Dispatch_Table_Aggregate;
+
+ -----------------------------
+ -- Is_Two_Dim_Packed_Array --
+ -----------------------------
+
+ function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is
+ C : constant Int := UI_To_Int (Component_Size (Typ));
+ begin
+ return Number_Dimensions (Typ) = 2
+ and then Is_Bit_Packed_Array (Typ)
+ and then (C = 1 or else C = 2 or else C = 4);
+ end Is_Two_Dim_Packed_Array;
+
+ --------------------
+ -- Late_Expansion --
+ --------------------
+
+ function Late_Expansion
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id) return List_Id
+ is
+ Aggr_Code : List_Id;
+
+ begin
+ if Is_Array_Type (Etype (N)) then
+ Aggr_Code :=
+ Build_Array_Aggr_Code
+ (N => N,
+ Ctype => Component_Type (Etype (N)),
+ Index => First_Index (Typ),
+ Into => Target,
+ Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
+ Indexes => No_List);
+
+ -- Directly or indirectly (e.g. access protected procedure) a record
+
+ else
+ Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
+ end if;
+
+ -- Save the last assignment statement associated with the aggregate
+ -- when building a controlled object. This reference is utilized by
+ -- the finalization machinery when marking an object as successfully
+ -- initialized.
+
+ if Needs_Finalization (Typ)
+ and then Is_Entity_Name (Target)
+ and then Present (Entity (Target))
+ and then Ekind_In (Entity (Target), E_Constant, E_Variable)
+ then
+ Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
+ end if;
+
+ return Aggr_Code;
+ end Late_Expansion;
+
+ ----------------------------------
+ -- Make_OK_Assignment_Statement --
+ ----------------------------------
+
+ function Make_OK_Assignment_Statement
+ (Sloc : Source_Ptr;
+ Name : Node_Id;
+ Expression : Node_Id) return Node_Id
+ is
+ begin
+ Set_Assignment_OK (Name);
+ return Make_Assignment_Statement (Sloc, Name, Expression);
+ end Make_OK_Assignment_Statement;
+
+ -----------------------
+ -- Number_Of_Choices --
+ -----------------------
+
+ function Number_Of_Choices (N : Node_Id) return Nat is
+ Assoc : Node_Id;
+ Choice : Node_Id;
+
+ Nb_Choices : Nat := 0;
+
+ begin
+ if Present (Expressions (N)) then
+ return 0;
+ end if;
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) /= N_Others_Choice then
+ Nb_Choices := Nb_Choices + 1;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ return Nb_Choices;
+ end Number_Of_Choices;
+
+ ------------------------------------
+ -- Packed_Array_Aggregate_Handled --
+ ------------------------------------
+
+ -- The current version of this procedure will handle at compile time
+ -- any array aggregate that meets these conditions:
+
+ -- One and two dimensional, bit packed
+ -- Underlying packed type is modular type
+ -- Bounds are within 32-bit Int range
+ -- All bounds and values are static
+
+ -- Note: for now, in the 2-D case, we only handle component sizes of
+ -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
+
+ function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
+
+ Not_Handled : exception;
+ -- Exception raised if this aggregate cannot be handled
+
+ begin
+ -- Handle one- or two dimensional bit packed array
+
+ if not Is_Bit_Packed_Array (Typ)
+ or else Number_Dimensions (Typ) > 2
+ then
+ return False;
+ end if;
+
+ -- If two-dimensional, check whether it can be folded, and transformed
+ -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of
+ -- the original type.
+
+ if Number_Dimensions (Typ) = 2 then
+ return Two_Dim_Packed_Array_Handled (N);
+ end if;
+
+ if not Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) then
+ return False;
+ end if;
+
+ if not Is_Scalar_Type (Ctyp) then
+ return False;
+ end if;
+
+ declare
+ Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
+
+ Lo : Node_Id;
+ Hi : Node_Id;
+ -- Bounds of index type
+
+ Lob : Uint;
+ Hib : Uint;
+ -- Values of bounds if compile time known
+
+ function Get_Component_Val (N : Node_Id) return Uint;
+ -- Given a expression value N of the component type Ctyp, returns a
+ -- value of Csiz (component size) bits representing this value. If
+ -- the value is nonstatic or any other reason exists why the value
+ -- cannot be returned, then Not_Handled is raised.
+
+ -----------------------
+ -- Get_Component_Val --
+ -----------------------
+
+ function Get_Component_Val (N : Node_Id) return Uint is
+ Val : Uint;
+
+ begin
+ -- We have to analyze the expression here before doing any further
+ -- processing here. The analysis of such expressions is deferred
+ -- till expansion to prevent some problems of premature analysis.
+
+ Analyze_And_Resolve (N, Ctyp);
+
+ -- Must have a compile time value. String literals have to be
+ -- converted into temporaries as well, because they cannot easily
+ -- be converted into their bit representation.
+
+ if not Compile_Time_Known_Value (N)
+ or else Nkind (N) = N_String_Literal
+ then
+ raise Not_Handled;
+ end if;
+
+ Val := Expr_Rep_Value (N);
+
+ -- Adjust for bias, and strip proper number of bits
+
+ if Has_Biased_Representation (Ctyp) then
+ Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
+ end if;
+
+ return Val mod Uint_2 ** Csiz;
+ end Get_Component_Val;
+
+ -- Here we know we have a one dimensional bit packed array
+
+ begin
+ Get_Index_Bounds (First_Index (Typ), Lo, Hi);
+
+ -- Cannot do anything if bounds are dynamic
+
+ if not Compile_Time_Known_Value (Lo)
+ or else
+ not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ end if;
+
+ -- Or are silly out of range of int bounds
+
+ Lob := Expr_Value (Lo);
+ Hib := Expr_Value (Hi);
+
+ if not UI_Is_In_Int_Range (Lob)
+ or else
+ not UI_Is_In_Int_Range (Hib)
+ then
+ return False;
+ end if;
+
+ -- At this stage we have a suitable aggregate for handling at compile
+ -- time. The only remaining checks are that the values of expressions
+ -- in the aggregate are compile-time known (checks are performed by
+ -- Get_Component_Val), and that any subtypes or ranges are statically
+ -- known.
+
+ -- If the aggregate is not fully positional at this stage, then
+ -- convert it to positional form. Either this will fail, in which
+ -- case we can do nothing, or it will succeed, in which case we have
+ -- succeeded in handling the aggregate and transforming it into a
+ -- modular value, or it will stay an aggregate, in which case we
+ -- have failed to create a packed value for it.
+
+ if Present (Component_Associations (N)) then
+ Convert_To_Positional
+ (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ return Nkind (N) /= N_Aggregate;
+ end if;
+
+ -- Otherwise we are all positional, so convert to proper value
+
+ declare
+ Lov : constant Int := UI_To_Int (Lob);
+ Hiv : constant Int := UI_To_Int (Hib);
+
+ Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
+ -- The length of the array (number of elements)
+
+ Aggregate_Val : Uint;
+ -- Value of aggregate. The value is set in the low order bits of
+ -- this value. For the little-endian case, the values are stored
+ -- from low-order to high-order and for the big-endian case the
+ -- values are stored from high-order to low-order. Note that gigi
+ -- will take care of the conversions to left justify the value in
+ -- the big endian case (because of left justified modular type
+ -- processing), so we do not have to worry about that here.
+
+ Lit : Node_Id;
+ -- Integer literal for resulting constructed value
+
+ Shift : Nat;
+ -- Shift count from low order for next value
+
+ Incr : Int;
+ -- Shift increment for loop
+
+ Expr : Node_Id;
+ -- Next expression from positional parameters of aggregate
+
+ Left_Justified : Boolean;
+ -- Set True if we are filling the high order bits of the target
+ -- value (i.e. the value is left justified).
+
+ begin
+ -- For little endian, we fill up the low order bits of the target
+ -- value. For big endian we fill up the high order bits of the
+ -- target value (which is a left justified modular value).
+
+ Left_Justified := Bytes_Big_Endian;
+
+ -- Switch justification if using -gnatd8
+
+ if Debug_Flag_8 then
+ Left_Justified := not Left_Justified;
+ end if;
+
+ -- Switch justfification if reverse storage order
+
+ if Reverse_Storage_Order (Base_Type (Typ)) then
+ Left_Justified := not Left_Justified;
+ end if;
+
+ if Left_Justified then
+ Shift := Csiz * (Len - 1);
+ Incr := -Csiz;
+ else
+ Shift := 0;
+ Incr := +Csiz;
+ end if;
+
+ -- Loop to set the values
+
+ if Len = 0 then
+ Aggregate_Val := Uint_0;
+ else
+ Expr := First (Expressions (N));
+ Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
+
+ for J in 2 .. Len loop
+ Shift := Shift + Incr;
+ Next (Expr);
+ Aggregate_Val :=
+ Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
+ end loop;
+ end if;
- begin
- pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
+ -- Now we can rewrite with the proper value
- if No (Comps) then
- return False;
- end if;
+ Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
+ Set_Print_In_Hex (Lit);
- if Has_Self_Reference (N) then
- return True;
- end if;
+ -- Construct the expression using this literal. Note that it is
+ -- important to qualify the literal with its proper modular type
+ -- since universal integer does not have the required range and
+ -- also this is a left justified modular type, which is important
+ -- in the big-endian case.
- -- Check if any direct component has default initialized components
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
+ Expression => Lit)));
- C := First (Comps);
- while Present (C) loop
- if Box_Present (C) then
+ Analyze_And_Resolve (N, Typ);
return True;
- end if;
+ end;
+ end;
- Next (C);
- end loop;
+ exception
+ when Not_Handled =>
+ return False;
+ end Packed_Array_Aggregate_Handled;
- -- Recursive call in case of aggregate expression
+ ----------------------------
+ -- Has_Mutable_Components --
+ ----------------------------
- C := First (Comps);
- while Present (C) loop
- Expr := Expression (C);
+ function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Ctyp : Entity_Id;
- if Present (Expr)
- and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
- and then Has_Default_Init_Comps (Expr)
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ Ctyp := Underlying_Type (Etype (Comp));
+ if Is_Record_Type (Ctyp)
+ and then Has_Discriminants (Ctyp)
+ and then not Is_Constrained (Ctyp)
then
return True;
end if;
- Next (C);
+ Next_Component (Comp);
end loop;
return False;
- end Has_Default_Init_Comps;
+ end Has_Mutable_Components;
- --------------------------
- -- Is_Delayed_Aggregate --
- --------------------------
+ ------------------------------
+ -- Initialize_Discriminants --
+ ------------------------------
- function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
- Node : Node_Id := N;
- Kind : Node_Kind := Nkind (Node);
+ procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Bas : constant Entity_Id := Base_Type (Typ);
+ Par : constant Entity_Id := Etype (Bas);
+ Decl : constant Node_Id := Parent (Par);
+ Ref : Node_Id;
begin
- if Kind = N_Qualified_Expression then
- Node := Expression (Node);
- Kind := Nkind (Node);
+ if Is_Tagged_Type (Bas)
+ and then Is_Derived_Type (Bas)
+ and then Has_Discriminants (Par)
+ and then Has_Discriminants (Bas)
+ and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
+ and then Nkind (Decl) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then
+ Present (Variant_Part (Component_List (Type_Definition (Decl))))
+ and then Nkind (N) /= N_Extension_Aggregate
+ then
+
+ -- Call init proc to set discriminants.
+ -- There should eventually be a special procedure for this ???
+
+ Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
+ Insert_Actions_After (N,
+ Build_Initialization_Call (Sloc (N), Ref, Typ));
end if;
+ end Initialize_Discriminants;
- if not Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) then
+ ----------------
+ -- Must_Slide --
+ ----------------
+
+ function Must_Slide
+ (Obj_Type : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ L1, L2, H1, H2 : Node_Id;
+
+ begin
+ -- No sliding if the type of the object is not established yet, if it is
+ -- an unconstrained type whose actual subtype comes from the aggregate,
+ -- or if the two types are identical.
+
+ if not Is_Array_Type (Obj_Type) then
+ return False;
+
+ elsif not Is_Constrained (Obj_Type) then
+ return False;
+
+ elsif Typ = Obj_Type then
return False;
+
else
- return Expansion_Delayed (Node);
- end if;
- end Is_Delayed_Aggregate;
+ -- Sliding can only occur along the first dimension
- ---------------------------
- -- In_Object_Declaration --
- ---------------------------
+ Get_Index_Bounds (First_Index (Typ), L1, H1);
+ Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
- function In_Object_Declaration (N : Node_Id) return Boolean is
- P : Node_Id := Parent (N);
- begin
- while Present (P) loop
- if Nkind (P) = N_Object_Declaration then
- return True;
+ if not Is_OK_Static_Expression (L1) or else
+ not Is_OK_Static_Expression (L2) or else
+ not Is_OK_Static_Expression (H1) or else
+ not Is_OK_Static_Expression (H2)
+ then
+ return False;
+ else
+ return Expr_Value (L1) /= Expr_Value (L2)
+ or else
+ Expr_Value (H1) /= Expr_Value (H2);
end if;
+ end if;
+ end Must_Slide;
- P := Parent (P);
- end loop;
+ ---------------------------------
+ -- Process_Transient_Component --
+ ---------------------------------
- return False;
- end In_Object_Declaration;
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List)
+ is
+ procedure Add_Item (Item : Node_Id);
+ -- Insert arbitrary node Item into the tree depending on the values of
+ -- Aggr and Stmts.
- ----------------------------------------
- -- Is_Static_Dispatch_Table_Aggregate --
- ----------------------------------------
+ --------------
+ -- Add_Item --
+ --------------
- function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is
- Typ : constant Entity_Id := Base_Type (Etype (N));
+ procedure Add_Item (Item : Node_Id) is
+ begin
+ if Present (Aggr) then
+ Insert_Action (Aggr, Item);
+ else
+ pragma Assert (Present (Stmts));
+ Append_To (Stmts, Item);
+ end if;
+ end Add_Item;
+
+ -- Local variables
+
+ Hook_Assign : Node_Id;
+ Hook_Decl : Node_Id;
+ Ptr_Decl : Node_Id;
+ Res_Decl : Node_Id;
+ Res_Id : Entity_Id;
+ Res_Typ : Entity_Id;
+
+ -- Start of processing for Process_Transient_Component
begin
- return Static_Dispatch_Tables
- and then Tagged_Type_Expansion
- and then RTU_Loaded (Ada_Tags)
+ -- Add the access type, which provides a reference to the function
+ -- result. Generate:
- -- Avoid circularity when rebuilding the compiler
+ -- type Res_Typ is access all Comp_Typ;
- and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
- and then (Typ = RTE (RE_Dispatch_Table_Wrapper)
- or else
- Typ = RTE (RE_Address_Array)
- or else
- Typ = RTE (RE_Type_Specific_Data)
- or else
- Typ = RTE (RE_Tag_Table)
- or else
- (RTE_Available (RE_Interface_Data)
- and then Typ = RTE (RE_Interface_Data))
- or else
- (RTE_Available (RE_Interfaces_Array)
- and then Typ = RTE (RE_Interfaces_Array))
- or else
- (RTE_Available (RE_Interface_Data_Element)
- and then Typ = RTE (RE_Interface_Data_Element)));
- end Is_Static_Dispatch_Table_Aggregate;
+ Res_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Res_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
- -----------------------------
- -- Is_Two_Dim_Packed_Array --
- -----------------------------
+ Add_Item
+ (Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Res_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
- function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is
- C : constant Int := UI_To_Int (Component_Size (Typ));
- begin
- return Number_Dimensions (Typ) = 2
- and then Is_Bit_Packed_Array (Typ)
- and then (C = 1 or else C = 2 or else C = 4);
- end Is_Two_Dim_Packed_Array;
+ -- Add the temporary which captures the result of the function call.
+ -- Generate:
- --------------------
- -- Late_Expansion --
- --------------------
+ -- Res : constant Res_Typ := Init_Expr'Reference;
- function Late_Expansion
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id) return List_Id
- is
- Aggr_Code : List_Id;
+ -- Note that this temporary is effectively a transient object because
+ -- its lifetime is bounded by the current array or record component.
- begin
- if Is_Array_Type (Etype (N)) then
- Aggr_Code :=
- Build_Array_Aggr_Code
- (N => N,
- Ctype => Component_Type (Etype (N)),
- Index => First_Index (Typ),
- Into => Target,
- Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
- Indexes => No_List);
+ Res_Id := Make_Temporary (Loc, 'R');
+ Set_Ekind (Res_Id, E_Constant);
+ Set_Etype (Res_Id, Res_Typ);
- -- Directly or indirectly (e.g. access protected procedure) a record
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- else
- Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
- end if;
+ Set_Is_Finalized_Transient (Res_Id);
- -- Save the last assignment statement associated with the aggregate
- -- when building a controlled object. This reference is utilized by
- -- the finalization machinery when marking an object as successfully
- -- initialized.
+ -- Signal the general finalization machinery that this transient object
+ -- should not be considered for finalization actions because its cleanup
+ -- will be performed by Process_Transient_Component_Completion.
- if Needs_Finalization (Typ)
- and then Is_Entity_Name (Target)
- and then Present (Entity (Target))
- and then Ekind_In (Entity (Target), E_Constant, E_Variable)
- then
- Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
- end if;
+ Set_Is_Ignored_Transient (Res_Id);
- return Aggr_Code;
- end Late_Expansion;
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Res_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Res_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, New_Copy_Tree (Init_Expr)));
- ----------------------------------
- -- Make_OK_Assignment_Statement --
- ----------------------------------
+ Add_Item (Res_Decl);
- function Make_OK_Assignment_Statement
- (Sloc : Source_Ptr;
- Name : Node_Id;
- Expression : Node_Id) return Node_Id
- is
- begin
- Set_Assignment_OK (Name);
- return Make_Assignment_Statement (Sloc, Name, Expression);
- end Make_OK_Assignment_Statement;
+ -- Construct all pieces necessary to hook and finalize the transient
+ -- result.
- -----------------------
- -- Number_Of_Choices --
- -----------------------
+ Build_Transient_Object_Statements
+ (Obj_Decl => Res_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
- function Number_Of_Choices (N : Node_Id) return Nat is
- Assoc : Node_Id;
- Choice : Node_Id;
+ -- Add the access type which provides a reference to the transient
+ -- result. Generate:
- Nb_Choices : Nat := 0;
+ -- type Ptr_Typ is access all Comp_Typ;
- begin
- if Present (Expressions (N)) then
- return 0;
- end if;
+ Add_Item (Ptr_Decl);
- Assoc := First (Component_Associations (N));
- while Present (Assoc) loop
- Choice := First (Choices (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) /= N_Others_Choice then
- Nb_Choices := Nb_Choices + 1;
- end if;
+ -- Add the temporary which acts as a hook to the transient result.
+ -- Generate:
- Next (Choice);
- end loop;
+ -- Hook : Ptr_Typ := null;
- Next (Assoc);
- end loop;
+ Add_Item (Hook_Decl);
- return Nb_Choices;
- end Number_Of_Choices;
+ -- Attach the transient result to the hook. Generate:
- ------------------------------------
- -- Packed_Array_Aggregate_Handled --
- ------------------------------------
+ -- Hook := Ptr_Typ (Res);
- -- The current version of this procedure will handle at compile time
- -- any array aggregate that meets these conditions:
+ Add_Item (Hook_Assign);
- -- One and two dimensional, bit packed
- -- Underlying packed type is modular type
- -- Bounds are within 32-bit Int range
- -- All bounds and values are static
+ -- The original initialization expression now references the value of
+ -- the temporary function result. Generate:
- -- Note: for now, in the 2-D case, we only handle component sizes of
- -- 1, 2, 4 (cases where an integral number of elements occupies a byte).
+ -- Res.all
- function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
+ Rewrite (Init_Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Res_Id, Loc)));
+ end Process_Transient_Component;
- Not_Handled : exception;
- -- Exception raised if this aggregate cannot be handled
+ --------------------------------------------
+ -- Process_Transient_Component_Completion --
+ --------------------------------------------
- begin
- -- Handle one- or two dimensional bit packed array
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
- if not Is_Bit_Packed_Array (Typ)
- or else Number_Dimensions (Typ) > 2
- then
- return False;
- end if;
+ begin
+ pragma Assert (Present (Hook_Clear));
- -- If two-dimensional, check whether it can be folded, and transformed
- -- into a one-dimensional aggregate for the Packed_Array_Impl_Type of
- -- the original type.
+ -- Generate the following code if exception propagation is allowed:
- if Number_Dimensions (Typ) = 2 then
- return Two_Dim_Packed_Array_Handled (N);
- end if;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- if not Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)) then
- return False;
- end if;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- if not Is_Scalar_Type (Component_Type (Typ))
- and then Has_Non_Standard_Rep (Component_Type (Typ))
- then
- return False;
- end if;
+ -- begin
+ -- [Abort_Defer;]
- declare
- Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
+ -- begin
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
- Lo : Node_Id;
- Hi : Node_Id;
- -- Bounds of index type
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Curent_Excep.all.all);
+ -- end if;
+ -- end;
- Lob : Uint;
- Hib : Uint;
- -- Values of bounds if compile time known
+ -- [Abort_Undefer;]
- function Get_Component_Val (N : Node_Id) return Uint;
- -- Given a expression value N of the component type Ctyp, returns a
- -- value of Csiz (component size) bits representing this value. If
- -- the value is non-static or any other reason exists why the value
- -- cannot be returned, then Not_Handled is raised.
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- -----------------------
- -- Get_Component_Val --
- -----------------------
+ if Exceptions_OK then
+ Abort_And_Exception : declare
+ Blk_Decls : constant List_Id := New_List;
+ Blk_Stmts : constant List_Id := New_List;
+ Fin_Stmts : constant List_Id := New_List;
- function Get_Component_Val (N : Node_Id) return Uint is
- Val : Uint;
+ Fin_Data : Finalization_Exception_Data;
begin
- -- We have to analyze the expression here before doing any further
- -- processing here. The analysis of such expressions is deferred
- -- till expansion to prevent some problems of premature analysis.
+ -- Create the declarations of the two flags and the exception
+ -- occurrence.
- Analyze_And_Resolve (N, Ctyp);
+ Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
- -- Must have a compile time value. String literals have to be
- -- converted into temporaries as well, because they cannot easily
- -- be converted into their bit representation.
+ -- Generate:
+ -- Abort_Defer;
- if not Compile_Time_Known_Value (N)
- or else Nkind (N) = N_String_Literal
- then
- raise Not_Handled;
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Defer));
end if;
- Val := Expr_Rep_Value (N);
+ -- Wrap the hook clear and the finalization call in order to trap
+ -- a potential exception.
- -- Adjust for bias, and strip proper number of bits
+ Append_To (Fin_Stmts, Hook_Clear);
- if Has_Biased_Representation (Ctyp) then
- Val := Val - Expr_Value (Type_Low_Bound (Ctyp));
+ if Present (Fin_Call) then
+ Append_To (Fin_Stmts, Fin_Call);
end if;
- return Val mod Uint_2 ** Csiz;
- end Get_Component_Val;
+ Append_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts,
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data)))));
- -- Here we know we have a one dimensional bit packed array
+ -- Generate:
+ -- Abort_Undefer;
- begin
- Get_Index_Bounds (First_Index (Typ), Lo, Hi);
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
- -- Cannot do anything if bounds are dynamic
+ -- Reraise the potential exception with a proper "upgrade" to
+ -- Program_Error if needed.
- if not Compile_Time_Known_Value (Lo)
- or else
- not Compile_Time_Known_Value (Hi)
- then
- return False;
- end if;
+ Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
- -- Or are silly out of range of int bounds
+ -- Wrap everything in a block
- Lob := Expr_Value (Lo);
- Hib := Expr_Value (Hi);
+ Append_To (Stmts,
+ Make_Block_Statement (Loc,
+ Declarations => Blk_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts)));
+ end Abort_And_Exception;
- if not UI_Is_In_Int_Range (Lob)
- or else
- not UI_Is_In_Int_Range (Hib)
- then
- return False;
- end if;
+ -- Generate the following code if exception propagation is not allowed
+ -- and aborts are allowed:
- -- At this stage we have a suitable aggregate for handling at compile
- -- time. The only remaining checks are that the values of expressions
- -- in the aggregate are compile-time known (checks are performed by
- -- Get_Component_Val), and that any subtypes or ranges are statically
- -- known.
+ -- begin
+ -- Abort_Defer;
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
- -- If the aggregate is not fully positional at this stage, then
- -- convert it to positional form. Either this will fail, in which
- -- case we can do nothing, or it will succeed, in which case we have
- -- succeeded in handling the aggregate and transforming it into a
- -- modular value, or it will stay an aggregate, in which case we
- -- have failed to create a packed value for it.
+ elsif Abort_Allowed then
+ Abort_Only : declare
+ Blk_Stmts : constant List_Id := New_List;
- if Present (Component_Associations (N)) then
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
- return Nkind (N) /= N_Aggregate;
- end if;
+ begin
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ Append_To (Blk_Stmts, Hook_Clear);
- -- Otherwise we are all positional, so convert to proper value
+ if Present (Fin_Call) then
+ Append_To (Blk_Stmts, Fin_Call);
+ end if;
- declare
- Lov : constant Int := UI_To_Int (Lob);
- Hiv : constant Int := UI_To_Int (Hib);
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => Aggr));
+ end Abort_Only;
- Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
- -- The length of the array (number of elements)
+ -- Otherwise generate:
- Aggregate_Val : Uint;
- -- Value of aggregate. The value is set in the low order bits of
- -- this value. For the little-endian case, the values are stored
- -- from low-order to high-order and for the big-endian case the
- -- values are stored from high-order to low-order. Note that gigi
- -- will take care of the conversions to left justify the value in
- -- the big endian case (because of left justified modular type
- -- processing), so we do not have to worry about that here.
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
- Lit : Node_Id;
- -- Integer literal for resulting constructed value
+ else
+ Append_To (Stmts, Hook_Clear);
- Shift : Nat;
- -- Shift count from low order for next value
+ if Present (Fin_Call) then
+ Append_To (Stmts, Fin_Call);
+ end if;
+ end if;
+ end Process_Transient_Component_Completion;
- Incr : Int;
- -- Shift increment for loop
+ ---------------------
+ -- Sort_Case_Table --
+ ---------------------
- Expr : Node_Id;
- -- Next expression from positional parameters of aggregate
+ procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
+ L : constant Int := Case_Table'First;
+ U : constant Int := Case_Table'Last;
+ K : Int;
+ J : Int;
+ T : Case_Bounds;
- Left_Justified : Boolean;
- -- Set True if we are filling the high order bits of the target
- -- value (i.e. the value is left justified).
+ begin
+ K := L;
+ while K /= U loop
+ T := Case_Table (K + 1);
- begin
- -- For little endian, we fill up the low order bits of the target
- -- value. For big endian we fill up the high order bits of the
- -- target value (which is a left justified modular value).
+ J := K + 1;
+ while J /= L
+ and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
+ Expr_Value (T.Choice_Lo)
+ loop
+ Case_Table (J) := Case_Table (J - 1);
+ J := J - 1;
+ end loop;
- Left_Justified := Bytes_Big_Endian;
+ Case_Table (J) := T;
+ K := K + 1;
+ end loop;
+ end Sort_Case_Table;
- -- Switch justification if using -gnatd8
+ ----------------------------
+ -- Static_Array_Aggregate --
+ ----------------------------
- if Debug_Flag_8 then
- Left_Justified := not Left_Justified;
- end if;
+ function Static_Array_Aggregate (N : Node_Id) return Boolean is
+ function Is_Static_Component (Nod : Node_Id) return Boolean;
+ -- Return True if Nod has a compile-time known value and can be passed
+ -- as is to the back-end without further expansion.
- -- Switch justfification if reverse storage order
+ ---------------------------
+ -- Is_Static_Component --
+ ---------------------------
- if Reverse_Storage_Order (Base_Type (Typ)) then
- Left_Justified := not Left_Justified;
- end if;
+ function Is_Static_Component (Nod : Node_Id) return Boolean is
+ begin
+ if Nkind_In (Nod, N_Integer_Literal, N_Real_Literal) then
+ return True;
- if Left_Justified then
- Shift := Csiz * (Len - 1);
- Incr := -Csiz;
- else
- Shift := 0;
- Incr := +Csiz;
- end if;
+ elsif Is_Entity_Name (Nod)
+ and then Present (Entity (Nod))
+ and then Ekind (Entity (Nod)) = E_Enumeration_Literal
+ then
+ return True;
- -- Loop to set the values
+ elsif Nkind (Nod) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (Nod)
+ then
+ return True;
- if Len = 0 then
- Aggregate_Val := Uint_0;
- else
- Expr := First (Expressions (N));
- Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
+ else
+ return False;
+ end if;
+ end Is_Static_Component;
- for J in 2 .. Len loop
- Shift := Shift + Incr;
- Next (Expr);
- Aggregate_Val :=
- Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
- end loop;
- end if;
+ -- Local variables
- -- Now we can rewrite with the proper value
+ Bounds : constant Node_Id := Aggregate_Bounds (N);
+ Typ : constant Entity_Id := Etype (N);
- Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
- Set_Print_In_Hex (Lit);
+ Agg : Node_Id;
+ Expr : Node_Id;
+ Lo : Node_Id;
+ Hi : Node_Id;
- -- Construct the expression using this literal. Note that it is
- -- important to qualify the literal with its proper modular type
- -- since universal integer does not have the required range and
- -- also this is a left justified modular type, which is important
- -- in the big-endian case.
+ -- Start of processing for Static_Array_Aggregate
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
- Expression => Lit)));
+ begin
+ if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then
+ return False;
+ end if;
- Analyze_And_Resolve (N, Typ);
- return True;
- end;
- end;
+ if Present (Bounds)
+ and then Nkind (Bounds) = N_Range
+ and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
+ and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
+ then
+ Lo := Low_Bound (Bounds);
+ Hi := High_Bound (Bounds);
+
+ if No (Component_Associations (N)) then
- exception
- when Not_Handled =>
- return False;
- end Packed_Array_Aggregate_Handled;
+ -- Verify that all components are static
- ----------------------------
- -- Has_Mutable_Components --
- ----------------------------
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ if not Is_Static_Component (Expr) then
+ return False;
+ end if;
- function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
- Comp : Entity_Id;
+ Next (Expr);
+ end loop;
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Is_Record_Type (Etype (Comp))
- and then Has_Discriminants (Etype (Comp))
- and then not Is_Constrained (Etype (Comp))
- then
return True;
- end if;
- Next_Component (Comp);
- end loop;
-
- return False;
- end Has_Mutable_Components;
+ else
+ -- We allow only a single named association, either a static
+ -- range or an others_clause, with a static expression.
- ------------------------------
- -- Initialize_Discriminants --
- ------------------------------
+ Expr := First (Component_Associations (N));
- procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Bas : constant Entity_Id := Base_Type (Typ);
- Par : constant Entity_Id := Etype (Bas);
- Decl : constant Node_Id := Parent (Par);
- Ref : Node_Id;
+ if Present (Expressions (N)) then
+ return False;
- begin
- if Is_Tagged_Type (Bas)
- and then Is_Derived_Type (Bas)
- and then Has_Discriminants (Par)
- and then Has_Discriminants (Bas)
- and then Number_Discriminants (Bas) /= Number_Discriminants (Par)
- and then Nkind (Decl) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Decl)) = N_Record_Definition
- and then
- Present (Variant_Part (Component_List (Type_Definition (Decl))))
- and then Nkind (N) /= N_Extension_Aggregate
- then
+ elsif Present (Next (Expr)) then
+ return False;
- -- Call init proc to set discriminants.
- -- There should eventually be a special procedure for this ???
+ elsif Present (Next (First (Choice_List (Expr)))) then
+ return False;
- Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
- Insert_Actions_After (N,
- Build_Initialization_Call (Sloc (N), Ref, Typ));
- end if;
- end Initialize_Discriminants;
+ else
+ -- The aggregate is static if all components are literals,
+ -- or else all its components are static aggregates for the
+ -- component type. We also limit the size of a static aggregate
+ -- to prevent runaway static expressions.
- ----------------
- -- Must_Slide --
- ----------------
+ if not Is_Static_Component (Expression (Expr)) then
+ return False;
+ end if;
- function Must_Slide
- (Obj_Type : Entity_Id;
- Typ : Entity_Id) return Boolean
- is
- L1, L2, H1, H2 : Node_Id;
+ if not Aggr_Size_OK (N, Typ) then
+ return False;
+ end if;
- begin
- -- No sliding if the type of the object is not established yet, if it is
- -- an unconstrained type whose actual subtype comes from the aggregate,
- -- or if the two types are identical.
+ -- Create a positional aggregate with the right number of
+ -- copies of the expression.
- if not Is_Array_Type (Obj_Type) then
- return False;
+ Agg := Make_Aggregate (Sloc (N), New_List, No_List);
- elsif not Is_Constrained (Obj_Type) then
- return False;
+ for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
+ loop
+ Append_To (Expressions (Agg), New_Copy (Expression (Expr)));
- elsif Typ = Obj_Type then
- return False;
+ -- The copied expression must be analyzed and resolved.
+ -- Besides setting the type, this ensures that static
+ -- expressions are appropriately marked as such.
- else
- -- Sliding can only occur along the first dimension
+ Analyze_And_Resolve
+ (Last (Expressions (Agg)), Component_Type (Typ));
+ end loop;
- Get_Index_Bounds (First_Index (Typ), L1, H1);
- Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
+ Set_Aggregate_Bounds (Agg, Bounds);
+ Set_Etype (Agg, Typ);
+ Set_Analyzed (Agg);
+ Rewrite (N, Agg);
+ Set_Compile_Time_Known_Aggregate (N);
- if not Is_OK_Static_Expression (L1) or else
- not Is_OK_Static_Expression (L2) or else
- not Is_OK_Static_Expression (H1) or else
- not Is_OK_Static_Expression (H2)
- then
- return False;
- else
- return Expr_Value (L1) /= Expr_Value (L2)
- or else
- Expr_Value (H1) /= Expr_Value (H2);
+ return True;
+ end if;
end if;
+
+ else
+ return False;
end if;
- end Must_Slide;
+ end Static_Array_Aggregate;
----------------------------------
-- Two_Dim_Packed_Array_Handled --
then
null;
- -- The aggregate may have been re-analyzed and converted already
+ -- The aggregate may have been reanalyzed and converted already
elsif Nkind (N) /= N_Aggregate then
return True;
-- Assembled list of packed values for equivalent aggregate
Comp_Val : Uint;
- -- integer value of component
+ -- Integer value of component
Incr : Int;
-- Step size for packing
-- Current insertion position
Val : Int;
- -- Component of packed array being assembled.
+ -- Component of packed array being assembled
begin
Comps := New_List;
Val := 0;
Packed_Num := 0;
- -- Account for endianness. See corresponding comment in
+ -- Account for endianness. See corresponding comment in
-- Packed_Array_Aggregate_Handled concerning the following.
if Bytes_Big_Endian
end;
end Two_Dim_Packed_Array_Handled;
- ---------------------
- -- Sort_Case_Table --
- ---------------------
-
- procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
- L : constant Int := Case_Table'First;
- U : constant Int := Case_Table'Last;
- K : Int;
- J : Int;
- T : Case_Bounds;
-
- begin
- K := L;
- while K /= U loop
- T := Case_Table (K + 1);
-
- J := K + 1;
- while J /= L
- and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
- Expr_Value (T.Choice_Lo)
- loop
- Case_Table (J) := Case_Table (J - 1);
- J := J - 1;
- end loop;
-
- Case_Table (J) := T;
- K := K + 1;
- end loop;
- end Sort_Case_Table;
-
- ----------------------------
- -- Static_Array_Aggregate --
- ----------------------------
-
- function Static_Array_Aggregate (N : Node_Id) return Boolean is
- Bounds : constant Node_Id := Aggregate_Bounds (N);
-
- Typ : constant Entity_Id := Etype (N);
- Comp_Type : constant Entity_Id := Component_Type (Typ);
- Agg : Node_Id;
- Expr : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id;
-
- begin
- if Is_Tagged_Type (Typ)
- or else Is_Controlled (Typ)
- or else Is_Packed (Typ)
- then
- return False;
- end if;
-
- if Present (Bounds)
- and then Nkind (Bounds) = N_Range
- and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
- and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
- then
- Lo := Low_Bound (Bounds);
- Hi := High_Bound (Bounds);
-
- if No (Component_Associations (N)) then
-
- -- Verify that all components are static integers
-
- Expr := First (Expressions (N));
- while Present (Expr) loop
- if Nkind (Expr) /= N_Integer_Literal then
- return False;
- end if;
-
- Next (Expr);
- end loop;
-
- return True;
-
- else
- -- We allow only a single named association, either a static
- -- range or an others_clause, with a static expression.
-
- Expr := First (Component_Associations (N));
-
- if Present (Expressions (N)) then
- return False;
-
- elsif Present (Next (Expr)) then
- return False;
-
- elsif Present (Next (First (Choices (Expr)))) then
- return False;
-
- else
- -- The aggregate is static if all components are literals,
- -- or else all its components are static aggregates for the
- -- component type. We also limit the size of a static aggregate
- -- to prevent runaway static expressions.
-
- if Is_Array_Type (Comp_Type)
- or else Is_Record_Type (Comp_Type)
- then
- if Nkind (Expression (Expr)) /= N_Aggregate
- or else
- not Compile_Time_Known_Aggregate (Expression (Expr))
- then
- return False;
- end if;
-
- elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
- return False;
- end if;
-
- if not Aggr_Size_OK (N, Typ) then
- return False;
- end if;
-
- -- Create a positional aggregate with the right number of
- -- copies of the expression.
-
- Agg := Make_Aggregate (Sloc (N), New_List, No_List);
-
- for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
- loop
- Append_To (Expressions (Agg), New_Copy (Expression (Expr)));
-
- -- The copied expression must be analyzed and resolved.
- -- Besides setting the type, this ensures that static
- -- expressions are appropriately marked as such.
-
- Analyze_And_Resolve
- (Last (Expressions (Agg)), Component_Type (Typ));
- end loop;
-
- Set_Aggregate_Bounds (Agg, Bounds);
- Set_Etype (Agg, Typ);
- Set_Analyzed (Agg);
- Rewrite (N, Agg);
- Set_Compile_Time_Known_Aggregate (N);
-
- return True;
- end if;
- end if;
-
- else
- return False;
- end if;
- end Static_Array_Aggregate;
-
end Exp_Aggr;
projects / thirdparty / gcc.git / blobdiff