2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+ * einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
+ is now used as Is_Ignored_Transient.
+ (Is_Finalized_Transient): New routine.
+ (Is_Ignored_Transient): New routine.
+ (Is_Processed_Transient): Removed.
+ (Set_Is_Finalized_Transient): New routine.
+ (Set_Is_Ignored_Transient): New routine.
+ (Set_Is_Processed_Transient): Removed.
+ (Write_Entity_Flags): Output Flag252 and Flag295.
+ * einfo.ads: New attributes Is_Finalized_Transient
+ and Is_Ignored_Transient along with occurrences in
+ entities. Remove attribute Is_Processed_Transient.
+ (Is_Finalized_Transient): New routine along with pragma Inline.
+ (Is_Ignored_Transient): New routine along with pragma Inline.
+ (Is_Processed_Transient): Removed along with pragma Inline.
+ (Set_Is_Finalized_Transient): New routine along with pragma Inline.
+ (Set_Is_Ignored_Transient): New routine along with pragma Inline.
+ (Set_Is_Processed_Transient): Removed along with pragma Inline.
+ * exp_aggr.adb Add with and use clauses for Exp_Ch11 and Inline.
+ (Build_Record_Aggr_Code): Change the handling
+ of controlled record components.
+ (Ctrl_Init_Expression): Removed.
+ (Gen_Assign): Add new formal parameter In_Loop
+ along with comment on usage. Remove local variables Stmt and
+ Stmt_Expr. Change the handling of controlled array components.
+ (Gen_Loop): Update the call to Gen_Assign.
+ (Gen_While): Update the call to Gen_Assign.
+ (Initialize_Array_Component): New routine.
+ (Initialize_Ctrl_Array_Component): New routine.
+ (Initialize_Ctrl_Record_Component): New routine.
+ (Initialize_Record_Component): New routine.
+ (Process_Transient_Component): New routine.
+ (Process_Transient_Component_Completion): New routine.
+ * exp_ch4.adb (Process_Transient_In_Expression): New routine.
+ (Process_Transient_Object): Removed. Replace all existing calls
+ to this routine with calls to Process_Transient_In_Expression.
+ * exp_ch6.adb (Expand_Ctrl_Function_Call): Remove local constant
+ Is_Elem_Ref. Update the comment on ignoring transients.
+ * exp_ch7.adb (Process_Declarations): Do not process ignored
+ or finalized transient objects.
+ (Process_Transient_In_Scope): New routine.
+ (Process_Transients_In_Scope): New routine.
+ (Process_Transient_Objects): Removed. Replace all existing calls
+ to this routine with calls to Process_Transients_In_Scope.
+ * exp_util.adb (Build_Transient_Object_Statements): New routine.
+ (Is_Finalizable_Transient): Do not consider a transient object
+ which has been finalized.
+ (Requires_Cleanup_Actions): Do not consider ignored or finalized
+ transient objects.
+ * exp_util.ads (Build_Transient_Object_Statements): New routine.
+ * sem_aggr.adb: Major code clean up.
+ * sem_res.adb: Update documentation.
+
+2016-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): For generated
+ subtypes, such as actual subtypes of unconstrained formals,
+ inherit predicate functions, if any, from the parent type rather
+ than creating redundant new ones.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
* exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting.
2016-07-06 Arnaud Charlet <charlet@adacore.com>
-- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
- -- Is_Processed_Transient Flag252
+ -- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
-- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293
-- Has_Pragma_Unused Flag294
+ -- Is_Ignored_Transient Flag295
- -- (unused) Flag295
-- (unused) Flag296
-- (unused) Flag297
-- (unused) Flag298
return Flag99 (Id);
end Is_Exported;
+ function Is_Finalized_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag252 (Id);
+ end Is_Finalized_Transient;
+
function Is_First_Subtype (Id : E) return B is
begin
return Flag70 (Id);
return Flag278 (Id);
end Is_Ignored_Ghost_Entity;
+ function Is_Ignored_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag295 (Id);
+ end Is_Ignored_Transient;
+
function Is_Immediately_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag245 (Id);
end Is_Private_Primitive;
- function Is_Processed_Transient (Id : E) return B is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- return Flag252 (Id);
- end Is_Processed_Transient;
-
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag99 (Id, V);
end Set_Is_Exported;
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag252 (Id, V);
+ end Set_Is_Finalized_Transient;
+
procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin
Set_Flag70 (Id, V);
Set_Flag278 (Id, V);
end Set_Is_Ignored_Ghost_Entity;
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag295 (Id, V);
+ end Set_Is_Ignored_Transient;
+
procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
- procedure Set_Is_Processed_Transient (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- Set_Flag252 (Id, V);
- end Set_Is_Processed_Transient;
-
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
+ W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (Id));
W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
+ W ("Is_Ignored_Transient", Flag295 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
- W ("Is_Processed_Transient", Flag252 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
-- a build-in-place function call. Contains the relocated build-in-place
-- call after the expansion has decoupled the call from the object. This
-- attribute is used by the finalization machinery to insert cleanup code
--- for all additional transient variables found in the transient block.
+-- for all additional transient objects found in the transient block.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record
-- Applies to all entities, true for abstract states that are subject to
-- option External.
+-- Is_Finalized_Transient (Flag252)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object has been finalized by one of
+-- the transient finalization mechanisms. The flag prevents the double
+-- finalization of the object.
+
-- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore.
+-- Is_Ignored_Transient (Flag295)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object must be processed by one of
+-- the transient finalization mechanisms. Once marked, a transient is
+-- intentionally ignored by the general finalization mechanism because
+-- its clean up actions are context specific.
+
-- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes.
--- Is_Processed_Transient (Flag252)
--- Defined in variables, loop parameters, and constants, including the
--- loop parameters of generalized iterators. Set when a transient object
--- needs to be finalized and has already been processed by the transient
--- scope machinery. This flag signals the general finalization mechanism
--- to ignore the transient object.
-
-- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private
-- component of a protected type.
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Uplevel_Referenced_Entity (Flag283)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252)
-- Is_Return_Object (Flag209)
-- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60)
function Is_Entry_Formal (Id : E) return B;
function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
+ function Is_Finalized_Transient (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B;
function Is_Hidden_Open_Scope (Id : E) return B;
function Is_Ignored_Ghost_Entity (Id : E) return B;
+ function Is_Ignored_Transient (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
- function Is_Processed_Transient (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True);
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
- procedure Set_Is_Processed_Transient (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
pragma Inline (Is_Enumeration_Type);
pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
+ pragma Inline (Is_Finalized_Transient);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Ignored_Ghost_Entity);
+ pragma Inline (Is_Ignored_Transient);
pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
- pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
+ pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Ignored_Ghost_Entity);
+ pragma Inline (Set_Is_Ignored_Transient);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
- pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Freeze; use Freeze;
+with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
-- 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
-- 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
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.
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
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Init_Stmt : Node_Id;
begin
- Init_Expr := New_Copy_Tree (Expr);
+ -- Initialize the array element. 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.
+ -- Arr_Comp := Init_Expr;
- Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+ -- Note that the initialization expression is replicated because
+ -- it has to be reevaluated within a generated loop.
- -- 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.
+ 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);
- if Nkind (Init_Expr) = N_Function_Call then
+ -- 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:
- -- Suppress the removal of side effects by generatal analysis
- -- because this behavior is emulated here.
+ -- begin
+ -- Arr_Comp := Init_Expr;
+ -- end;
- Set_No_Side_Effect_Removal (Init_Expr);
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ 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:
- -- type Ptr_Typ is access all Comp_Typ;
+ Append_To (Stmts, Init_Stmt);
- Ptr_Typ := Make_Temporary (Loc, 'A');
+ -- Adjust the tag due to a possible view conversion. Generate:
+ -- Arr_Comp._tag := Full_TypP;
+
+ if Tagged_Type_Expansion
+ and then Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
+ then
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))));
+ 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;
- -- Generate:
- -- Obj : constant Ptr_Typ := Init_Expr'Reference;
+ -- Adjust the array component. Controlled subaggregates are not
+ -- considered because each of their individual elements will
+ -- receive an adjustment of its own. Generate:
- Obj_Id := Make_Temporary (Loc, 'R');
+ -- [Deep_]Adjust (Arr_Comp);
+ 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_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression => Make_Reference (Loc, Init_Expr)));
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Arr_Comp),
+ Typ => Comp_Typ));
+ end if;
+ end Initialize_Array_Component;
- -- Generate:
- -- Obj.all;
+ -------------------------------------
+ -- Initialize_Ctrl_Array_Component --
+ -------------------------------------
- return
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc));
+ 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;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
- -- Otherwise the initialization expression denotes a controlled
- -- object. There is nothing special to be done here as there is
- -- no possible transient scope involvement.
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
- else
- return Init_Expr;
+ begin
+ -- 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 (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;
+
+ In_Place_Expansion :=
+ Nkind (Init_Expr) = N_Function_Call
+ and then not Is_Limited_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 (Init_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 => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => Act_Aggr,
+ Stmts => Act_Stmts);
end if;
- end Ctrl_Init_Expression;
+
+ -- 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 => Init_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 Initialize_Ctrl_Array_Component;
-- Local variables
Expr_Q : Node_Id;
Indexed_Comp : Node_Id;
New_Indexes : List_Id;
- Stmt : Node_Id;
- Stmt_Expr : Node_Id;
-- Start of processing for Gen_Assign
-- 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
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
Typ => Ctype));
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.
-
- -- Arr_Comp (1) := Ctrl_Func_Call;
-
- -- 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));
-
- -- 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.
- -- Note that the function result behaves as a source controlled
- -- object and is finalized by the general finalization mechanism.
-
- -- begin
- -- Res : ... := Ctrl_Func_Call;
- -- Arr_Comp (1) := Res;
- -- Arr_Comp (1)._tag := ...;
- -- Adjust (Arr_Comp (1));
- -- at end
- -- Finalize (Res);
- -- end;
-
- -- 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.
-
- 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);
-
- -- Otherwise use the initialization expression directly
-
- else
- Stmt_Expr := New_Copy_Tree (Expr);
- end if;
-
- Stmt :=
- Make_OK_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Indexed_Comp),
- Expression => Stmt_Expr);
-
- -- 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).
-
- -- 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.
-
- Set_No_Ctrl_Actions (Stmt);
-
- -- 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);
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
then
-
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
-- 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
-- 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.
- ---------------------------------
- -- Ancestor_Discriminant_Value --
- ---------------------------------
+ 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 --
+ ---------------------------------
function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is
Assoc : Node_Id;
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 --
--------------------------------
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_Limited_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))));
+ 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 (Init_Expr);
+
+ -- Install all hook-related declarations and prepare the clean up
+ -- statements.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => N);
end if;
- end Generate_Finalization_Actions;
- 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.
+ -- 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;
- 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.
+ ---------------------------------
+ -- Initialize_Record_Component --
+ ---------------------------------
- --------------------------
- -- Rewrite_Discriminant --
- --------------------------
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Init_Stmt : Node_Id;
- 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))
+ -- 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 (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 (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 Needs_Finalization (Comp_Typ)
+ and then not Is_Limited_Type (Comp_Typ)
then
- Rewrite (Expr,
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ Append_To (Stmts,
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Rec_Comp),
+ Typ => Comp_Typ));
end if;
+ end Initialize_Record_Component;
- return OK;
- end Rewrite_Discriminant;
+ -------------------------
+ -- 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 --
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))));
+ 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
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;
-- case the current delayed expansion mechanism doesn't work when
-- the declared object size depend on the initializing expr.
- begin
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
+ 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 Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
- or else Is_Class_Wide_Type
- (Entity (Object_Definition (Parent_Node)));
- end if;
- end;
+ 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 if;
-- Just set the Delay flag in the cases where the transformation will be
-- 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, Sec_Stack => Needs_Finalization (Typ));
end if;
- -- If the aggregate is non-limited, create a temporary. If it is limited
+ -- If the aggregate is nonlimited, 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.
end if;
end Must_Slide;
- ----------------------------------
- -- Two_Dim_Packed_Array_Handled --
- ----------------------------------
+ ---------------------------------
+ -- Process_Transient_Component --
+ ---------------------------------
- function Two_Dim_Packed_Array_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);
- Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
- Packed_Array : constant Entity_Id :=
- Packed_Array_Impl_Type (Base_Type (Typ));
+ 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.
- One_Comp : Node_Id;
- -- Expression in original aggregate
+ --------------
+ -- Add_Item --
+ --------------
- One_Dim : Node_Id;
- -- One-dimensional subaggregate
+ 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
+ -- Add the access type, which provides a reference to the function
+ -- result. Generate:
- -- For now, only deal with cases where an integral number of elements
- -- fit in a single byte. This includes the most common boolean case.
+ -- type Res_Typ is access all Comp_Typ;
- if not (Comp_Size = 1 or else
- Comp_Size = 2 or else
- Comp_Size = 4)
- then
- return False;
- end if;
+ Res_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Res_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ 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))));
- -- Verify that all components are static
+ -- Add the temporary which captures the result of the function call.
+ -- Generate:
- if Nkind (N) = N_Aggregate
- and then Compile_Time_Known_Aggregate (N)
- then
- null;
+ -- Res : constant Res_Typ := Init_Expr'Reference;
- -- The aggregate may have been re-analyzed and converted already
+ -- Note that this temporary is effectively a transient object because
+ -- its lifetime is bounded by the current array or record component.
- elsif Nkind (N) /= N_Aggregate then
- return True;
+ Res_Id := Make_Temporary (Loc, 'R');
+ Set_Ekind (Res_Id, E_Constant);
+ Set_Etype (Res_Id, Res_Typ);
- -- If component associations remain, the aggregate is not static
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- elsif Present (Component_Associations (N)) then
- return False;
+ Set_Is_Finalized_Transient (Res_Id);
- else
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- if Present (Component_Associations (One_Dim)) then
- return False;
- end if;
+ -- 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.
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if not Is_OK_Static_Expression (One_Comp) then
- return False;
- end if;
+ Set_Is_Ignored_Transient (Res_Id);
- Next (One_Comp);
- end loop;
+ 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)));
- Next (One_Dim);
- end loop;
- end if;
+ Add_Item (Res_Decl);
- -- Two-dimensional aggregate is now fully positional so pack one
- -- dimension to create a static one-dimensional array, and rewrite
- -- as an unchecked conversion to the original type.
+ -- Construct all pieces necessary to hook and finalize the transient
+ -- result.
- declare
- Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
- -- The packed array type is a byte array
+ 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);
- Packed_Num : Nat;
- -- Number of components accumulated in current byte
+ -- Add the access type which provides a reference to the transient
+ -- result. Generate:
- Comps : List_Id;
- -- Assembled list of packed values for equivalent aggregate
+ -- type Ptr_Typ is access all Comp_Typ;
- Comp_Val : Uint;
- -- integer value of component
+ Add_Item (Ptr_Decl);
- Incr : Int;
- -- Step size for packing
+ -- Add the temporary which acts as a hook to the transient result.
+ -- Generate:
- Init_Shift : Int;
- -- Endian-dependent start position for packing
+ -- Hook : Ptr_Typ := null;
- Shift : Int;
- -- Current insertion position
+ Add_Item (Hook_Decl);
- Val : Int;
- -- Component of packed array being assembled.
+ -- Attach the transient result to the hook. Generate:
- begin
- Comps := New_List;
- Val := 0;
- Packed_Num := 0;
+ -- Hook := Ptr_Typ (Res);
- -- Account for endianness. See corresponding comment in
- -- Packed_Array_Aggregate_Handled concerning the following.
+ Add_Item (Hook_Assign);
- if Bytes_Big_Endian
- xor Debug_Flag_8
- xor Reverse_Storage_Order (Base_Type (Typ))
- then
- Init_Shift := Byte_Size - Comp_Size;
- Incr := -Comp_Size;
- else
- Init_Shift := 0;
- Incr := +Comp_Size;
- end if;
+ -- The original initialization expression now references the value of
+ -- the temporary function result. Generate:
- -- Iterate over each subaggregate
+ -- Res.all
- Shift := Init_Shift;
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if Packed_Num = Byte_Size / Comp_Size then
+ Rewrite (Init_Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Res_Id, Loc)));
+ end Process_Transient_Component;
- -- Byte is complete, add to list of expressions
+ --------------------------------------------
+ -- Process_Transient_Component_Completion --
+ --------------------------------------------
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- Val := 0;
- Shift := Init_Shift;
- Packed_Num := 0;
+ 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);
- else
- Comp_Val := Expr_Rep_Value (One_Comp);
+ begin
+ pragma Assert (Present (Fin_Call));
+ pragma Assert (Present (Hook_Clear));
- -- Adjust for bias, and strip proper number of bits
+ -- Generate the following code if exception propagation is allowed:
- if Has_Biased_Representation (Ctyp) then
- Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
- end if;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
- Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
- Shift := Shift + Incr;
- One_Comp := Next (One_Comp);
- Packed_Num := Packed_Num + 1;
- end if;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- One_Dim := Next (One_Dim);
- end loop;
+ -- begin
+ -- [Abort_Defer;]
- if Packed_Num > 0 then
+ -- begin
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
- -- Add final incomplete byte if present
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Curent_Excep.all.all);
+ -- end if;
+ -- end;
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- end if;
+ -- [Abort_Undefer;]
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
- Expression => Make_Aggregate (Loc, Expressions => Comps))));
- Analyze_And_Resolve (N);
- return True;
- end;
- end Two_Dim_Packed_Array_Handled;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
+
+ if Exceptions_OK then
+ Abort_And_Exception : declare
+ Blk_Decls : constant List_Id := New_List;
+ Blk_Stmts : constant List_Id := New_List;
+
+ Fin_Data : Finalization_Exception_Data;
+
+ begin
+ -- Create the declarations of the two flags and the exception
+ -- occurrence.
+
+ Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
+
+ -- Generate:
+ -- Abort_Defer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Defer));
+ end if;
+
+ -- Wrap the hook clear and the finalization call in order to trap
+ -- a potential exception.
+
+ Append_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Hook_Clear,
+ Fin_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data)))));
+
+ -- Generate:
+ -- Abort_Undefer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+
+ -- Reraise the potential exception with a proper "upgrade" to
+ -- Program_Error if needed.
+
+ Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+
+ -- Wrap everything in a block
+
+ 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;
+
+ -- Generate the following code if exception propagation is not allowed
+ -- and aborts are allowed:
+
+ -- begin
+ -- Abort_Defer;
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+ -- at end
+ -- Abort_Undefer;
+ -- end;
+
+ elsif Abort_Allowed then
+ Abort_Only : declare
+ Blk_Stmts : constant List_Id := New_List;
+
+ AUD : Entity_Id;
+ Blk : Node_Id;
+ Blk_HSS : Node_Id;
+ Blk_Id : Entity_Id;
+
+ begin
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ Append_To (Blk_Stmts, Hook_Clear);
+ Append_To (Blk_Stmts, Fin_Call);
+
+ AUD := RTE (RE_Abort_Undefer_Direct);
+
+ Blk_HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
+
+ Blk :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => Blk_HSS);
+
+ Add_Block_Identifier (Blk, Blk_Id);
+ Expand_At_End_Handler (Blk_HSS, Blk_Id);
+
+ -- Present the Abort_Undefer_Direct function to the back end so
+ -- that it can inline the call to the function.
+
+ Add_Inlined_Body (AUD, Aggr);
+
+ Append_To (Stmts, Blk);
+ end Abort_Only;
+
+ -- Otherwise generate:
+
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+
+ else
+ Append_To (Stmts, Hook_Clear);
+ Append_To (Stmts, Fin_Call);
+ end if;
+ end Process_Transient_Component_Completion;
---------------------
-- Sort_Case_Table --
end if;
end Static_Array_Aggregate;
+ ----------------------------------
+ -- Two_Dim_Packed_Array_Handled --
+ ----------------------------------
+
+ function Two_Dim_Packed_Array_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);
+ Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
+ Packed_Array : constant Entity_Id :=
+ Packed_Array_Impl_Type (Base_Type (Typ));
+
+ One_Comp : Node_Id;
+ -- Expression in original aggregate
+
+ One_Dim : Node_Id;
+ -- One-dimensional subaggregate
+
+ begin
+
+ -- For now, only deal with cases where an integral number of elements
+ -- fit in a single byte. This includes the most common boolean case.
+
+ if not (Comp_Size = 1 or else
+ Comp_Size = 2 or else
+ Comp_Size = 4)
+ then
+ return False;
+ end if;
+
+ Convert_To_Positional
+ (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+
+ -- Verify that all components are static
+
+ if Nkind (N) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (N)
+ then
+ null;
+
+ -- The aggregate may have been reanalyzed and converted already
+
+ elsif Nkind (N) /= N_Aggregate then
+ return True;
+
+ -- If component associations remain, the aggregate is not static
+
+ elsif Present (Component_Associations (N)) then
+ return False;
+
+ else
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ if Present (Component_Associations (One_Dim)) then
+ return False;
+ end if;
+
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if not Is_OK_Static_Expression (One_Comp) then
+ return False;
+ end if;
+
+ Next (One_Comp);
+ end loop;
+
+ Next (One_Dim);
+ end loop;
+ end if;
+
+ -- Two-dimensional aggregate is now fully positional so pack one
+ -- dimension to create a static one-dimensional array, and rewrite
+ -- as an unchecked conversion to the original type.
+
+ declare
+ Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
+ -- The packed array type is a byte array
+
+ Packed_Num : Nat;
+ -- Number of components accumulated in current byte
+
+ Comps : List_Id;
+ -- Assembled list of packed values for equivalent aggregate
+
+ Comp_Val : Uint;
+ -- Integer value of component
+
+ Incr : Int;
+ -- Step size for packing
+
+ Init_Shift : Int;
+ -- Endian-dependent start position for packing
+
+ Shift : Int;
+ -- Current insertion position
+
+ Val : Int;
+ -- Component of packed array being assembled
+
+ begin
+ Comps := New_List;
+ Val := 0;
+ Packed_Num := 0;
+
+ -- Account for endianness. See corresponding comment in
+ -- Packed_Array_Aggregate_Handled concerning the following.
+
+ if Bytes_Big_Endian
+ xor Debug_Flag_8
+ xor Reverse_Storage_Order (Base_Type (Typ))
+ then
+ Init_Shift := Byte_Size - Comp_Size;
+ Incr := -Comp_Size;
+ else
+ Init_Shift := 0;
+ Incr := +Comp_Size;
+ end if;
+
+ -- Iterate over each subaggregate
+
+ Shift := Init_Shift;
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if Packed_Num = Byte_Size / Comp_Size then
+
+ -- Byte is complete, add to list of expressions
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ Val := 0;
+ Shift := Init_Shift;
+ Packed_Num := 0;
+
+ else
+ Comp_Val := Expr_Rep_Value (One_Comp);
+
+ -- Adjust for bias, and strip proper number of bits
+
+ if Has_Biased_Representation (Ctyp) then
+ Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
+ end if;
+
+ Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
+ Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
+ Shift := Shift + Incr;
+ One_Comp := Next (One_Comp);
+ Packed_Num := Packed_Num + 1;
+ end if;
+ end loop;
+
+ One_Dim := Next (One_Dim);
+ end loop;
+
+ if Packed_Num > 0 then
+
+ -- Add final incomplete byte if present
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ end if;
+
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
+ Expression => Make_Aggregate (Loc, Expressions => Comps))));
+ Analyze_And_Resolve (N);
+ return True;
+ end;
+ end Two_Dim_Packed_Array_Handled;
+
end Exp_Aggr;
procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
-- Inspect and process statement list Stmt of if or case expression N for
- -- transient controlled objects. If such objects are found, the routine
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
-
- procedure Process_Transient_Object
- (Decl : Node_Id;
- N : Node_Id;
- Stmts : List_Id);
+ -- transient objects. If such objects are found, the routine generates code
+ -- to clean them up when the context of the expression is evaluated.
+
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id);
-- Subsidiary routine to the expansion of expression_with_actions, if and
-- case expressions. Generate all necessary code to finalize a transient
- -- controlled object when the enclosing context is elaborated or evaluated.
- -- Decl denotes the declaration of the transient controlled object which is
- -- usually the result of a controlled function call. N denotes the related
- -- expression_with_actions, if expression, or case expression node. Stmts
- -- denotes the statement list which contains Decl, either at the top level
- -- or within a nested construct.
+ -- object when the enclosing context is elaborated or evaluated. Obj_Decl
+ -- denotes the declaration of the transient object, which is usually the
+ -- result of a controlled function call. Expr denotes the expression with
+ -- actions, if expression, or case expression node. Stmts denotes the
+ -- statement list which contains Decl, either at the top level or within a
+ -- nested construct.
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
Prepend_List (Actions (Alt), Stmts);
end if;
- -- Finalize any transient controlled objects on exit from the
- -- alternative. This is done only in the return optimization case
- -- because otherwise the case expression is converted into an
- -- expression with actions which already contains this form of
- -- processing.
+ -- Finalize any transient objects on exit from the alternative.
+ -- This is done only in the return optimization case because
+ -- otherwise the case expression is converted into an expression
+ -- with actions which already contains this form of processing.
if Optimize_Return_Stmt then
Process_If_Case_Statements (N, Stmts);
function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for
- -- transient controlled objects. If such objects are found, the routine
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
+ -- transient objects. If such objects are found, the routine generates
+ -- code to clean them up when the context of the expression is evaluated
+ -- or elaborated.
------------------------------
-- Force_Boolean_Evaluation --
if Nkind (Act) = N_Object_Declaration
and then Is_Finalizable_Transient (Act, N)
then
- Process_Transient_Object (Act, N, Acts);
+ Process_Transient_In_Expression (Act, N, Acts);
return Abandon;
-- Avoid processing temporary function results multiple times when
null;
-- Force the evaluation of the expression by capturing its value in a
- -- temporary. This ensures that aliases of transient controlled objects
- -- do not leak to the expression of the expression_with_actions node:
+ -- temporary. This ensures that aliases of transient objects do not leak
+ -- to the expression of the expression_with_actions node:
-- do
-- Trans_Id : Ctrl_Typ := ...;
-- in Val end;
-- Once this transformation is performed, it is safe to finalize the
- -- transient controlled object at the end of the actions list.
+ -- transient object at the end of the actions list.
-- Note that Force_Evaluation does not remove side effects in operators
-- because it assumes that all operands are evaluated and side effect
-- free. This is not the case when an operand depends implicitly on the
- -- transient controlled object through the use of access types.
+ -- transient object through the use of access types.
elsif Is_Boolean_Type (Etype (Expression (N))) then
Force_Boolean_Evaluation (Expression (N));
Force_Evaluation (Expression (N));
end if;
- -- Process all transient controlled objects found within the actions of
- -- the EWA node.
+ -- Process all transient objects found within the actions of the EWA
+ -- node.
Act := First (Acts);
while Present (Act) loop
if Nkind (Decl) = N_Object_Declaration
and then Is_Finalizable_Transient (Decl, N)
then
- Process_Transient_Object (Decl, N, Stmts);
+ Process_Transient_In_Expression (Decl, N, Stmts);
end if;
Next (Decl);
end loop;
end Process_If_Case_Statements;
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
+ -------------------------------------
+ -- Process_Transient_In_Expression --
+ -------------------------------------
- procedure Process_Transient_Object
- (Decl : Node_Id;
- N : Node_Id;
- Stmts : List_Id)
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id)
is
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Node_Id := Etype (Obj_Id);
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Hook_Id : Entity_Id;
- Hook_Insert : Node_Id;
- Ptr_Id : Entity_Id;
-
- Hook_Context : constant Node_Id := Find_Hook_Context (N);
+ Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
-- The node on which to insert the hook as an action. This is usually
-- the innermost enclosing non-transient construct.
+ Fin_Call : Node_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+
Fin_Context : Node_Id;
-- The node after which to insert the finalization actions of the
- -- transient controlled object.
+ -- transient object.
begin
- pragma Assert (Nkind_In (N, N_Case_Expression,
- N_Expression_With_Actions,
- N_If_Expression));
+ pragma Assert (Nkind_In (Expr, N_Case_Expression,
+ N_Expression_With_Actions,
+ N_If_Expression));
-- When the context is a Boolean evaluation, all three nodes capture the
-- result of their computation in a local temporary:
-- <finalize Trans_Id>
-- in Result end;
- -- As a result, the finalization of any transient controlled objects can
- -- safely take place after the result capture.
+ -- As a result, the finalization of any transient objects can safely
+ -- take place after the result capture.
-- ??? could this be extended to elementary types?
- if Is_Boolean_Type (Etype (N)) then
+ if Is_Boolean_Type (Etype (Expr)) then
Fin_Context := Last (Stmts);
- -- Otherwise the immediate context may not be safe enough to carry out
- -- transient controlled object finalization due to aliasing and nesting
- -- of constructs. Insert calls to [Deep_]Finalize after the innermost
+ -- Otherwise the immediate context may not be safe enough to carry
+ -- out transient object finalization due to aliasing and nesting of
+ -- constructs. Insert calls to [Deep_]Finalize after the innermost
-- enclosing non-transient construct.
else
Fin_Context := Hook_Context;
end if;
- -- Step 1: Create the access type which provides a reference to the
- -- transient controlled object.
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
+ Set_Is_Finalized_Transient (Obj_Id);
- Desig_Typ := Base_Type (Desig_Typ);
+ -- Construct all the pieces necessary to hook and finalize a transient
+ -- object.
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl,
+ Finalize_Obj => False);
- Ptr_Id := Make_Temporary (Loc, 'A');
+ -- Add the access type which provides a reference to the transient
+ -- object. Generate:
- Insert_Action (Hook_Context,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
+ -- type Ptr_Typ is access all Desig_Typ;
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- controlled object. Generate:
+ Insert_Action (Hook_Context, Ptr_Decl);
+
+ -- Add the temporary which acts as a hook to the transient object.
+ -- Generate:
-- Hook : Ptr_Id := null;
- Hook_Id := Make_Temporary (Loc, 'T');
+ Insert_Action (Hook_Context, Hook_Decl);
- Insert_Action (Hook_Context,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
-
- -- Mark the hook as created for the purposes of exporting the transient
- -- controlled object out of the expression_with_action or if expression.
- -- This signals the machinery in Build_Finalizer to treat this case in
- -- a special manner.
-
- Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl);
-
- -- Step 3: Associate the transient object to the hook
-
- -- This must be inserted right after the object declaration, so that
- -- the assignment is executed if, and only if, the object is actually
- -- created (whereas the declaration of the hook pointer, and the
- -- finalization call, may be inserted at an outer level, and may
- -- remain unused for some executions, if the actual creation of
- -- the object is conditional).
-
- -- The use of unchecked conversion / unrestricted access is needed to
- -- avoid an accessibility violation. Note that the finalization code is
- -- structured in such a way that the "hook" is processed only when it
- -- points to an existing object.
-
- if Is_Access_Type (Obj_Typ) then
- Expr :=
- Unchecked_Convert_To
- (Typ => Ptr_Id,
- Expr => New_Occurrence_Of (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
+ -- When the transient object is initialized by an aggregate, the hook
+ -- must capture the object after the last aggregate assignment takes
+ -- place. Only then is the object considered initialized. Generate:
- -- Generate:
- -- Hook := Ptr_Id (Obj_Id);
+ -- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
- -- When the transient object is initialized by an aggregate, the hook
- -- must capture the object after the last component assignment takes
- -- place. Only then is the object fully initialized.
-
- if Ekind (Obj_Id) = E_Variable
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
-- Otherwise the hook seizes the related object immediately
else
- Hook_Insert := Decl;
+ Hook_Insert := Obj_Decl;
end if;
- Insert_After_And_Analyze (Hook_Insert,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Expr));
-
- -- Step 4: Finalize the hook after the context has been evaluated or
- -- elaborated. Generate:
-
- -- if Hook /= null then
- -- [Deep_]Finalize (Hook.all);
- -- Hook := null;
- -- end if;
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
-- When the node is part of a return statement, there is no need to
-- insert a finalization call, as the general finalization mechanism
- -- (see Build_Finalizer) would take care of the transient controlled
- -- object on subprogram exit. Note that it would also be impossible to
- -- insert the finalization code after the return statement as this will
- -- render it unreachable.
+ -- (see Build_Finalizer) would take care of the transient object on
+ -- subprogram exit. Note that it would also be impossible to insert the
+ -- finalization code after the return statement as this will render it
+ -- unreachable.
if Nkind (Fin_Context) = N_Simple_Return_Statement then
null;
- -- Otherwise finalize the hook
+ -- Finalize the hook after the context has been evaluated. Generate:
+
+ -- if Hook /= null then
+ -- [Deep_]Finalize (Hook.all);
+ -- Hook := null;
+ -- end if;
else
Insert_Action_After (Fin_Context,
- Make_Implicit_If_Statement (Decl,
+ Make_Implicit_If_Statement (Obj_Decl,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd => New_Occurrence_Of (Hook_Id, Loc),
+ Left_Opnd =>
+ New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
- Make_Final_Call
- (Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Hook_Id, Loc)),
- Typ => Desig_Typ),
-
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc)))));
+ Fin_Call,
+ Hook_Clear)));
end if;
- end Process_Transient_Object;
+ end Process_Transient_In_Expression;
------------------------
-- Rewrite_Comparison --
and then Present (Generalized_Indexing (Ref));
end Is_Element_Reference;
- -- Local variables
-
- Is_Elem_Ref : constant Boolean := Is_Element_Reference (N);
-
-- Start of processing for Expand_Ctrl_Function_Call
begin
Remove_Side_Effects (N);
- -- When the temporary function result appears inside a case expression
- -- or an if expression, its lifetime must be extended to match that of
- -- the context. If not, the function result will be finalized too early
- -- and the evaluation of the expression could yield incorrect result. An
- -- exception to this rule are references to Ada 2012 container elements.
+ -- The side effect removal of the function call produced a temporary.
+ -- When the context is a case expression, if expression, or expression
+ -- with actions, the lifetime of the temporary must be extended to match
+ -- that of the context. Otherwise the function result will be finalized
+ -- too early and affect the result of the expression. To prevent this
+ -- unwanted effect, the temporary should not be considered for clean up
+ -- actions by the general finalization machinery.
+
+ -- Exception to this rule are references to Ada 2012 container elements.
-- Such references must be finalized at the end of each iteration of the
-- related quantified expression, otherwise the container will remain
-- busy.
- if not Is_Elem_Ref
+ if Nkind (N) = N_Explicit_Dereference
and then Within_Case_Or_If_Expression (N)
- and then Nkind (N) = N_Explicit_Dereference
+ and then not Is_Element_Reference (N)
then
- Set_Is_Processed_Transient (Entity (Prefix (N)));
+ Set_Is_Ignored_Transient (Entity (Prefix (N)));
end if;
end Expand_Ctrl_Function_Call;
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to
- -- minimize the size of the generated code. For details, see
- -- Process_Transient_Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
- elsif Is_Processed_Transient (Obj_Id) then
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
+
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions
then
Processing_Actions (Has_No_Init => True);
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient
+ -- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
end if;
end if;
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
- -- controlled transient out of an Expression_With_Actions (EWA)
+ -- transient object out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
-- temporaries.
Act_Cleanup : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
- -- Last), but this was incorrect as Process_Transient_Object may
+ -- Last), but this was incorrect as Process_Transients_In_Scope may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id);
- -- First_Object and Last_Object define a list which contains potential
- -- controlled transient objects. Finalization flags are inserted before
- -- First_Object and finalization calls are inserted after Last_Object.
- -- Related_Node is the node for which transient objects have been
- -- created.
+ -- Find all transient objects in the list First_Object .. Last_Object
+ -- and generate finalization actions for them. Related_Node denotes the
+ -- node which created all transient objects.
- -------------------------------
- -- Process_Transient_Objects --
- -------------------------------
+ ---------------------------------
+ -- Process_Transients_In_Scope --
+ ---------------------------------
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id)
is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
Must_Hook : Boolean := False;
- -- Flag denoting whether the context requires transient variable
+ -- Flag denoting whether the context requires transient object
-- export to the outer finalizer.
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
procedure Detect_Subprogram_Call is
new Traverse_Proc (Is_Subprogram_Call);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id);
+ -- Generate finalization actions for a single transient object
+ -- denoted by object declaration Obj_Decl. Blk_Data is the
+ -- exception data of the enclosing block. Blk_Stmts denotes the
+ -- statements of the enclosing block.
+
------------------------
-- Is_Subprogram_Call --
------------------------
end if;
end Is_Subprogram_Call;
- -- Local variables
+ --------------------------------
+ -- Process_Transient_In_Scope --
+ --------------------------------
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Fin_Call : Node_Id;
+ Fin_Stmts : List_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+
+ begin
+ -- Mark the transient object as successfully processed to avoid
+ -- double finalization.
+
+ Set_Is_Finalized_Transient (Obj_Id);
+
+ -- Construct all the pieces necessary to hook and finalize the
+ -- transient object.
+
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
+
+ -- The context contains at least one subprogram call which may
+ -- raise an exception. This scenario employs "hooking" to pass
+ -- transient objects to the enclosing finalizer in case of an
+ -- exception.
+
+ if Must_Hook then
+
+ -- Add the access type which provides a reference to the
+ -- transient object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Insert_Action (Obj_Decl, Ptr_Decl);
+
+ -- Add the temporary which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Insert_Action (Obj_Decl, Hook_Decl);
+
+ -- When the transient object is initialized by an aggregate,
+ -- the hook must capture the object after the last aggregate
+ -- assignment takes place. Only then is the object considered
+ -- fully initialized. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hook := Obj_Id'Unrestricted_Access;
+
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
+
+ -- Otherwise the hook seizes the related object immediately
+
+ else
+ Hook_Insert := Obj_Decl;
+ end if;
+
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
+ end if;
+
+ -- When exception propagation is enabled wrap the hook clear
+ -- statement and the finalization call into a block to catch
+ -- potential exceptions raised during finalization. Generate:
+
+ -- begin
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence
+ -- (Enn, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
+
+ if Exceptions_OK then
+ Fin_Stmts := New_List;
+
+ if Must_Hook then
+ Append_To (Fin_Stmts, Hook_Clear);
+ end if;
+
+ Append_To (Fin_Stmts, Fin_Call);
+
+ Prepend_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 (Blk_Data)))));
+
+ -- Otherwise generate:
+
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- Note that the statements are inserted in reverse order to
+ -- achieve the desired final order outlined above.
+
+ else
+ Prepend_To (Blk_Stmts, Fin_Call);
+
+ if Must_Hook then
+ Prepend_To (Blk_Stmts, Hook_Clear);
+ end if;
+ end if;
+ end Process_Transient_In_Scope;
+
+ -- Local variables
Built : Boolean := False;
+ Blk_Data : Finalization_Exception_Data;
Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id;
Blk_Stmts : List_Id;
- Desig_Typ : Entity_Id;
- Fin_Call : Node_Id;
- Fin_Data : Finalization_Exception_Data;
- Fin_Stmts : List_Id;
- Hook_Clr : Node_Id := Empty;
- Hook_Id : Entity_Id;
- Hook_Ins : Node_Id;
- Init_Expr : Node_Id;
Loc : Source_Ptr;
Obj_Decl : Node_Id;
- Obj_Id : Entity_Id;
- Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id;
- Ptr_Typ : Entity_Id;
- -- Start of processing for Process_Transient_Objects
+ -- Start of processing for Process_Transients_In_Scope
begin
-- The expansion performed by this routine is as follows:
-- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end;
+ -- Abort_Undefer;
+
-- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
-
- -- Abort_Undefer_Direct;
-- end;
-- Recognize a scenario where the transient context is an object
-- Obj : ...;
-- Res : ... := BIP_Func_Call (..., Obj, ...);
- -- The finalization of any controlled transient must happen after
- -- the build-in-place function call is executed.
+ -- The finalization of any transient object must happen after the
+ -- build-in-place function call is executed.
if Nkind (N) = N_Object_Declaration
and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
and then Obj_Decl /= Related_Node
then
- Loc := Sloc (Obj_Decl);
- Obj_Id := Defining_Identifier (Obj_Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
- Desig_Typ := Obj_Typ;
-
- Set_Is_Processed_Transient (Obj_Id);
-
- -- Handle access types
-
- if Is_Access_Type (Desig_Typ) then
- Desig_Typ := Available_View (Designated_Type (Desig_Typ));
- end if;
-
- -- Transient objects associated with subprogram calls need
- -- extra processing. These objects are usually created right
- -- before the call and finalized immediately after the call.
- -- If an exception occurs during the call, the clean up code
- -- is skipped due to the sudden change in control and the
- -- transient is never finalized.
-
- -- To handle this case, such variables are "exported" to the
- -- enclosing sequence of statements where their corresponding
- -- "hooks" are picked up by the finalization machinery.
-
- if Must_Hook then
-
- -- Create an access type which provides a reference to the
- -- transient object. Generate:
- -- type Ptr_Typ is access [all] Desig_Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'A');
-
- Insert_Action (Obj_Decl,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication =>
- New_Occurrence_Of (Desig_Typ, Loc))));
-
- -- Create a temporary which acts as a hook to the transient
- -- object. Generate:
- -- Hook : Ptr_Typ := null;
-
- Hook_Id := Make_Temporary (Loc, 'T');
-
- Insert_Action (Obj_Decl,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition =>
- New_Occurrence_Of (Ptr_Typ, Loc)));
-
- -- Mark the temporary as a hook. This signals the machinery
- -- in Build_Finalizer to recognize this special case.
-
- Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
-
- -- Hook the transient object to the temporary. Generate:
- -- Hook := Ptr_Typ (Obj_Id);
- -- <or>
- -- Hook := Obj_Id'Unrestricted_Access;
-
- if Is_Access_Type (Obj_Typ) then
- Init_Expr :=
- Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
-
- else
- Init_Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
-
- -- When the transient object is initialized by an aggregate,
- -- the hook must capture the object after the last component
- -- assignment takes place. Only then is the object fully
- -- initialized.
-
- if Ekind (Obj_Id) = E_Variable
- and then Present (Last_Aggregate_Assignment (Obj_Id))
- then
- Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
-
- -- Otherwise the hook seizes the related object immediately
-
- else
- Hook_Ins := Obj_Decl;
- end if;
-
- Insert_After_And_Analyze (Hook_Ins,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Init_Expr));
-
- -- The transient object is about to be finalized by the
- -- clean up code following the subprogram call. In order
- -- to avoid double finalization, clear the hook.
-
- -- Generate:
- -- Hook := null;
-
- Hook_Clr :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc));
- end if;
+ Loc := Sloc (Obj_Decl);
-- Before generating the clean up code for the first transient
-- object, create a wrapper block which houses all hook clear
Built := True;
Blk_Stmts := New_List;
- -- Create the declarations of all entities that participate
- -- in exception detection and propagation.
+ -- Generate:
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
if Exceptions_OK then
Blk_Decls := New_List;
-
- -- Generate:
- -- Abrt : constant Boolean := ...;
- -- Ex : Exception_Occurrence;
- -- Raised : Boolean := False;
-
- Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
-
- -- Generate:
- -- if Raised and then not Abrt then
- -- Raise_From_Controlled_Operation (Ex);
- -- end if;
-
- Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+ Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
end if;
Blk_Decl :=
Statements => Blk_Stmts));
end if;
- -- Generate:
- -- [Deep_]Finalize (Obj_Ref);
-
- Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
-
- if Is_Access_Type (Obj_Typ) then
- Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
- Set_Etype (Obj_Ref, Desig_Typ);
- end if;
-
- Fin_Call :=
- Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
-
- -- When exception propagation is enabled wrap the hook clear
- -- statement and the finalization call into a block to catch
- -- potential exceptions raised during finalization. Generate:
-
- -- begin
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence
- -- (Enn, Get_Current_Excep.all.all);
- -- end if;
- -- end;
-
- if Exceptions_OK then
- Fin_Stmts := New_List;
+ -- Construct all necessary circuitry to hook and finalize a
+ -- single transient object.
- if Present (Hook_Clr) then
- Append_To (Fin_Stmts, Hook_Clr);
- end if;
-
- Append_To (Fin_Stmts, Fin_Call);
-
- Prepend_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)))));
-
- -- Otherwise generate:
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- else
- Prepend_To (Blk_Stmts, Fin_Call);
-
- if Present (Hook_Clr) then
- Prepend_To (Blk_Stmts, Hook_Clr);
- end if;
- end if;
+ Process_Transient_In_Scope
+ (Obj_Decl => Obj_Decl,
+ Blk_Data => Blk_Data,
+ Blk_Stmts => Blk_Stmts);
end if;
-- Terminate the scan after the last object has been processed to
Next (Obj_Decl);
end loop;
+ -- Complete the decoration of the enclosing finalization block and
+ -- insert it into the tree.
+
if Present (Blk_Decl) then
- -- Note that the abort defer / undefer pair does not require an
- -- extra block because each finalization exception is caught in
- -- its corresponding finalization block. As a result, the call to
- -- Abort_Defer always takes place.
+ -- Note that this Abort_Undefer does not require a extra block or
+ -- an AT_END handler because each finalization exception is caught
+ -- in its own corresponding finalization block. As a result, the
+ -- call to Abort_Defer always takes place.
if Abort_Allowed then
Prepend_To (Blk_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
+ -- Generate:
+ -- if Raised and then not Abrt then
+ -- Raise_From_Controlled_Operation (Ex);
+ -- end if;
+
+ if Exceptions_OK then
+ Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
+ end if;
+
Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
- end Process_Transient_Objects;
+ end Process_Transients_In_Scope;
-- Local variables
(Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
end if;
- -- Check for transient controlled objects associated with Target and
- -- generate the appropriate finalization actions for them.
+ -- Check for transient objects associated with Target and generate the
+ -- appropriate finalization actions for them.
- Process_Transient_Objects
+ Process_Transients_In_Scope
(First_Object => First_Obj,
Last_Object => Last_Obj,
Related_Node => Target);
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ---------------------------------------
+ -- Build_Transient_Object_Statements --
+ ---------------------------------------
+
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+
+ Desig_Typ : Entity_Id;
+ Hook_Expr : Node_Id;
+ Hook_Id : Entity_Id;
+ Obj_Ref : Node_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ -- Recover the type of the object
+
+ Desig_Typ := Obj_Typ;
+
+ if Is_Access_Type (Desig_Typ) then
+ Desig_Typ := Available_View (Designated_Type (Desig_Typ));
+ end if;
+
+ -- Create an access type which provides a reference to the transient
+ -- object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Ptr_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
+
+ Ptr_Decl :=
+ 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 (Desig_Typ, Loc)));
+
+ -- Create a temporary check which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Hook_Id := Make_Temporary (Loc, 'T');
+ Set_Ekind (Hook_Id, E_Variable);
+ Set_Etype (Hook_Id, Ptr_Typ);
+
+ Hook_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Hook_Id,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Mark the temporary as a hook. This signals the machinery in
+ -- Build_Finalizer to recognize this special case.
+
+ Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
+
+ -- Hook the transient object to the temporary. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hool := Obj_Id'Unrestricted_Access;
+
+ if Is_Access_Type (Obj_Typ) then
+ Hook_Expr :=
+ Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
+ else
+ Hook_Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
+
+ Hook_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Hook_Expr);
+
+ -- Crear the hook prior to finalizing the object. Generate:
+
+ -- Hook := null;
+
+ Hook_Clear :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Finalize the object. Generate:
+
+ -- [Deep_]Finalize (Obj_Ref[.all]);
+
+ if Finalize_Obj then
+ Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
+
+ if Is_Access_Type (Obj_Typ) then
+ Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
+ Set_Etype (Obj_Ref, Desig_Typ);
+ end if;
+
+ Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ);
+
+ -- Otherwise finalize the hook. Generate:
+
+ -- [Deep_]Finalize (Hook.all);
+
+ else
+ Fin_Call :=
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Hook_Id, Loc)),
+ Typ => Desig_Typ);
+ end if;
+ end Build_Transient_Object_Statements;
+
-----------------------------
-- Check_Float_Op_Overflow --
-----------------------------
-- explicit aliases of it:
-- do
- -- Trans_Id : Ctrl_Typ ...; -- controlled transient object
+ -- Trans_Id : Ctrl_Typ ...; -- transient object
-- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ -- Do not consider a transient object that was already processed
+
+ and then not Is_Finalized_Transient (Obj_Id)
+
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to minimize
- -- the size of the generated code. See Exp_Ch7.Process_Transient_
- -- Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
- elsif Is_Processed_Transient (Obj_Id) then
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
+
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions because
then
return True;
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient objects
+ -- declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
elsif Nkind (Decl) = N_Block_Statement
and then
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
-- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups.
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True);
+ -- Subsidiary to the processing of transient objects in transient scopes,
+ -- if expressions, case expressions, expression_with_action nodes, array
+ -- aggregates, and record aggregates. Obj_Decl denotes the declaration of
+ -- the transient object. Generate the following nodes:
+ --
+ -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient
+ -- object if flag Finalize_Obj is set to True, or finalizes the hook when
+ -- the flag is False.
+ --
+ -- * Hook_Assign - the assignment statement which captures a reference to
+ -- the transient object in the hook.
+ --
+ -- * Hook_Clear - the assignment statement which resets the hook to null
+ --
+ -- * Hook_Decl - the declaration of the hook object
+ --
+ -- * Ptr_Decl - the full type declaration of the hook type
+ --
+ -- These nodes are inserted in specific places depending on the context by
+ -- the various Process_Transient_xxx routines.
+
procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow
end if;
else
- Error_Msg_N ("no unique type for this aggregate", A);
+ Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Assoc : Node_Id;
- -- N_Component_Association node belonging to the input aggregate N
-
- Expr : Node_Id;
- Positional_Expr : Node_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
-
- Components : constant Elist_Id := New_Elmt_List;
- -- Components is the list of the record components whose value must be
- -- provided in the aggregate. This list does include discriminants.
-
New_Assoc_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
- -- nodes. New_Assoc is one such N_Component_Association node in it.
- -- Note that while Assoc and New_Assoc contain the same kind of nodes,
- -- they are used to iterate over two different N_Component_Association
- -- lists.
+ -- nodes.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
Box_Node : Node_Id;
Is_Box_Present : Boolean := False;
Others_Box : Integer := 0;
-
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
-- (which may be a sub-aggregate of a larger one) that are default-
-- initialized. A value of One indicates that an others_box is present.
-- Any larger value indicates that the others_box is not redundant.
- -- These variables, similar to Others_Etype, are also updated as a
- -- side effect of function Get_Value.
- -- Box_Node is used to place a warning on a redundant others_box.
+ -- These variables, similar to Others_Etype, are also updated as a side
+ -- effect of function Get_Value. Box_Node is used to place a warning on
+ -- a redundant others_box.
procedure Add_Association
(Component : Entity_Id;
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
- function Discr_Present (Discr : Entity_Id) return Boolean;
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- The constraint to a component may be given by a discriminant of the
+ -- enclosing type, in which case we have to retrieve its value, which is
+ -- part of the enclosing aggregate. Assoc_List provides the discriminant
+ -- associations of the current type or of some enclosing record.
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
- -- Otherwise, if N is an extension aggregate, Discr is a discriminant
- -- whose value may already have been specified by N's ancestor part.
- -- This routine checks whether this is indeed the case and if so returns
- -- False, signaling that no value for Discr should appear in N's
- -- aggregate part. Also, in this case, the routine appends to
- -- New_Assoc_List the discriminant value specified in the ancestor part.
+ -- Otherwise, if N is an extension aggregate, then Input_Discr denotes
+ -- a discriminant whose value may already have been specified by N's
+ -- ancestor part. This routine checks whether this is indeed the case
+ -- and if so returns False, signaling that no value for Input_Discr
+ -- should appear in N's aggregate part. Also, in this case, the routine
+ -- appends to New_Assoc_List the discriminant value specified in the
+ -- ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from private view Typ. Whether the aggregate is legal depends
+ -- on the current visibility of the type as well as that of the parent
+ -- of the ancestor.
+
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id;
+ Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes.
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- Nested components may themselves be discriminated types constrained
+ -- by outer discriminants, whose values must be captured before the
+ -- aggregate is expanded into assignments.
+
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that
Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
- Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
+ Loc : Source_Ptr;
begin
- -- If this is a box association the expression is missing, so
- -- use the Sloc of the aggregate itself for the new association.
+ -- If this is a box association the expression is missing, so use the
+ -- Sloc of the aggregate itself for the new association.
if Present (Expr) then
Loc := Sloc (Expr);
Loc := Sloc (N);
end if;
- Append (New_Occurrence_Of (Component, Loc), Choice_List);
- New_Assoc :=
+ Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
+
+ Append_To (Assoc_List,
Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
- Box_Present => Is_Box_Present);
- Append (New_Assoc, Assoc_List);
+ Box_Present => Is_Box_Present));
end Add_Association;
- -------------------
- -- Discr_Present --
- -------------------
+ -----------------------------
+ -- Add_Discriminant_Values --
+ -----------------------------
+
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Discr_Val : Node_Id;
+ Val : Entity_Id;
+
+ begin
+ Discr := First_Discriminant (Etype (New_Aggr));
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
+ while Present (Discr_Elmt) loop
+ Discr_Val := Node (Discr_Elmt);
+
+ -- If the constraint is given by a discriminant then it is a
+ -- discriminant of an enclosing record, and its value has already
+ -- been placed in the association list.
- function Discr_Present (Discr : Entity_Id) return Boolean is
+ if Is_Entity_Name (Discr_Val)
+ and then Ekind (Entity (Discr_Val)) = E_Discriminant
+ then
+ Val := Entity (Discr_Val);
+
+ Assoc := First (Assoc_List);
+ while Present (Assoc) loop
+ if Present (Entity (First (Choices (Assoc))))
+ and then Entity (First (Choices (Assoc))) = Val
+ then
+ Discr_Val := Expression (Assoc);
+ exit;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Add_Association
+ (Discr, New_Copy_Tree (Discr_Val),
+ Component_Associations (New_Aggr));
+
+ -- If the discriminant constraint is a current instance, mark the
+ -- current aggregate so that the self-reference can be expanded
+ -- later. The constraint may refer to the subtype of aggregate, so
+ -- use base type for comparison.
+
+ if Nkind (Discr_Val) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Discr_Val))
+ and then Is_Type (Entity (Prefix (Discr_Val)))
+ and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
+ then
+ Set_Has_Self_Reference (N);
+ end if;
+
+ Next_Elmt (Discr_Elmt);
+ Next_Discriminant (Discr);
+ end loop;
+ end Add_Discriminant_Values;
+
+ --------------------------
+ -- Discriminant_Present --
+ --------------------------
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+ Ancestor_Is_Subtyp : Boolean;
+
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Ancestor_Typ : Entity_Id;
Comp_Assoc : Node_Id;
+ Discr : Entity_Id;
Discr_Expr : Node_Id;
-
- Ancestor_Typ : Entity_Id;
+ Discr_Val : Elmt_Id := No_Elmt;
Orig_Discr : Entity_Id;
- D : Entity_Id;
- D_Val : Elmt_Id := No_Elmt; -- stop junk warning
-
- Ancestor_Is_Subtyp : Boolean;
begin
if Regular_Aggr then
-- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then
- D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+ Discr_Val :=
+ First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
- Orig_Discr := Original_Record_Component (Discr);
+ Orig_Discr := Original_Record_Component (Input_Discr);
- D := First_Discriminant (Ancestor_Typ);
- while Present (D) loop
+ Discr := First_Discriminant (Ancestor_Typ);
+ while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
- if Original_Record_Component (D) = Orig_Discr then
+ if Original_Record_Component (Discr) = Orig_Discr then
if Ancestor_Is_Subtyp then
- Discr_Expr := New_Copy_Tree (Node (D_Val));
+ Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
- Selector_Name => New_Occurrence_Of (Discr, Loc));
+ Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if;
- Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
- Next_Discriminant (D);
+ Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then
- Next_Elmt (D_Val);
+ Next_Elmt (Discr_Val);
end if;
end loop;
return True;
- end Discr_Present;
+ end Discriminant_Present;
+
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is
+ Par : Entity_Id;
+
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
---------------
-- Get_Value --
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id
+ Consider_Others_Choice : Boolean := False) return Node_Id
is
Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id;
null;
else
Error_Msg_N
- ("components in OTHERS choice must "
- & "have same type", Selector_Name);
+ ("components in OTHERS choice must have same "
+ & "type", Selector_Name);
end if;
end if;
Others_Etype := Typ;
- -- Copy expression so that it is resolved
+ -- Copy the expression so that it is resolved
-- independently for each component, This is needed
-- for accessibility checks on compoents of anonymous
-- access types, even in compile_only mode.
return New_Copy;
end New_Copy_Tree_And_Copy_Dimensions;
+ -----------------------------
+ -- Propagate_Discriminants --
+ -----------------------------
+
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Needs_Box : Boolean := False;
+
+ procedure Process_Component (Comp : Entity_Id);
+ -- Add one component with a box association to the inner aggregate,
+ -- and recurse if component is itself composite.
+
+ -----------------------
+ -- Process_Component --
+ -----------------------
+
+ procedure Process_Component (Comp : Entity_Id) is
+ T : constant Entity_Id := Etype (Comp);
+ New_Aggr : Node_Id;
+
+ begin
+ if Is_Record_Type (T) and then Has_Discriminants (T) then
+ New_Aggr := Make_Aggregate (Loc, New_List, New_List);
+ Set_Etype (New_Aggr, T);
+
+ Add_Association
+ (Comp, New_Aggr, Component_Associations (Aggr));
+
+ -- Collect discriminant values and recurse
+
+ Add_Discriminant_Values (New_Aggr, Assoc_List);
+ Propagate_Discriminants (New_Aggr, Assoc_List);
+
+ else
+ Needs_Box := True;
+ end if;
+ end Process_Component;
+
+ -- Local variables
+
+ Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
+ Components : constant Elist_Id := New_Elmt_List;
+ Def_Node : constant Node_Id :=
+ Type_Definition (Declaration_Node (Aggr_Type));
+
+ Comp : Node_Id;
+ Comp_Elmt : Elmt_Id;
+ Errors : Boolean;
+
+ -- Start of processing for Propagate_Discriminants
+
+ begin
+ -- The component type may be a variant type. Collect the components
+ -- that are ruled by the known values of the discriminants. Their
+ -- values have already been inserted into the component list of the
+ -- current aggregate.
+
+ if Nkind (Def_Node) = N_Record_Definition
+ and then Present (Component_List (Def_Node))
+ and then Present (Variant_Part (Component_List (Def_Node)))
+ then
+ Gather_Components (Aggr_Type,
+ Component_List (Def_Node),
+ Governed_By => Component_Associations (Aggr),
+ Into => Components,
+ Report_Errors => Errors);
+
+ Comp_Elmt := First_Elmt (Components);
+ while Present (Comp_Elmt) loop
+ if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
+ Process_Component (Node (Comp_Elmt));
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ -- No variant part, iterate over all components
+
+ else
+ Comp := First_Component (Etype (Aggr));
+ while Present (Comp) loop
+ Process_Component (Comp);
+ Next_Component (Comp);
+ end loop;
+ end if;
+
+ if Needs_Box then
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True));
+ end if;
+ end Propagate_Discriminants;
+
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded
---------------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Expr);
begin
- return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
- and then Present (Etype (Expr))
- and then Is_Record_Type (Etype (Expr))
- and then Expansion_Delayed (Expr))
- or else (Kind = N_Qualified_Expression
- and then Has_Expansion_Delayed (Expression (Expr)));
+ return
+ (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Present (Etype (Expr))
+ and then Is_Record_Type (Etype (Expr))
+ and then Expansion_Delayed (Expr))
+ or else
+ (Nkind (Expr) = N_Qualified_Expression
+ and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
-- Local variables
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
+ -- Add association Component => Expr if the caller requests it
+
if Relocate then
New_Expr := Relocate_Node (Expr);
Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
+ -- Local variables
+
+ Components : constant Elist_Id := New_Elmt_List;
+ -- Components is the list of the record components whose value must be
+ -- provided in the aggregate. This list does include discriminants.
+
+ Expr : Node_Id;
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+ Positional_Expr : Node_Id;
+
-- Start of processing for Resolve_Record_Aggregate
begin
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
-
if Present (Expressions (N)) then
Check_SPARK_05_Restriction
("named association cannot follow positional one",
-- STEP 2: Verify aggregate structure
Step_2 : declare
- Selector_Name : Node_Id;
+ Assoc : Node_Id;
Bad_Aggregate : Boolean := False;
+ Selector_Name : Node_Id;
begin
if Present (Component_Associations (N)) then
-- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop
- if Discr_Present (Discrim) then
+ if Discriminant_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231)
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
- if not Discr_Present (Discrim) then
+ if not Discriminant_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant &",
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype : declare
+ Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : Entity_Id;
Indic : Node_Id;
+ New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
-
- C : constant List_Id := New_List;
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
- Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
+ Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
Next (New_Assoc);
end loop;
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
end if;
Def_Id := Create_Itype (Ekind (Typ), N);
-- STEP 5: Get remaining components according to discriminant values
Step_5 : declare
+ Dnode : Node_Id;
+ Errors_Found : Boolean := False;
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
- Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
- Errors_Found : Boolean := False;
- Dnode : Node_Id;
-
- function Find_Private_Ancestor return Entity_Id;
- -- AI05-0115: Find earlier ancestor in the derivation chain that is
- -- derived from a private view. Whether the aggregate is legal
- -- depends on the current visibility of the type as well as that
- -- of the parent of the ancestor.
-
- ---------------------------
- -- Find_Private_Ancestor --
- ---------------------------
-
- function Find_Private_Ancestor return Entity_Id is
- Par : Entity_Id;
-
- begin
- Par := Typ;
- loop
- if Has_Private_Ancestor (Par)
- and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
- then
- return Par;
-
- elsif not Is_Derived_Type (Par) then
- return Empty;
-
- else
- Par := Etype (Base_Type (Par));
- end if;
- end loop;
- end Find_Private_Ancestor;
-
- -- Start of processing for Step_5
+ Root_Typ : Entity_Id;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
- -- AI05-0115: check legality of aggregate for type with
- -- aa private ancestor.
+ -- AI05-0115: check legality of aggregate for type with a
+ -- private ancestor.
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
- Find_Private_Ancestor;
+ Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id :=
- Cunit_Entity (Get_Source_Unit (Ancestor));
+ Cunit_Entity
+ (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
- Cunit_Entity
- (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ Cunit_Entity (Get_Source_Unit
+ (Base_Type (Etype (Ancestor))));
begin
-- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
-- object of the aggregate.
if Present (Parent (Component))
- and then
- Nkind (Parent (Component)) = N_Component_Declaration
+ and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
Expr :=
elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp))
then
- if not Is_Private_Type (Ctyp) then
- Expr := Make_Null (Sloc (N));
- Set_Etype (Expr, Ctyp);
- Add_Association
- (Component => Component,
- Expr => Expr,
- Assoc_List => New_Assoc_List);
-
-- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking.
- else
+ if Is_Private_Type (Ctyp) then
declare
Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark =>
New_Occurrence_Of
(Underlying_Type (Ctyp), Sloc (N)),
- Expression => Make_Null (Sloc (N)));
+ Expression => Make_Null (Sloc (N)));
Convert_Null : constant Node_Id :=
Unchecked_Convert_To
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end;
+
+ -- Otherwise the component type is non-private
+
+ else
+ Expr := Make_Null (Sloc (N));
+ Set_Etype (Expr, Ctyp);
+
+ Add_Association
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
end if;
-- Ada 2012: If component is scalar with default value, use it
then
Add_Association
(Component => Component,
- Expr => Default_Aspect_Value
- (First_Subtype (Underlying_Type (Ctyp))),
+ Expr =>
+ Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List);
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
-- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of
- -- the component. The capture of discriminants must
- -- be recursive because subcomponents may be constrained
+ -- the component. The capture of discriminants must be
+ -- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id;
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id);
- -- The constraint to a component may be given by a
- -- discriminant of the enclosing type, in which case
- -- we have to retrieve its value, which is part of the
- -- enclosing aggregate. Assoc_List provides the
- -- discriminant associations of the current type or
- -- of some enclosing record.
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id);
- -- Nested components may themselves be discriminated
- -- types constrained by outer discriminants, whose
- -- values must be captured before the aggregate is
- -- expanded into assignments.
-
- -----------------------------
- -- Add_Discriminant_Values --
- -----------------------------
-
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Val : Entity_Id;
-
- begin
- Discr := First_Discriminant (Etype (New_Aggr));
- Discr_Elmt :=
- First_Elmt
- (Discriminant_Constraint (Etype (New_Aggr)));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
-
- -- If the constraint is given by a discriminant
- -- it is a discriminant of an enclosing record,
- -- and its value has already been placed in the
- -- association list.
-
- if Is_Entity_Name (Discr_Val)
- and then
- Ekind (Entity (Discr_Val)) = E_Discriminant
- then
- Val := Entity (Discr_Val);
-
- Assoc := First (Assoc_List);
- while Present (Assoc) loop
- if Present
- (Entity (First (Choices (Assoc))))
- and then
- Entity (First (Choices (Assoc))) = Val
- then
- Discr_Val := Expression (Assoc);
- exit;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- Add_Association
- (Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
-
- -- If the discriminant constraint is a current
- -- instance, mark the current aggregate so that
- -- the self-reference can be expanded later.
- -- The constraint may refer to the subtype of
- -- aggregate, so use base type for comparison.
-
- if Nkind (Discr_Val) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Discr_Val))
- and then Is_Type (Entity (Prefix (Discr_Val)))
- and then Base_Type (Etype (N)) =
- Entity (Prefix (Discr_Val))
- then
- Set_Has_Self_Reference (N);
- end if;
-
- Next_Elmt (Discr_Elmt);
- Next_Discriminant (Discr);
- end loop;
- end Add_Discriminant_Values;
-
- -----------------------------
- -- Propagate_Discriminants --
- -----------------------------
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Aggr_Type : constant Entity_Id :=
- Base_Type (Etype (Aggr));
- Def_Node : constant Node_Id :=
- Type_Definition
- (Declaration_Node (Aggr_Type));
-
- Comp : Node_Id;
- Comp_Elmt : Elmt_Id;
- Components : constant Elist_Id := New_Elmt_List;
- Needs_Box : Boolean := False;
- Errors : Boolean;
-
- procedure Process_Component (Comp : Entity_Id);
- -- Add one component with a box association to the
- -- inner aggregate, and recurse if component is
- -- itself composite.
-
- -----------------------
- -- Process_Component --
- -----------------------
-
- procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
-
- begin
- if Is_Record_Type (T)
- and then Has_Discriminants (T)
- then
- New_Aggr :=
- Make_Aggregate (Loc, New_List, New_List);
- Set_Etype (New_Aggr, T);
- Add_Association
- (Comp, New_Aggr,
- Component_Associations (Aggr));
-
- -- Collect discriminant values and recurse
-
- Add_Discriminant_Values
- (New_Aggr, Assoc_List);
- Propagate_Discriminants
- (New_Aggr, Assoc_List);
-
- else
- Needs_Box := True;
- end if;
- end Process_Component;
-
- -- Start of processing for Propagate_Discriminants
-
- begin
- -- The component type may be a variant type, so
- -- collect the components that are ruled by the
- -- known values of the discriminants. Their values
- -- have already been inserted into the component
- -- list of the current aggregate.
-
- if Nkind (Def_Node) = N_Record_Definition
- and then Present (Component_List (Def_Node))
- and then
- Present
- (Variant_Part (Component_List (Def_Node)))
- then
- Gather_Components (Aggr_Type,
- Component_List (Def_Node),
- Governed_By => Component_Associations (Aggr),
- Into => Components,
- Report_Errors => Errors);
-
- Comp_Elmt := First_Elmt (Components);
- while Present (Comp_Elmt) loop
- if Ekind (Node (Comp_Elmt)) /=
- E_Discriminant
- then
- Process_Component (Node (Comp_Elmt));
- end if;
-
- Next_Elmt (Comp_Elmt);
- end loop;
-
- -- No variant part, iterate over all components
-
- else
- Comp := First_Component (Etype (Aggr));
- while Present (Comp) loop
- Process_Component (Comp);
- Next_Component (Comp);
- end loop;
- end if;
-
- if Needs_Box then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
- end Propagate_Discriminants;
-
- -- Start of processing for Capture_Discriminants
-
begin
Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp);
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
Propagate_Discriminants
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
else
declare
Expression => Empty,
Box_Present => True));
end if;
+
exit;
end if;
Assoc_List => New_Assoc_List);
end Capture_Discriminants;
+ -- Otherwise the component type is not a record, or it has
+ -- not discriminants, or it is private.
+
else
Add_Association
(Component => Component,
-- STEP 7: check for invalid components + check type in choice list
Step_7 : declare
+ Assoc : Node_Id;
+ New_Assoc : Node_Id;
+
Selectr : Node_Id;
-- Selector name
if Nkind (N) /= N_Extension_Aggregate
or else
Scope (Original_Record_Component (C)) /=
- Etype (Ancestor_Part (N))
+ Etype (Ancestor_Part (N))
then
exit;
end if;
then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
+
+ -- Generated subtypes inherit the predicate function from the parent
+ -- (no aspects to examine on the generated declaration).
+
+ if not Comes_From_Source (N) then
+ Set_Ekind (Id, Ekind (T));
+
+ if Present (Predicate_Function (T)) then
+ Set_Predicate_Function (Id, Predicate_Function (T));
+
+ elsif Present (Ancestor_Subtype (T))
+ and then Has_Predicates (Ancestor_Subtype (T))
+ and then Present (Predicate_Function (Ancestor_Subtype (T)))
+ then
+ Set_Predicate_Function (Id,
+ Predicate_Function (Ancestor_Subtype (T)));
+ end if;
+ end if;
end if;
-- Subtype of Boolean cannot have a constraint in SPARK
begin
-- Ensure all actions associated with the left operand (e.g.
- -- finalization of transient controlled objects) are fully evaluated
- -- locally within an expression with actions. This is particularly
- -- helpful for coverage analysis. However this should not happen in
- -- generics or if Minimize_Expression_With_Actions is set.
+ -- finalization of transient objects) are fully evaluated locally within
+ -- an expression with actions. This is particularly helpful for coverage
+ -- analysis. However this should not happen in generics or if option
+ -- Minimize_Expression_With_Actions is set.
if Expander_Active and not Minimize_Expression_With_Actions then
declare
projects / platform / upstream / gcc.git / commitdiff