then
return;
- -- Do not expand an aggregate for an array type which contains tasks if
- -- the aggregate is associated with an unexpanded return statement of a
- -- build-in-place function. The aggregate is expanded when the related
- -- return statement (rewritten into an extended return) is processed.
- -- This delay ensures that any temporaries and initialization code
- -- generated for the aggregate appear in the proper return block and
- -- use the correct _chain and _master.
-
- elsif Has_Task (Base_Type (Etype (N)))
- and then Nkind (Parent (N)) = N_Simple_Return_Statement
- and then Is_Build_In_Place_Function
- (Return_Applies_To (Return_Statement_Entity (Parent (N))))
- then
- return;
-
elsif Present (Component_Associations (N))
and then Nkind (First (Component_Associations (N))) =
N_Iterated_Component_Association
or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association
or else (Parent_Kind = N_Object_Declaration
- and then Needs_Finalization (Typ))
+ and then (Needs_Finalization (Typ)
+ or else Is_Build_In_Place_Return_Object
+ (Defining_Identifier (Parent_Node))))
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
end loop;
end Copy_Discr_Checking_Funcs;
- ----------------------------------------
- -- Ensure_Activation_Chain_And_Master --
- ----------------------------------------
-
- procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is
- Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- Expr : constant Node_Id := Expression (Obj_Decl);
- Expr_Q : Node_Id;
- Typ : constant Entity_Id := Etype (Def_Id);
-
- begin
- pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration);
-
- if Might_Have_Tasks (Typ) then
- Build_Activation_Chain_Entity (Obj_Decl);
-
- if Has_Task (Typ) then
- Build_Master_Entity (Def_Id);
-
- -- Handle objects initialized with BIP function calls
-
- elsif Present (Expr) then
- if Nkind (Expr) = N_Qualified_Expression then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
- end if;
-
- if Is_Build_In_Place_Function_Call (Expr_Q)
- or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
- or else
- (Nkind (Expr_Q) = N_Reference
- and then
- Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
- then
- Build_Master_Entity (Def_Id);
- end if;
- end if;
- end if;
- end Ensure_Activation_Chain_And_Master;
-
------------------------------
-- Expand_Freeze_Array_Type --
------------------------------
-- value, it may be possible to build an equivalent aggregate instead,
-- and prevent an actual call to the initialization procedure.
+ function Build_Heap_Or_Pool_Allocator
+ (Temp_Id : Entity_Id;
+ Temp_Typ : Entity_Id;
+ Func_Id : Entity_Id;
+ Ret_Typ : Entity_Id;
+ Alloc_Expr : Node_Id) return Node_Id;
+ -- Create the statements necessary to allocate a return object on the
+ -- heap or user-defined storage pool. The object may need finalization
+ -- actions depending on the return type.
+ --
+ -- * Controlled case
+ --
+ -- if BIPfinalizationmaster = null then
+ -- Temp_Id := <Alloc_Expr>;
+ -- else
+ -- declare
+ -- type Ptr_Typ is access Ret_Typ;
+ -- for Ptr_Typ'Storage_Pool use
+ -- Base_Pool (BIPfinalizationmaster.all).all;
+ -- Local : Ptr_Typ;
+ --
+ -- begin
+ -- procedure Allocate (...) is
+ -- begin
+ -- System.Storage_Pools.Subpools.Allocate_Any (...);
+ -- end Allocate;
+ --
+ -- Local := <Alloc_Expr>;
+ -- Temp_Id := Temp_Typ (Local);
+ -- end;
+ -- end if;
+ --
+ -- * Non-controlled case
+ --
+ -- Temp_Id := <Alloc_Expr>;
+ --
+ -- Temp_Id is the temporary which is used to reference the internally
+ -- created object in all allocation forms. Temp_Typ is the type of the
+ -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
+ -- type of Func_Id. Alloc_Expr is the actual allocator.
+
procedure Count_Default_Sized_Task_Stacks
(Typ : Entity_Id;
Pri_Stacks : out Int;
end if;
end Build_Equivalent_Aggregate;
+ ----------------------------------
+ -- Build_Heap_Or_Pool_Allocator --
+ ----------------------------------
+
+ function Build_Heap_Or_Pool_Allocator
+ (Temp_Id : Entity_Id;
+ Temp_Typ : Entity_Id;
+ Func_Id : Entity_Id;
+ Ret_Typ : Entity_Id;
+ Alloc_Expr : Node_Id) return Node_Id
+ is
+ begin
+ pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
+ -- Processing for objects that require finalization actions
+
+ if Needs_Finalization (Ret_Typ) then
+ declare
+ Decls : constant List_Id := New_List;
+ Fin_Mas_Id : constant Entity_Id :=
+ Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
+ Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
+ Stmts : constant List_Id := New_List;
+ Local_Id : Entity_Id;
+ Pool_Id : Entity_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ -- Generate:
+ -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
+
+ Pool_Id := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
+ Parameter_Associations => New_List (
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
+
+ -- Create an access type which uses the storage pool of the
+ -- caller's master. This additional type is necessary because
+ -- the finalization master cannot be associated with the type
+ -- of the temporary. Otherwise the secondary stack allocation
+ -- will fail.
+
+ -- Generate:
+ -- type Ptr_Typ is access Ret_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Typ, Loc))));
+
+ -- Perform minor decoration in order to set the master and the
+ -- storage pool attributes.
+
+ Mutate_Ekind (Ptr_Typ, E_Access_Type);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
+ Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
+
+ -- Create the temporary, generate:
+ -- Local_Id : Ptr_Typ;
+
+ Local_Id := Make_Temporary (Loc, 'T');
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ptr_Typ, Loc)));
+
+ -- Allocate the object, generate:
+ -- Local_Id := <Alloc_Expr>;
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Local_Id, Loc),
+ Expression => Alloc_Expr));
+
+ -- Generate:
+ -- Temp_Id := Temp_Typ (Local_Id);
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression =>
+ Unchecked_Convert_To (Temp_Typ,
+ New_Occurrence_Of (Local_Id, Loc))));
+
+ -- Wrap the allocation in a block. This is further conditioned
+ -- by checking the caller finalization master at runtime. A
+ -- null value indicates a non-existent master, most likely due
+ -- to a Finalize_Storage_Only allocation.
+
+ -- Generate:
+ -- if BIPfinalizationmaster = null then
+ -- Temp_Id := <Orig_Expr>;
+ -- else
+ -- declare
+ -- <Decls>
+ -- begin
+ -- <Stmts>
+ -- end;
+ -- end if;
+
+ return
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
+ Right_Opnd => Make_Null (Loc)),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression => Orig_Expr)),
+
+ Else_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts))));
+ end;
+
+ -- For all other cases, generate:
+ -- Temp_Id := <Alloc_Expr>;
+
+ else
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression => Alloc_Expr);
+ end if;
+ end Build_Heap_Or_Pool_Allocator;
+
-------------------------------------
-- Count_Default_Sized_Task_Stacks --
-------------------------------------
-- also that a Master variable is established (and that the appropriate
-- enclosing construct is established as a task master).
- Ensure_Activation_Chain_And_Master (N);
+ if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
+ Build_Activation_Chain_Entity (N);
+
+ if Has_Task (Typ) then
+ Build_Master_Entity (Def_Id);
+
+ -- Handle objects initialized with BIP function calls
+
+ elsif Present (Expr) then
+ Expr_Q := Unqualify (Expr);
+
+ if Is_Build_In_Place_Function_Call (Expr_Q)
+ or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ or else (Nkind (Expr_Q) = N_Reference
+ and then
+ Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
+ then
+ Build_Master_Entity (Def_Id);
+ end if;
+ end if;
+ end if;
-- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
-- restrictions are active then default-sized secondary stacks are
-- Default initialization required, and no expression present
if No (Expr) then
+ Expr_Q := Expr;
-- If we have a type with a variant part, the initialization proc
-- will contain implicit tests of the discriminant values, which
end if;
end if;
- Default_Initialize_Object (Init_After);
+ if not Is_Build_In_Place_Return_Object (Def_Id) then
+ Default_Initialize_Object (Init_After);
+ end if;
-- Generate attribute for Persistent_BSS if needed
Expander_Mode_Restore;
end if;
- Convert_Aggr_In_Object_Decl (N);
+ if not Is_Build_In_Place_Return_Object (Def_Id) then
+ Convert_Aggr_In_Object_Decl (N);
+ end if;
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the declared object
then
pragma Assert (Is_Class_Wide_Type (Typ));
- -- If the object is a return object of an inherently limited type,
- -- which implies build-in-place treatment, bypass the special
+ -- If the object is a built-in-place return object, bypass special
-- treatment of class-wide interface initialization below. In this
-- case, the expansion of the return statement will take care of
-- creating the object (via allocator) and initializing it.
- if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
+ if Is_Build_In_Place_Return_Object (Def_Id) then
null;
elsif Tagged_Type_Expansion then
Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI);
end;
end;
- end if;
- return;
+ return;
+
+ else
+ return;
+ end if;
-- Common case of explicit object initialization
Name => New_Occurrence_Of (Def_Id, Loc),
Expression => Relocate_Node (Expr));
begin
- Set_Expression (N, Empty);
- Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
Set_No_Ctrl_Actions (Stat);
- Insert_After_And_Analyze (Init_After, Stat);
+ Insert_Action_After (Init_After, Stat);
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
end;
end if;
end if;
end;
end if;
+ -- If this is the return object of a build-in-place function, locate the
+ -- implicit BIPaccess parameter designating the caller-supplied return
+ -- object and convert the declaration to a renaming of a dereference of
+ -- this parameter. If the declaration includes an expression, add an
+ -- assignment statement to ensure the return object gets initialized.
+
+ -- Result : T [:= <expression>];
+
+ -- is converted to
+
+ -- Result : T renames BIPaccess.all;
+ -- [Result := <expression>;]
+
+ -- in the constrained case, or to
+
+ -- type Txx is access all ...;
+ -- Rxx : Txx := null;
+
+ -- if BIPalloc = 1 then
+ -- Rxx := BIPaccess;
+ -- elsif BIPalloc = 2 then
+ -- Rxx := new <expression-type>[storage_pool =
+ -- system__secondary_stack__ss_pool][procedure_to_call =
+ -- system__secondary_stack__ss_allocate];
+ -- elsif BIPalloc = 3 then
+ -- Rxx := new <expression-type>
+ -- elsif BIPalloc = 4 then
+ -- Pxx : system__storage_pools__root_storage_pool renames
+ -- BIPstoragepool.all;
+ -- Rxx := new <expression-type>[storage_pool =
+ -- Pxx][procedure_to_call =
+ -- system__storage_pools__allocate_any];
+ -- else
+ -- [program_error "build in place mismatch"]
+ -- end if;
+
+ -- Result : T renames Rxx.all;
+ -- Result := <expression>;
+
+ -- in the unconstrained case.
+
+ if Is_Build_In_Place_Return_Object (Def_Id) then
+ declare
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Scope (Def_Id));
+ Ret_Obj_Typ : constant Entity_Id := Etype (Def_Id);
+
+ Init_Stmt : Node_Id;
+ Obj_Acc_Formal : Entity_Id;
+
+ begin
+ -- Retrieve the implicit access parameter passed by the caller
+
+ Obj_Acc_Formal :=
+ Build_In_Place_Formal (Func_Id, BIP_Object_Access);
+
+ -- If the return object's declaration includes an expression
+ -- and the declaration isn't marked as No_Initialization, then
+ -- we need to generate an assignment to the object and insert
+ -- it after the declaration before rewriting it as a renaming
+ -- (otherwise we'll lose the initialization). The case where
+ -- the result type is an interface (or class-wide interface)
+ -- is also excluded because the context of the function call
+ -- must be unconstrained, so the initialization will always
+ -- be done as part of an allocator evaluation (storage pool
+ -- or secondary stack), never to a constrained target object
+ -- passed in by the caller. Besides the assignment being
+ -- unneeded in this case, it avoids problems with trying to
+ -- generate a dispatching assignment when the return expression
+ -- is a nonlimited descendant of a limited interface (the
+ -- interface has no assignment operation).
+
+ if Present (Expr_Q)
+ and then not Is_Delayed_Aggregate (Expr_Q)
+ and then not No_Initialization (N)
+ and then not Is_Interface (Etype (Def_Id))
+ then
+ if Is_Class_Wide_Type (Etype (Def_Id))
+ and then not Is_Class_Wide_Type (Etype (Expr_Q))
+ then
+ Init_Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Def_Id), Loc),
+ Expression => New_Copy_Tree (Expr_Q)));
+
+ else
+ Init_Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression => New_Copy_Tree (Expr_Q));
+ end if;
+
+ Set_Assignment_OK (Name (Init_Stmt));
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ else
+ Init_Stmt := Empty;
+ end if;
+
+ -- When the function's subtype is unconstrained, a run-time
+ -- test may be needed to decide the form of allocation to use
+ -- for the return object. The function has an implicit formal
+ -- parameter indicating this. If the BIP_Alloc_Form formal has
+ -- the value one, then the caller has passed access to an
+ -- existing object for use as the return object. If the value
+ -- is two, then the return object must be allocated on the
+ -- secondary stack. Otherwise, the object must be allocated in
+ -- a storage pool. We generate an if statement to test the
+ -- implicit allocation formal and initialize a local access
+ -- value appropriately, creating allocators in the secondary
+ -- stack and global heap cases. The special formal also exists
+ -- and must be tested when the function has a tagged result,
+ -- even when the result subtype is constrained, because in
+ -- general such functions can be called in dispatching contexts
+ -- and must be handled similarly to functions with a class-wide
+ -- result.
+
+ if Needs_BIP_Alloc_Form (Func_Id) then
+ declare
+ Desig_Typ : constant Entity_Id :=
+ (if Ekind (Ret_Obj_Typ) = E_Array_Subtype
+ then Etype (Func_Id) else Ret_Obj_Typ);
+ -- Ensure that the we use a fat pointer when allocating
+ -- an unconstrained array on the heap. In this case the
+ -- result object type is a constrained array type even
+ -- though the function type is unconstrained.
+ Obj_Alloc_Formal : constant Entity_Id :=
+ Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
+ Pool_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'P');
+
+ Alloc_Obj_Id : Entity_Id;
+ Alloc_Obj_Decl : Node_Id;
+ Alloc_Stmt : Node_Id;
+ Guard_Except : Node_Id;
+ Heap_Allocator : Node_Id;
+ Pool_Decl : Node_Id;
+ Pool_Allocator : Node_Id;
+ Ptr_Type_Decl : Node_Id;
+ Ref_Type : Entity_Id;
+ SS_Allocator : Node_Id;
+
+ begin
+ -- Create an access type designating the function's
+ -- result subtype.
+
+ Ref_Type := Make_Temporary (Loc, 'A');
+
+ Ptr_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Desig_Typ, Loc)));
+
+ Insert_Action (N, Ptr_Type_Decl);
+
+ -- Create an access object that will be initialized to an
+ -- access value denoting the return object, either coming
+ -- from an implicit access value passed in by the caller
+ -- or from the result of an allocator.
+
+ Alloc_Obj_Id := Make_Temporary (Loc, 'R');
+ Set_Etype (Alloc_Obj_Id, Ref_Type);
+
+ Alloc_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alloc_Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ref_Type, Loc));
+
+ Insert_Action (N, Alloc_Obj_Decl);
+
+ -- Create allocators for both the secondary stack and
+ -- global heap. If there's an initialization expression,
+ -- then create these as initialized allocators.
+
+ if Present (Expr_Q)
+ and then not Is_Delayed_Aggregate (Expr_Q)
+ and then not No_Initialization (N)
+ then
+ -- Always use the type of the expression for the
+ -- qualified expression, rather than the result type.
+ -- In general we cannot always use the result type
+ -- for the allocator, because the expression might be
+ -- of a specific type, such as in the case of an
+ -- aggregate or even a nonlimited object when the
+ -- result type is a limited class-wide interface type.
+
+ Heap_Allocator :=
+ Make_Allocator (Loc,
+ Expression =>
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Expr_Q), Loc),
+ Expression => New_Copy_Tree (Expr_Q)));
+
+ else
+ -- If the function returns a class-wide type we cannot
+ -- use the return type for the allocator. Instead we
+ -- use the type of the expression, which must be an
+ -- aggregate of a definite type.
+
+ if Is_Class_Wide_Type (Ret_Obj_Typ) then
+ Heap_Allocator :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Etype (Expr_Q), Loc));
+
+ else
+ Heap_Allocator :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Ret_Obj_Typ, Loc));
+ end if;
+
+ -- If the object requires default initialization then
+ -- that will happen later following the elaboration of
+ -- the object renaming. If we don't turn it off here
+ -- then the object will be default initialized twice.
+
+ Set_No_Initialization (Heap_Allocator);
+ end if;
+
+ -- Set the flag indicating that the allocator came from
+ -- a build-in-place return statement, so we can avoid
+ -- adjusting the allocated object. Note that this flag
+ -- will be inherited by the copies made below.
+
+ Set_Alloc_For_BIP_Return (Heap_Allocator);
+
+ -- The Pool_Allocator is just like the Heap_Allocator,
+ -- except we set Storage_Pool and Procedure_To_Call so
+ -- it will use the user-defined storage pool.
+
+ Pool_Allocator := New_Copy_Tree (Heap_Allocator);
+
+ pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
+
+ -- Do not generate the renaming of the build-in-place
+ -- pool parameter on ZFP because the parameter is not
+ -- created in the first place.
+
+ if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+ Pool_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Func_Id, BIP_Storage_Pool), Loc)));
+ Set_Storage_Pool (Pool_Allocator, Pool_Id);
+ Set_Procedure_To_Call
+ (Pool_Allocator, RTE (RE_Allocate_Any));
+ else
+ Pool_Decl := Make_Null_Statement (Loc);
+ end if;
+
+ -- If the No_Allocators restriction is active, then only
+ -- an allocator for secondary stack allocation is needed.
+ -- It's OK for such allocators to have Comes_From_Source
+ -- set to False, because gigi knows not to flag them as
+ -- being a violation of No_Implicit_Heap_Allocations.
+
+ if Restriction_Active (No_Allocators) then
+ SS_Allocator := Heap_Allocator;
+ Heap_Allocator := Make_Null (Loc);
+ Pool_Allocator := Make_Null (Loc);
+
+ -- Otherwise the heap and pool allocators may be needed,
+ -- so we make another allocator for secondary stack
+ -- allocation.
+
+ else
+ SS_Allocator := New_Copy_Tree (Heap_Allocator);
+
+ pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
+
+ -- The heap and pool allocators are marked as
+ -- Comes_From_Source since they correspond to an
+ -- explicit user-written allocator (that is, it will
+ -- only be executed on behalf of callers that call the
+ -- function as initialization for such an allocator).
+ -- Prevents errors when No_Implicit_Heap_Allocations
+ -- is in force.
+
+ Set_Comes_From_Source (Heap_Allocator, True);
+ Set_Comes_From_Source (Pool_Allocator, True);
+ end if;
+
+ -- The allocator is returned on the secondary stack
+
+ Check_Restriction (No_Secondary_Stack, N);
+ Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
+ Set_Procedure_To_Call
+ (SS_Allocator, RTE (RE_SS_Allocate));
+
+ -- The allocator is returned on the secondary stack,
+ -- so indicate that the function return, as well as
+ -- all blocks that encloses the allocator, must not
+ -- release it. The flags must be set now because
+ -- the decision to use the secondary stack is done
+ -- very late in the course of expanding the return
+ -- statement, past the point where these flags are
+ -- normally set.
+
+ Set_Uses_Sec_Stack (Func_Id);
+ Set_Uses_Sec_Stack (Scope (Def_Id));
+ Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));
+
+ -- Guard against poor expansion on the caller side by
+ -- using a raise statement to catch out-of-range values
+ -- of formal parameter BIP_Alloc_Form.
+
+ if Exceptions_OK then
+ Guard_Except :=
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Build_In_Place_Mismatch);
+ else
+ Guard_Except := Make_Null_Statement (Loc);
+ end if;
+
+ -- Create an if statement to test the BIP_Alloc_Form
+ -- formal and initialize the access object to either the
+ -- BIP_Object_Access formal (BIP_Alloc_Form =
+ -- Caller_Allocation), the result of allocating the
+ -- object in the secondary stack (BIP_Alloc_Form =
+ -- Secondary_Stack), or else an allocator to create the
+ -- return object in the heap or user-defined pool
+ -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
+
+ -- ??? An unchecked type conversion must be made in the
+ -- case of assigning the access object formal to the
+ -- local access object, because a normal conversion would
+ -- be illegal in some cases (such as converting access-
+ -- to-unconstrained to access-to-constrained), but the
+ -- the unchecked conversion will presumably fail to work
+ -- right in just such cases. It's not clear at all how to
+ -- handle this. ???
+
+ Alloc_Stmt :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Caller_Allocation)))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Alloc_Obj_Id, Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
+
+ Elsif_Parts => New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Secondary_Stack)))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Alloc_Obj_Id, Loc),
+ Expression => SS_Allocator))),
+
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Global_Heap)))),
+
+ Then_Statements => New_List (
+ Build_Heap_Or_Pool_Allocator
+ (Temp_Id => Alloc_Obj_Id,
+ Temp_Typ => Ref_Type,
+ Func_Id => Func_Id,
+ Ret_Typ => Desig_Typ,
+ Alloc_Expr => Heap_Allocator))),
+
+ -- ???If all is well, we can put the following
+ -- 'elsif' in the 'else', but this is a useful
+ -- self-check in case caller and callee don't agree
+ -- on whether BIPAlloc and so on should be passed.
+
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (User_Storage_Pool)))),
+
+ Then_Statements => New_List (
+ Pool_Decl,
+ Build_Heap_Or_Pool_Allocator
+ (Temp_Id => Alloc_Obj_Id,
+ Temp_Typ => Ref_Type,
+ Func_Id => Func_Id,
+ Ret_Typ => Desig_Typ,
+ Alloc_Expr => Pool_Allocator)))),
+
+ -- Raise Program_Error if it's none of the above;
+ -- this is a compiler bug.
+
+ Else_Statements => New_List (Guard_Except));
+
+ -- If a separate initialization assignment was created
+ -- earlier, append that following the assignment of the
+ -- implicit access formal to the access object, to ensure
+ -- that the return object is initialized in that case. In
+ -- this situation, the target of the assignment must be
+ -- rewritten to denote a dereference of the access to the
+ -- return object passed in by the caller.
+
+ if Present (Init_Stmt) then
+ Set_Name (Init_Stmt,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
+ Set_Assignment_OK (Name (Init_Stmt));
+
+ Append_To (Then_Statements (Alloc_Stmt), Init_Stmt);
+ Init_Stmt := Empty;
+ end if;
+
+ Insert_Action (N, Alloc_Stmt, Suppress => All_Checks);
+
+ -- From now on, the type of the return object is the
+ -- designated type.
+
+ Set_Etype (Def_Id, Desig_Typ);
+
+ -- Remember the local access object for use in the
+ -- dereference of the renaming created below.
+
+ Obj_Acc_Formal := Alloc_Obj_Id;
+ end;
+
+ -- When the function's subtype is unconstrained and a run-time
+ -- test is not needed, we nevertheless need to build the return
+ -- using the function's result subtype.
+
+ elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then
+ declare
+ Alloc_Obj_Id : Entity_Id;
+ Alloc_Obj_Decl : Node_Id;
+ Ptr_Type_Decl : Node_Id;
+ Ref_Type : Entity_Id;
+
+ begin
+ -- Create an access type designating the function's
+ -- result subtype.
+
+ Ref_Type := Make_Temporary (Loc, 'A');
+
+ Ptr_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Obj_Typ, Loc)));
+
+ Insert_Action (N, Ptr_Type_Decl);
+
+ -- Create an access object initialized to the conversion
+ -- of the implicit access value passed in by the caller.
+
+ Alloc_Obj_Id := Make_Temporary (Loc, 'R');
+
+ -- See the ??? comment a few lines above about the use of
+ -- an unchecked conversion here.
+
+ Alloc_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alloc_Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ref_Type, Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)));
+
+ Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
+
+ -- Remember the local access object for use in the
+ -- dereference of the renaming created below.
+
+ Obj_Acc_Formal := Alloc_Obj_Id;
+ end;
+ end if;
+
+ -- Initialize the object now that it has got its final subtype,
+ -- but before rewriting it as a renaming.
+
+ if No (Expr_Q) then
+ Default_Initialize_Object (Init_After);
+
+ elsif Is_Delayed_Aggregate (Expr_Q)
+ and then not No_Initialization (N)
+ then
+ Convert_Aggr_In_Object_Decl (N);
+
+ elsif Present (Init_Stmt) then
+ Insert_Action_After (Init_After, Init_Stmt);
+ Set_Expression (N, Empty);
+ end if;
+
+ -- Replace the return object declaration with a renaming of a
+ -- dereference of the access value designating the return object.
+
+ Expr_Q :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
+ Set_Etype (Expr_Q, Etype (Def_Id));
+
+ Rewrite_As_Renaming := True;
+ end;
+ end if;
+
-- Final transformation - turn the object declaration into a renaming
-- if appropriate. If this is the completion of a deferred constant
-- declaration, then this transformation generates what would be
if Rewrite_As_Renaming then
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Defining_Identifier (N),
- Subtype_Mark => Obj_Def,
+ Defining_Identifier => Def_Id,
+ Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc),
Name => Expr_Q));
-- We do not analyze this renaming declaration, because all its
-- ahead and analyze it, we would in effect be trying to generate
-- another declaration of X, which won't do.
- Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+ Set_Renamed_Object (Def_Id, Expr_Q);
Set_Analyzed (N);
-- We do need to deal with debug issues for this renaming
-- Build the body of the equality function Body_Id for the untagged variant
-- record Typ with the given parameters specification list.
- procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id);
- -- If tasks are being declared (or might be declared) by the given object
- -- declaration then ensure to have an activation chain defined for the
- -- tasks (has no effect if we already have one), and also that a Master
- -- variable is established (and that the appropriate enclosing construct
- -- is established as a task master).
-
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted. We
-- (in which case default initial values might need to be set)).
procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- function Build_Heap_Or_Pool_Allocator
- (Temp_Id : Entity_Id;
- Temp_Typ : Entity_Id;
- Func_Id : Entity_Id;
- Ret_Typ : Entity_Id;
- Alloc_Expr : Node_Id) return Node_Id;
- -- Create the statements necessary to allocate a return object on the
- -- heap or user-defined storage pool. The object may need finalization
- -- actions depending on the return type.
- --
- -- * Controlled case
- --
- -- if BIPfinalizationmaster = null then
- -- Temp_Id := <Alloc_Expr>;
- -- else
- -- declare
- -- type Ptr_Typ is access Ret_Typ;
- -- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPfinalizationmaster.all).all;
- -- Local : Ptr_Typ;
- --
- -- begin
- -- procedure Allocate (...) is
- -- begin
- -- System.Storage_Pools.Subpools.Allocate_Any (...);
- -- end Allocate;
- --
- -- Local := <Alloc_Expr>;
- -- Temp_Id := Temp_Typ (Local);
- -- end;
- -- end if;
- --
- -- * Non-controlled case
- --
- -- Temp_Id := <Alloc_Expr>;
- --
- -- Temp_Id is the temporary which is used to reference the internally
- -- created object in all allocation forms. Temp_Typ is the type of the
- -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
- -- type of Func_Id. Alloc_Expr is the actual allocator.
+ Loc : constant Source_Ptr := Sloc (N);
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Return_Statement_Entity (N));
+ Is_BIP_Func : constant Boolean :=
+ Is_Build_In_Place_Function (Func_Id);
+ Ret_Obj_Id : constant Entity_Id :=
+ First_Entity (Return_Statement_Entity (N));
+ Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
+ Ret_Typ : constant Entity_Id := Etype (Func_Id);
function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
-- Construct a call to System.Tasking.Stages.Move_Activation_Chain
-- Func_Id is the entity of the function where the extended return
-- statement appears.
- ----------------------------------
- -- Build_Heap_Or_Pool_Allocator --
- ----------------------------------
-
- function Build_Heap_Or_Pool_Allocator
- (Temp_Id : Entity_Id;
- Temp_Typ : Entity_Id;
- Func_Id : Entity_Id;
- Ret_Typ : Entity_Id;
- Alloc_Expr : Node_Id) return Node_Id
- is
- begin
- pragma Assert (Is_Build_In_Place_Function (Func_Id));
-
- -- Processing for objects that require finalization actions
-
- if Needs_Finalization (Ret_Typ) then
- declare
- Decls : constant List_Id := New_List;
- Fin_Mas_Id : constant Entity_Id :=
- Build_In_Place_Formal
- (Func_Id, BIP_Finalization_Master);
- Orig_Expr : constant Node_Id :=
- New_Copy_Tree
- (Source => Alloc_Expr,
- Scopes_In_EWA_OK => True);
- Stmts : constant List_Id := New_List;
- Desig_Typ : Entity_Id;
- Local_Id : Entity_Id;
- Pool_Id : Entity_Id;
- Ptr_Typ : Entity_Id;
-
- begin
- -- Generate:
- -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
-
- Pool_Id := Make_Temporary (Loc, 'P');
-
- Append_To (Decls,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
-
- -- Create an access type which uses the storage pool of the
- -- caller's master. This additional type is necessary because
- -- the finalization master cannot be associated with the type
- -- of the temporary. Otherwise the secondary stack allocation
- -- will fail.
-
- Desig_Typ := Ret_Typ;
-
- -- Ensure that the build-in-place machinery uses a fat pointer
- -- when allocating an unconstrained array on the heap. In this
- -- case the result object type is a constrained array type even
- -- though the function type is unconstrained.
-
- if Ekind (Desig_Typ) = E_Array_Subtype then
- Desig_Typ := Base_Type (Desig_Typ);
- end if;
-
- -- Generate:
- -- type Ptr_Typ is access Desig_Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'P');
-
- Append_To (Decls,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Desig_Typ, Loc))));
-
- -- Perform minor decoration in order to set the master and the
- -- storage pool attributes.
-
- Mutate_Ekind (Ptr_Typ, E_Access_Type);
- Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
- Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-
- -- Create the temporary, generate:
- -- Local_Id : Ptr_Typ;
-
- Local_Id := Make_Temporary (Loc, 'T');
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Local_Id,
- Object_Definition =>
- New_Occurrence_Of (Ptr_Typ, Loc)));
-
- -- Allocate the object, generate:
- -- Local_Id := <Alloc_Expr>;
-
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Local_Id, Loc),
- Expression => Alloc_Expr));
-
- -- Generate:
- -- Temp_Id := Temp_Typ (Local_Id);
-
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression =>
- Unchecked_Convert_To (Temp_Typ,
- New_Occurrence_Of (Local_Id, Loc))));
-
- -- Wrap the allocation in a block. This is further conditioned
- -- by checking the caller finalization master at runtime. A
- -- null value indicates a non-existent master, most likely due
- -- to a Finalize_Storage_Only allocation.
-
- -- Generate:
- -- if BIPfinalizationmaster = null then
- -- Temp_Id := <Orig_Expr>;
- -- else
- -- declare
- -- <Decls>
- -- begin
- -- <Stmts>
- -- end;
- -- end if;
-
- return
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
- Right_Opnd => Make_Null (Loc)),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Orig_Expr)),
-
- Else_Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts))));
- end;
-
- -- For all other cases, generate:
- -- Temp_Id := <Alloc_Expr>;
-
- else
- return
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Alloc_Expr);
- end if;
- end Build_Heap_Or_Pool_Allocator;
-
---------------------------
-- Move_Activation_Chain --
---------------------------
-- Local variables
- Func_Id : constant Entity_Id :=
- Return_Applies_To (Return_Statement_Entity (N));
- Is_BIP_Func : constant Boolean :=
- Is_Build_In_Place_Function (Func_Id);
- Ret_Obj_Id : constant Entity_Id :=
- First_Entity (Return_Statement_Entity (N));
- Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
- Ret_Typ : constant Entity_Id := Etype (Func_Id);
-
Exp : Node_Id;
HSS : Node_Id;
Result : Node_Id;
end;
end if;
- -- Build a simple_return_statement that returns the return object
-
- Return_Stmt :=
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
- Append_To (Stmts, Return_Stmt);
-
HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
end if;
Set_Identifier
(Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
- -- If the object decl was already rewritten as a renaming, then we
- -- don't want to do the object allocation and transformation of
- -- the return object declaration to a renaming. This case occurs
- -- when the return object is initialized by a call to another
- -- build-in-place function, and that function is responsible for
- -- the allocation of the return object.
-
- if Is_BIP_Func
- and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
- then
- pragma Assert
- (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
- and then
-
- -- It is a regular BIP object declaration
-
- (Is_Build_In_Place_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl)))
-
- -- It is a BIP object declaration that displaces the pointer
- -- to the object to reference a converted interface type.
-
- or else
- Present (Unqual_BIP_Iface_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl))))));
-
- elsif Is_BIP_Func then
-
- -- Locate the implicit access parameter associated with the
- -- caller-supplied return object and convert the return
- -- statement's return object declaration to a renaming of a
- -- dereference of the access parameter. If the return object's
- -- declaration includes an expression that has not already been
- -- expanded as separate assignments, then add an assignment
- -- statement to ensure the return object gets initialized.
-
- -- declare
- -- Result : T [:= <expression>];
- -- begin
- -- ...
-
- -- is converted to
-
- -- declare
- -- Result : T renames FuncRA.all;
- -- [Result := <expression;]
- -- begin
- -- ...
-
- declare
- Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
- Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
-
- Init_Assignment : Node_Id := Empty;
- Obj_Acc_Formal : Entity_Id;
- Obj_Acc_Deref : Node_Id;
- Obj_Alloc_Formal : Entity_Id;
-
- begin
- -- Retrieve the implicit access parameter passed by the caller
-
- Obj_Acc_Formal :=
- Build_In_Place_Formal (Func_Id, BIP_Object_Access);
-
- -- If the return object's declaration includes an expression
- -- and the declaration isn't marked as No_Initialization, then
- -- we need to generate an assignment to the object and insert
- -- it after the declaration before rewriting it as a renaming
- -- (otherwise we'll lose the initialization). The case where
- -- the result type is an interface (or class-wide interface)
- -- is also excluded because the context of the function call
- -- must be unconstrained, so the initialization will always
- -- be done as part of an allocator evaluation (storage pool
- -- or secondary stack), never to a constrained target object
- -- passed in by the caller. Besides the assignment being
- -- unneeded in this case, it avoids problems with trying to
- -- generate a dispatching assignment when the return expression
- -- is a nonlimited descendant of a limited interface (the
- -- interface has no assignment operation).
-
- if Present (Ret_Obj_Expr)
- and then not No_Initialization (Ret_Obj_Decl)
- and then not Is_Interface (Ret_Obj_Typ)
- then
- Init_Assignment :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
- Expression =>
- New_Copy_Tree
- (Source => Ret_Obj_Expr,
- Scopes_In_EWA_OK => True));
-
- Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
- Set_Assignment_OK (Name (Init_Assignment));
- Set_No_Ctrl_Actions (Init_Assignment);
-
- Set_Parent (Name (Init_Assignment), Init_Assignment);
- Set_Parent (Expression (Init_Assignment), Init_Assignment);
-
- Set_Expression (Ret_Obj_Decl, Empty);
-
- if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
- and then not Is_Class_Wide_Type
- (Etype (Expression (Init_Assignment)))
- then
- Rewrite (Expression (Init_Assignment),
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
- Expression =>
- Relocate_Node (Expression (Init_Assignment))));
- end if;
-
- -- In the case of functions where the calling context can
- -- determine the form of allocation needed, initialization
- -- is done with each part of the if statement that handles
- -- the different forms of allocation (this is true for
- -- unconstrained, tagged, and controlled result subtypes).
-
- if not Needs_BIP_Alloc_Form (Func_Id) then
- Insert_After (Ret_Obj_Decl, Init_Assignment);
- end if;
- end if;
-
- -- When the function's subtype is unconstrained, a run-time
- -- test may be needed to decide the form of allocation to use
- -- for the return object. The function has an implicit formal
- -- parameter indicating this. If the BIP_Alloc_Form formal has
- -- the value one, then the caller has passed access to an
- -- existing object for use as the return object. If the value
- -- is two, then the return object must be allocated on the
- -- secondary stack. Otherwise, the object must be allocated in
- -- a storage pool. We generate an if statement to test the
- -- implicit allocation formal and initialize a local access
- -- value appropriately, creating allocators in the secondary
- -- stack and global heap cases. The special formal also exists
- -- and must be tested when the function has a tagged result,
- -- even when the result subtype is constrained, because in
- -- general such functions can be called in dispatching contexts
- -- and must be handled similarly to functions with a class-wide
- -- result.
-
- if Needs_BIP_Alloc_Form (Func_Id) then
- Obj_Alloc_Formal :=
- Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
-
- declare
- Pool_Id : constant Entity_Id :=
- Make_Temporary (Loc, 'P');
- Alloc_Obj_Id : Entity_Id;
- Alloc_Obj_Decl : Node_Id;
- Alloc_If_Stmt : Node_Id;
- Guard_Except : Node_Id;
- Heap_Allocator : Node_Id;
- Pool_Decl : Node_Id;
- Pool_Allocator : Node_Id;
- Ptr_Type_Decl : Node_Id;
- Ref_Type : Entity_Id;
- SS_Allocator : Node_Id;
-
- begin
- -- Create an access type designating the function's
- -- result subtype.
-
- Ref_Type := Make_Temporary (Loc, 'A');
-
- Ptr_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
-
- -- Create an access object that will be initialized to an
- -- access value denoting the return object, either coming
- -- from an implicit access value passed in by the caller
- -- or from the result of an allocator.
-
- Alloc_Obj_Id := Make_Temporary (Loc, 'R');
- Set_Etype (Alloc_Obj_Id, Ref_Type);
-
- Alloc_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Alloc_Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Ref_Type, Loc));
-
- Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
-
- -- Create allocators for both the secondary stack and
- -- global heap. If there's an initialization expression,
- -- then create these as initialized allocators.
-
- if Present (Ret_Obj_Expr)
- and then not No_Initialization (Ret_Obj_Decl)
- then
- -- Always use the type of the expression for the
- -- qualified expression, rather than the result type.
- -- In general we cannot always use the result type
- -- for the allocator, because the expression might be
- -- of a specific type, such as in the case of an
- -- aggregate or even a nonlimited object when the
- -- result type is a limited class-wide interface type.
-
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype (Ret_Obj_Expr), Loc),
- Expression =>
- New_Copy_Tree
- (Source => Ret_Obj_Expr,
- Scopes_In_EWA_OK => True)));
-
- else
- -- If the function returns a class-wide type we cannot
- -- use the return type for the allocator. Instead we
- -- use the type of the expression, which must be an
- -- aggregate of a definite type.
-
- if Is_Class_Wide_Type (Ret_Obj_Typ) then
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of
- (Etype (Ret_Obj_Expr), Loc));
- else
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc));
- end if;
-
- -- If the object requires default initialization then
- -- that will happen later following the elaboration of
- -- the object renaming. If we don't turn it off here
- -- then the object will be default initialized twice.
-
- Set_No_Initialization (Heap_Allocator);
- end if;
-
- -- Set the flag indicating that the allocator came from
- -- a build-in-place return statement, so we can avoid
- -- adjusting the allocated object. Note that this flag
- -- will be inherited by the copies made below.
-
- Set_Alloc_For_BIP_Return (Heap_Allocator);
-
- -- The Pool_Allocator is just like the Heap_Allocator,
- -- except we set Storage_Pool and Procedure_To_Call so
- -- it will use the user-defined storage pool.
-
- Pool_Allocator :=
- New_Copy_Tree
- (Source => Heap_Allocator,
- Scopes_In_EWA_OK => True);
-
- pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
-
- -- Do not generate the renaming of the build-in-place
- -- pool parameter on ZFP because the parameter is not
- -- created in the first place.
-
- if RTE_Available (RE_Root_Storage_Pool_Ptr) then
- Pool_Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of
- (Build_In_Place_Formal
- (Func_Id, BIP_Storage_Pool), Loc)));
- Set_Storage_Pool (Pool_Allocator, Pool_Id);
- Set_Procedure_To_Call
- (Pool_Allocator, RTE (RE_Allocate_Any));
- else
- Pool_Decl := Make_Null_Statement (Loc);
- end if;
-
- -- If the No_Allocators restriction is active, then only
- -- an allocator for secondary stack allocation is needed.
- -- It's OK for such allocators to have Comes_From_Source
- -- set to False, because gigi knows not to flag them as
- -- being a violation of No_Implicit_Heap_Allocations.
-
- if Restriction_Active (No_Allocators) then
- SS_Allocator := Heap_Allocator;
- Heap_Allocator := Make_Null (Loc);
- Pool_Allocator := Make_Null (Loc);
-
- -- Otherwise the heap and pool allocators may be needed,
- -- so we make another allocator for secondary stack
- -- allocation.
-
- else
- SS_Allocator :=
- New_Copy_Tree
- (Source => Heap_Allocator,
- Scopes_In_EWA_OK => True);
-
- pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
-
- -- The heap and pool allocators are marked as
- -- Comes_From_Source since they correspond to an
- -- explicit user-written allocator (that is, it will
- -- only be executed on behalf of callers that call the
- -- function as initialization for such an allocator).
- -- Prevents errors when No_Implicit_Heap_Allocations
- -- is in force.
-
- Set_Comes_From_Source (Heap_Allocator, True);
- Set_Comes_From_Source (Pool_Allocator, True);
- end if;
-
- -- The allocator is returned on the secondary stack
-
- Check_Restriction (No_Secondary_Stack, N);
- Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
- Set_Procedure_To_Call
- (SS_Allocator, RTE (RE_SS_Allocate));
-
- -- The allocator is returned on the secondary stack,
- -- so indicate that the function return, as well as
- -- all blocks that encloses the allocator, must not
- -- release it. The flags must be set now because
- -- the decision to use the secondary stack is done
- -- very late in the course of expanding the return
- -- statement, past the point where these flags are
- -- normally set.
-
- Set_Uses_Sec_Stack (Func_Id);
- Set_Uses_Sec_Stack (Return_Statement_Entity (N));
- Set_Sec_Stack_Needed_For_Return
- (Return_Statement_Entity (N));
- Set_Enclosing_Sec_Stack_Return (N);
-
- -- Guard against poor expansion on the caller side by
- -- using a raise statement to catch out-of-range values
- -- of formal parameter BIP_Alloc_Form.
-
- if Exceptions_OK then
- Guard_Except :=
- Make_Raise_Program_Error (Loc,
- Reason => PE_Build_In_Place_Mismatch);
- else
- Guard_Except := Make_Null_Statement (Loc);
- end if;
-
- -- Create an if statement to test the BIP_Alloc_Form
- -- formal and initialize the access object to either the
- -- BIP_Object_Access formal (BIP_Alloc_Form =
- -- Caller_Allocation), the result of allocating the
- -- object in the secondary stack (BIP_Alloc_Form =
- -- Secondary_Stack), or else an allocator to create the
- -- return object in the heap or user-defined pool
- -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
-
- -- ??? An unchecked type conversion must be made in the
- -- case of assigning the access object formal to the
- -- local access object, because a normal conversion would
- -- be illegal in some cases (such as converting access-
- -- to-unconstrained to access-to-constrained), but the
- -- the unchecked conversion will presumably fail to work
- -- right in just such cases. It's not clear at all how to
- -- handle this. ???
-
- Alloc_If_Stmt :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Caller_Allocation)))),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Alloc_Obj_Id, Loc),
- Expression =>
- Unchecked_Convert_To
- (Ref_Type,
- New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
-
- Elsif_Parts => New_List (
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Secondary_Stack)))),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Alloc_Obj_Id, Loc),
- Expression => SS_Allocator))),
-
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Global_Heap)))),
-
- Then_Statements => New_List (
- Build_Heap_Or_Pool_Allocator
- (Temp_Id => Alloc_Obj_Id,
- Temp_Typ => Ref_Type,
- Func_Id => Func_Id,
- Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Heap_Allocator))),
-
- -- ???If all is well, we can put the following
- -- 'elsif' in the 'else', but this is a useful
- -- self-check in case caller and callee don't agree
- -- on whether BIPAlloc and so on should be passed.
-
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (User_Storage_Pool)))),
-
- Then_Statements => New_List (
- Pool_Decl,
- Build_Heap_Or_Pool_Allocator
- (Temp_Id => Alloc_Obj_Id,
- Temp_Typ => Ref_Type,
- Func_Id => Func_Id,
- Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Pool_Allocator)))),
-
- -- Raise Program_Error if it's none of the above;
- -- this is a compiler bug.
-
- Else_Statements => New_List (Guard_Except));
-
- -- If a separate initialization assignment was created
- -- earlier, append that following the assignment of the
- -- implicit access formal to the access object, to ensure
- -- that the return object is initialized in that case. In
- -- this situation, the target of the assignment must be
- -- rewritten to denote a dereference of the access to the
- -- return object passed in by the caller.
-
- if Present (Init_Assignment) then
- Rewrite (Name (Init_Assignment),
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
- pragma Assert
- (Assignment_OK
- (Original_Node (Name (Init_Assignment))));
- Set_Assignment_OK (Name (Init_Assignment));
-
- Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
-
- Append_To
- (Then_Statements (Alloc_If_Stmt), Init_Assignment);
- end if;
-
- Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
-
- -- Remember the local access object for use in the
- -- dereference of the renaming created below.
-
- Obj_Acc_Formal := Alloc_Obj_Id;
- end;
-
- -- When the function's subtype is unconstrained and a run-time
- -- test is not needed, we nevertheless need to build the return
- -- using the function's result subtype.
-
- elsif not Is_Constrained (Underlying_Type (Etype (Func_Id)))
- then
- declare
- Alloc_Obj_Id : Entity_Id;
- Alloc_Obj_Decl : Node_Id;
- Ptr_Type_Decl : Node_Id;
- Ref_Type : Entity_Id;
-
- begin
- -- Create an access type designating the function's
- -- result subtype.
-
- Ref_Type := Make_Temporary (Loc, 'A');
-
- Ptr_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
-
- -- Create an access object initialized to the conversion
- -- of the implicit access value passed in by the caller.
-
- Alloc_Obj_Id := Make_Temporary (Loc, 'R');
- Set_Etype (Alloc_Obj_Id, Ref_Type);
-
- -- See the ??? comment a few lines above about the use of
- -- an unchecked conversion here.
-
- Alloc_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Alloc_Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Ref_Type, Loc),
- Expression =>
- Unchecked_Convert_To
- (Ref_Type,
- New_Occurrence_Of (Obj_Acc_Formal, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
-
- -- Remember the local access object for use in the
- -- dereference of the renaming created below.
-
- Obj_Acc_Formal := Alloc_Obj_Id;
- end;
- end if;
-
- -- Replace the return object declaration with a renaming of a
- -- dereference of the access value designating the return
- -- object.
-
- Obj_Acc_Deref :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
-
- Rewrite (Ret_Obj_Decl,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Ret_Obj_Id,
- Access_Definition => Empty,
- Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
- Name => Obj_Acc_Deref));
+ -- Build a simple_return_statement that returns the return object
- Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
- end;
- end if;
+ Return_Stmt :=
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
+ Append_To (Stmts, Return_Stmt);
-- Case where we do not need to build a block. But we're about to drop
-- Return_Object_Declarations on the floor, so assert that it contains
-- before an object is returned. A predicate that applies to the return
-- subtype is checked immediately before an object is returned.
- -- Suppress access checks to avoid generating extra checks for b-i-p.
-
- Analyze (N, Suppress => Access_Check);
+ Analyze (N);
end Expand_N_Extended_Return_Statement;
----------------------------
end if;
end Install_Class_Preconditions_Check;
- -----------------------------------
- -- Is_Build_In_Place_Result_Type --
- -----------------------------------
-
- function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
- begin
- if not Expander_Active then
- return False;
- end if;
-
- -- In Ada 2005 all functions with an inherently limited return type
- -- must be handled using a build-in-place profile, including the case
- -- of a function with a limited interface result, where the function
- -- may return objects of nonlimited descendants.
-
- return Is_Limited_View (Typ)
- and then Ada_Version >= Ada_2005
- and then not Debug_Flag_Dot_L;
- end Is_Build_In_Place_Result_Type;
-
------------------------------
-- Is_Build_In_Place_Entity --
------------------------------
end;
end Is_Build_In_Place_Function_Call;
+ -----------------------------------
+ -- Is_Build_In_Place_Result_Type --
+ -----------------------------------
+
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if not Expander_Active then
+ return False;
+ end if;
+
+ -- In Ada 2005 all functions with an inherently limited return type
+ -- must be handled using a build-in-place profile, including the case
+ -- of a function with a limited interface result, where the function
+ -- may return objects of nonlimited descendants.
+
+ return Is_Limited_View (Typ)
+ and then Ada_Version >= Ada_2005
+ and then not Debug_Flag_Dot_L;
+ end Is_Build_In_Place_Result_Type;
+
+ -------------------------------------
+ -- Is_Build_In_Place_Return_Object --
+ -------------------------------------
+
+ function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean is
+ begin
+ return Is_Return_Object (E)
+ and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E)));
+ end Is_Build_In_Place_Return_Object;
+
-----------------------
-- Is_Null_Procedure --
-----------------------
function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
- function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
- -- Ada 2005 (AI-318-02): Returns True if functions returning the type use
- -- build-in-place protocols. For inherently limited types, this must be
- -- True in >= Ada 2005, and must be False in Ada 95. For other types, it
- -- can be True or False, and the decision should be based on efficiency,
- -- and should be the same for all language versions, so that mixed-dialect
- -- programs will work.
- --
- -- For inherently limited types in Ada 2005, True means that calls will
- -- actually be build-in-place in all cases. For other types, build-in-place
- -- will be used when possible, but we need to make a copy in some
- -- cases. For example, for "X := F(...);" if F can see X, or if F can
- -- propagate exceptions, we need to store its result in a temp in general,
- -- and copy the temp into X. Also, for "return Global_Var;" Global_Var
- -- needs to be copied into the function result object.
-
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- function, or access-to-function type for which
-- that requires handling as a build-in-place call (possibly qualified or
-- converted).
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if functions returning the type use
+ -- build-in-place protocols. For inherently limited types, this must be
+ -- True in >= Ada 2005 and must be False in Ada 95.
+
+ function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Return True is E is a return object of a function
+ -- that uses build-in-place protocols.
+
function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
-- Predicate to recognize stubbed procedures and null procedures, which
-- can be inlined unconditionally in all cases.
-- to reference the secondary dispatch table of an interface; otherwise
-- return Empty.
+private
+ pragma Inline (Is_Build_In_Place_Return_Object);
+
end Exp_Ch6;
-- of the formal of Proc, or force a conversion to the class-wide type in
-- the case where the operation is abstract.
- function Enclosing_Function (E : Entity_Id) return Entity_Id;
- -- Given an arbitrary entity, traverse the scope chain looking for the
- -- first enclosing function. Return Empty if no function was found.
-
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
if Is_Return_Object (Obj_Id) then
declare
- Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Scope (Obj_Id));
+
begin
if Is_Build_In_Place_Function (Func_Id)
and then Needs_BIP_Finalization_Master (Func_Id)
end if;
end Convert_View;
- ------------------------
- -- Enclosing_Function --
- ------------------------
-
- function Enclosing_Function (E : Entity_Id) return Entity_Id is
- Func_Id : Entity_Id;
-
- begin
- Func_Id := E;
- while Present (Func_Id) and then Func_Id /= Standard_Standard loop
- if Ekind (Func_Id) = E_Function then
- return Func_Id;
- end if;
-
- Func_Id := Scope (Func_Id);
- end loop;
-
- return Empty;
- end Enclosing_Function;
-
-------------------------------
-- Establish_Transient_Scope --
-------------------------------
Prev_Entity : Entity_Id := Empty;
Related_Id : Entity_Id;
- Full_View_Present : Boolean := False;
-- Start of processing for Analyze_Object_Declaration
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
- -- Propagate attributes to full view when needed
+ if Act_T /= T then
+ declare
+ Full_View_Present : constant Boolean :=
+ Is_Private_Type (Act_T)
+ and then Present (Full_View (Act_T));
+ -- Propagate attributes to full view when needed
- Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+ begin
+ Set_Is_Constr_Subt_For_U_Nominal (Act_T);
- if Is_Private_Type (Act_T) and then Present (Full_View (Act_T))
- then
- Full_View_Present := True;
- end if;
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T));
+ end if;
- if Full_View_Present then
- Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T));
- end if;
+ if Aliased_Present (N) then
+ Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
- if Aliased_Present (N) then
- Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T));
+ end if;
+ end if;
- if Full_View_Present then
- Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T));
- end if;
+ Freeze_Before (N, Act_T);
+ end;
end if;
- Freeze_Before (N, Act_T);
Freeze_Before (N, T);
end if;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
-with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
-- object declaration.
Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
-
- -- Returning a build-in-place unconstrained array type we defer
- -- the full analysis of the returned object to avoid generating
- -- the corresponding constrained subtype; otherwise the bounds
- -- would be created in the stack and a dangling reference would
- -- be returned pointing to the bounds. We perform its preanalysis
- -- to report errors on the initializing aggregate now (if any);
- -- we also ensure its activation chain and Master variable are
- -- defined (if tasks are being declared) since they are generated
- -- as part of the analysis and expansion of the object declaration
- -- at this stage.
-
- if Is_Array_Type (R_Type)
- and then not Is_Constrained (R_Type)
- and then Is_Build_In_Place_Function (Scope_Id)
- and then Needs_BIP_Alloc_Form (Scope_Id)
- and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
- then
- Preanalyze (Obj_Decl);
-
- if Expander_Active then
- Ensure_Activation_Chain_And_Master (Obj_Decl);
- end if;
-
- else
- Analyze (Obj_Decl);
- end if;
+ Analyze (Obj_Decl);
Check_Return_Subtype_Indication (Obj_Decl);
-- Force the definition of the Itype in case of internal function
-- calls within the same or nested scope.
- if Is_Subprogram_Or_Generic_Subprogram (E) then
+ if Is_Subprogram_Or_Generic_Subprogram (E)
+ and then not Is_Compilation_Unit (E)
+ then
Subp_Decl := Parent (E);
-- The insertion point for an Itype reference should be after
projects / platform / upstream / gcc.git / commitdiff