-- 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 (currently only supported for the global
- -- heap, user-defined storage pools TBD ???). 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.
+ -- 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 not Is_Constrained (Ret_Typ)
or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
(Obj_Decl : Node_Id;
Function_Call : Node_Id)
is
+ function Get_Function_Id (Func_Call : Node_Id) return Entity_Id;
+ -- Get the value of Function_Id, below
+
+ function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is
+ begin
+ if Is_Entity_Name (Name (Func_Call)) then
+ return Entity (Name (Func_Call));
+
+ elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
+ return Etype (Name (Func_Call));
+
+ else
+ raise Program_Error;
+ end if;
+ end Get_Function_Id;
+
+ Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
+ Function_Id : constant Entity_Id := Get_Function_Id (Func_Call);
+ Result_Subt : constant Entity_Id := Etype (Function_Id);
+
Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
+ Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id);
Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
Loc : constant Source_Ptr := Sloc (Function_Call);
Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
Caller_Object : Node_Id;
Def_Id : Entity_Id;
Fmaster_Actual : Node_Id := Empty;
- Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
- Function_Id : Entity_Id;
Pool_Actual : Node_Id;
Designated_Type : Entity_Id;
Ptr_Typ : Entity_Id;
Ptr_Typ_Decl : Node_Id;
Pass_Caller_Acc : Boolean := False;
Res_Decl : Node_Id;
- Result_Subt : Entity_Id;
+
+ Definite : constant Boolean :=
+ Caller_Known_Size (Func_Call, Result_Subt)
+ and then not Is_Class_Wide_Type (Obj_Typ);
+ -- In the case of "X : T'Class := F(...);", where F returns a
+ -- Caller_Known_Size (specific) tagged type, we treat it as
+ -- indefinite, because the code for the Definite case below sets the
+ -- initialization expression of the object to Empty, which would be
+ -- illegal Ada, and would cause gigi to mis-allocate X.
begin
-- Mark the call as processed as a build-in-place call
pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
- if Is_Entity_Name (Name (Func_Call)) then
- Function_Id := Entity (Name (Func_Call));
+ -- Create an access type designating the function's result subtype.
+ -- We use the type of the original call because it may be a call to an
+ -- inherited operation, which the expansion has replaced with the parent
+ -- operation that yields the parent type. Note that this access type
+ -- must be declared before we establish a transient scope, so that it
+ -- receives the proper accessibility level.
- elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then
- Function_Id := Etype (Name (Func_Call));
+ if Is_Class_Wide_Type (Obj_Typ)
+ and then not Is_Interface (Obj_Typ)
+ and then not Is_Class_Wide_Type (Etype (Function_Call))
+ then
+ Designated_Type := Obj_Typ;
+ else
+ Designated_Type := Etype (Function_Call);
+ end if;
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+ Ptr_Typ_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 (Designated_Type, Loc)));
+
+ -- The access type and its accompanying object must be inserted after
+ -- the object declaration in the constrained case, so that the function
+ -- call can be passed access to the object. In the indefinite case, or
+ -- if the object declaration is for a return object, the access type and
+ -- object must be inserted before the object, since the object
+ -- declaration is rewritten to be a renaming of a dereference of the
+ -- access object. Note: we need to freeze Ptr_Typ explicitly, because
+ -- the result object is in a different (transient) scope, so won't cause
+ -- freezing.
+
+ if Definite
+ and then not Is_Return_Object (Obj_Def_Id)
+ then
+ Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
else
- raise Program_Error;
+ Insert_Action (Obj_Decl, Ptr_Typ_Decl);
end if;
- Result_Subt := Etype (Function_Id);
+ -- Force immediate freezing of Ptr_Typ because Res_Decl will be
+ -- elaborated in an inner (transient) scope and thus won't cause
+ -- freezing by itself. It's not an itype, but it needs to be frozen
+ -- inside the current subprogram (see Freeze_Outside in freeze.adb).
+
+ Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
+
+ -- If the object is a return object of an enclosing build-in-place
+ -- function, then the implicit build-in-place parameters of the
+ -- enclosing function are simply passed along to the called function.
+ -- (Unfortunately, this won't cover the case of extension aggregates
+ -- where the ancestor part is a build-in-place indefinite function
+ -- call that should be passed along the caller's parameters.
+ -- Currently those get mishandled by reassigning the result of the
+ -- call to the aggregate return object, when the call result should
+ -- really be directly built in place in the aggregate and not in a
+ -- temporary. ???)
+
+ if Is_Return_Object (Obj_Def_Id) then
+ Pass_Caller_Acc := True;
+
+ -- When the enclosing function has a BIP_Alloc_Form formal then we
+ -- pass it along to the callee (such as when the enclosing
+ -- function has an unconstrained or tagged result type).
+
+ if Needs_BIP_Alloc_Form (Encl_Func) then
+ if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+ Pool_Actual :=
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Encl_Func, BIP_Storage_Pool), Loc);
- declare
- Definite : constant Boolean :=
- Caller_Known_Size (Func_Call, Result_Subt);
+ -- The build-in-place pool formal is not built on e.g. ZFP
- begin
- -- Create an access type designating the function's result subtype.
- -- We use the type of the original call because it may be a call to
- -- an inherited operation, which the expansion has replaced with the
- -- parent operation that yields the parent type. Note that this
- -- access type must be declared before we establish a transient
- -- scope, so that it receives the proper accessibility level.
-
- if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl)))
- and then not Is_Interface (Etype (Defining_Identifier (Obj_Decl)))
- and then not Is_Class_Wide_Type (Etype (Function_Call))
- then
- Designated_Type := Etype (Defining_Identifier (Obj_Decl));
- else
- Designated_Type := Etype (Function_Call);
- end if;
+ else
+ Pool_Actual := Empty;
+ end if;
+
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Function_Call => Func_Call,
+ Function_Id => Function_Id,
+ Alloc_Form_Exp =>
+ New_Occurrence_Of
+ (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
+ Pool_Actual => Pool_Actual);
+
+ -- Otherwise, if enclosing function has a definite result subtype,
+ -- then caller allocation will be used.
- Ptr_Typ := Make_Temporary (Loc, 'A');
- Ptr_Typ_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 (Designated_Type, Loc)));
-
- -- The access type and its accompanying object must be inserted after
- -- the object declaration in the constrained case, so that the
- -- function call can be passed access to the object. In the
- -- indefinite case, or if the object declaration is for a return
- -- object, the access type and object must be inserted before the
- -- object, since the object declaration is rewritten to be a renaming
- -- of a dereference of the access object. Note: we need to freeze
- -- Ptr_Typ explicitly, because the result object is in a different
- -- (transient) scope, so won't cause freezing.
-
- if Definite
- and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
- then
- Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
else
- Insert_Action (Obj_Decl, Ptr_Typ_Decl);
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if;
- -- Force immediate freezing of Ptr_Typ because Res_Decl will be
- -- elaborated in an inner (transient) scope and thus won't cause
- -- freezing by itself. It's not an itype, but it needs to be frozen
- -- inside the current subprogram (see Freeze_Outside in freeze.adb).
-
- Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
+ if Needs_BIP_Finalization_Master (Encl_Func) then
+ Fmaster_Actual :=
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Encl_Func, BIP_Finalization_Master), Loc);
+ end if;
- -- If the object is a return object of an enclosing build-in-place
- -- function, then the implicit build-in-place parameters of the
- -- enclosing function are simply passed along to the called function.
- -- (Unfortunately, this won't cover the case of extension aggregates
- -- where the ancestor part is a build-in-place indefinite function
- -- call that should be passed along the caller's parameters.
- -- Currently those get mishandled by reassigning the result of the
- -- call to the aggregate return object, when the call result should
- -- really be directly built in place in the aggregate and not in a
- -- temporary. ???)
+ -- Retrieve the BIPacc formal from the enclosing function and convert
+ -- it to the access type of the callee's BIP_Object_Access formal.
- if Is_Return_Object (Defining_Identifier (Obj_Decl)) then
- Pass_Caller_Acc := True;
+ Caller_Object :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Etype
+ (Build_In_Place_Formal
+ (Function_Id, BIP_Object_Access)),
+ Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
+ Loc));
- -- When the enclosing function has a BIP_Alloc_Form formal then we
- -- pass it along to the callee (such as when the enclosing
- -- function has an unconstrained or tagged result type).
+ -- In the definite case, add an implicit actual to the function call
+ -- that provides access to the declared object. An unchecked conversion
+ -- to the (specific) result type of the function is inserted to handle
+ -- the case where the object is declared with a class-wide type.
- if Needs_BIP_Alloc_Form (Encl_Func) then
- if RTE_Available (RE_Root_Storage_Pool_Ptr) then
- Pool_Actual :=
- New_Occurrence_Of
- (Build_In_Place_Formal
- (Encl_Func, BIP_Storage_Pool), Loc);
+ elsif Definite then
+ Caller_Object :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
+ Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
- -- The build-in-place pool formal is not built on e.g. ZFP
+ -- When the function has a controlling result, an allocation-form
+ -- parameter must be passed indicating that the caller is allocating
+ -- the result object. This is needed because such a function can be
+ -- called as a dispatching operation and must be treated similarly to
+ -- functions with indefinite result subtypes.
- else
- Pool_Actual := Empty;
- end if;
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Function_Call => Func_Call,
- Function_Id => Function_Id,
- Alloc_Form_Exp =>
- New_Occurrence_Of
- (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
- Pool_Actual => Pool_Actual);
+ -- The allocation for indefinite library-level objects occurs on the
+ -- heap as opposed to the secondary stack. This accommodates DLLs where
+ -- the secondary stack is destroyed after each library unload. This is a
+ -- hybrid mechanism where a stack-allocated object lives on the heap.
- -- Otherwise, if enclosing function has a definite result subtype,
- -- then caller allocation will be used.
+ elsif Is_Library_Level_Entity (Obj_Def_Id)
+ and then not Restriction_Active (No_Implicit_Heap_Allocations)
+ then
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Global_Heap);
+ Caller_Object := Empty;
- else
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- end if;
+ -- Create a finalization master for the access result type to ensure
+ -- that the heap allocation can properly chain the object and later
+ -- finalize it when the library unit goes out of scope.
- if Needs_BIP_Finalization_Master (Encl_Func) then
- Fmaster_Actual :=
- New_Occurrence_Of
- (Build_In_Place_Formal
- (Encl_Func, BIP_Finalization_Master), Loc);
- end if;
+ if Needs_Finalization (Etype (Func_Call)) then
+ Build_Finalization_Master
+ (Typ => Ptr_Typ,
+ For_Lib_Level => True,
+ Insertion_Node => Ptr_Typ_Decl);
- -- Retrieve the BIPacc formal from the enclosing function and
- -- convert it to the access type of the callee's BIP_Object_Access
- -- formal.
-
- Caller_Object :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype
- (Build_In_Place_Formal
- (Function_Id, BIP_Object_Access)),
- Loc),
- Expression =>
- New_Occurrence_Of
- (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
- Loc));
-
- -- In the definite case, add an implicit actual to the function call
- -- that provides access to the declared object. An unchecked
- -- conversion to the (specific) result type of the function is
- -- inserted to handle the case where the object is declared with a
- -- class-wide type.
-
- elsif Definite then
- Caller_Object :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
- Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
-
- -- When the function has a controlling result, an allocation-form
- -- parameter must be passed indicating that the caller is
- -- allocating the result object. This is needed because such a
- -- function can be called as a dispatching operation and must be
- -- treated similarly to functions with indefinite result subtypes.
+ Fmaster_Actual :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+ -- In other indefinite cases, pass an indication to do the allocation on
+ -- the secondary stack and set Caller_Object to Empty so that a null
+ -- value will be passed for the caller's object address. A transient
+ -- scope is established to ensure eventual cleanup of the result.
- -- The allocation for indefinite library-level objects occurs on the
- -- heap as opposed to the secondary stack. This accommodates DLLs
- -- where the secondary stack is destroyed after each library
- -- unload. This is a hybrid mechanism where a stack-allocated object
- -- lives on the heap.
+ else
+ Add_Unconstrained_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
+ Caller_Object := Empty;
- elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl))
- and then not Restriction_Active (No_Implicit_Heap_Allocations)
- then
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Global_Heap);
- Caller_Object := Empty;
+ Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
+ end if;
- -- Create a finalization master for the access result type to
- -- ensure that the heap allocation can properly chain the object
- -- and later finalize it when the library unit goes out of scope.
+ -- Pass along any finalization master actual, which is needed in the
+ -- case where the called function initializes a return object of an
+ -- enclosing build-in-place function.
- if Needs_Finalization (Etype (Func_Call)) then
- Build_Finalization_Master
- (Typ => Ptr_Typ,
- For_Lib_Level => True,
- Insertion_Node => Ptr_Typ_Decl);
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
+ (Func_Call => Func_Call,
+ Func_Id => Function_Id,
+ Master_Exp => Fmaster_Actual);
- Fmaster_Actual :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
+ if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
+ and then Has_Task (Result_Subt)
+ then
+ -- Here we're passing along the master that was passed in to this
+ -- function.
- -- In other indefinite cases, pass an indication to do the allocation
- -- on the secondary stack and set Caller_Object to Empty so that a
- -- null value will be passed for the caller's object address. A
- -- transient scope is established to ensure eventual cleanup of the
- -- result.
+ Add_Task_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id,
+ Master_Actual =>
+ New_Occurrence_Of
+ (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
- else
- Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
- Caller_Object := Empty;
+ else
+ Add_Task_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+ end if;
- Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
- end if;
+ Add_Access_Actual_To_Build_In_Place_Call
+ (Func_Call,
+ Function_Id,
+ Caller_Object,
+ Is_Access => Pass_Caller_Acc);
- -- Pass along any finalization master actual, which is needed in the
- -- case where the called function initializes a return object of an
- -- enclosing build-in-place function.
+ -- Finally, create an access object initialized to a reference to the
+ -- function call. We know this access value cannot be null, so mark the
+ -- entity accordingly to suppress the access check.
- Add_Finalization_Master_Actual_To_Build_In_Place_Call
- (Func_Call => Func_Call,
- Func_Id => Function_Id,
- Master_Exp => Fmaster_Actual);
+ Def_Id := Make_Temporary (Loc, 'R', Func_Call);
+ Set_Etype (Def_Id, Ptr_Typ);
+ Set_Is_Known_Non_Null (Def_Id);
- if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement
- and then Has_Task (Result_Subt)
- then
- -- Here we're passing along the master that was passed in to this
- -- function.
+ if Nkind (Function_Call) = N_Type_Conversion then
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Ptr_Typ, Loc),
+ Make_Reference (Loc, Relocate_Node (Func_Call))));
+ else
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, Relocate_Node (Func_Call)));
+ end if;
- Add_Task_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id,
- Master_Actual =>
- New_Occurrence_Of
- (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
+ Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
- else
- Add_Task_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
- end if;
+ -- If the result subtype of the called function is definite and is not
+ -- itself the return expression of an enclosing BIP function, then mark
+ -- the object as having no initialization.
- Add_Access_Actual_To_Build_In_Place_Call
- (Func_Call,
- Function_Id,
- Caller_Object,
- Is_Access => Pass_Caller_Acc);
+ if Definite
+ and then not Is_Return_Object (Obj_Def_Id)
+ then
+ -- The related object declaration is encased in a transient block
+ -- because the build-in-place function call contains at least one
+ -- nested function call that produces a controlled transient
+ -- temporary:
- -- Finally, create an access object initialized to a reference to the
- -- function call. We know this access value cannot be null, so mark
- -- the entity accordingly to suppress the access check.
+ -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
- Def_Id := Make_Temporary (Loc, 'R', Func_Call);
- Set_Etype (Def_Id, Ptr_Typ);
- Set_Is_Known_Non_Null (Def_Id);
+ -- Since the build-in-place expansion decouples the call from the
+ -- object declaration, the finalization machinery lacks the context
+ -- which prompted the generation of the transient block. To resolve
+ -- this scenario, store the build-in-place call.
- if Nkind (Function_Call) = N_Type_Conversion then
- Res_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- New_Occurrence_Of (Ptr_Typ, Loc),
- Make_Reference (Loc, Relocate_Node (Func_Call))));
- else
- Res_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression =>
- Make_Reference (Loc, Relocate_Node (Func_Call)));
+ if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
+ Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
end if;
- Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
-
- -- If the result subtype of the called function is definite and is
- -- not itself the return expression of an enclosing BIP function,
- -- then mark the object as having no initialization.
-
- if Definite
- and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
- then
- -- The related object declaration is encased in a transient block
- -- because the build-in-place function call contains at least one
- -- nested function call that produces a controlled transient
- -- temporary:
-
- -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call);
-
- -- Since the build-in-place expansion decouples the call from the
- -- object declaration, the finalization machinery lacks the
- -- context which prompted the generation of the transient
- -- block. To resolve this scenario, store the build-in-place call.
-
- if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
- Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
- end if;
-
- Set_Expression (Obj_Decl, Empty);
- Set_No_Initialization (Obj_Decl);
-
- -- In case of an indefinite result subtype, or if the call is the
- -- return expression of an enclosing BIP function, rewrite the object
- -- declaration as an object renaming where the renamed object is a
- -- dereference of <function_Call>'reference:
- --
- -- Obj : Subt renames <function_call>'Ref.all;
+ Set_Expression (Obj_Decl, Empty);
+ Set_No_Initialization (Obj_Decl);
- else
- Call_Deref :=
- Make_Explicit_Dereference (Obj_Loc,
- Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
-
- Rewrite (Obj_Decl,
- Make_Object_Renaming_Declaration (Obj_Loc,
- Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
- Subtype_Mark =>
- New_Occurrence_Of (Designated_Type, Obj_Loc),
- Name => Call_Deref));
-
- Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
-
- -- If the original entity comes from source, then mark the new
- -- entity as needing debug information, even though it's defined
- -- by a generated renaming that does not come from source, so that
- -- the Materialize_Entity flag will be set on the entity when
- -- Debug_Renaming_Declaration is called during analysis.
-
- if Comes_From_Source (Obj_Def_Id) then
- Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
- end if;
+ -- In case of an indefinite result subtype, or if the call is the
+ -- return expression of an enclosing BIP function, rewrite the object
+ -- declaration as an object renaming where the renamed object is a
+ -- dereference of <function_Call>'reference:
+ --
+ -- Obj : Subt renames <function_call>'Ref.all;
- Analyze (Obj_Decl);
- Replace_Renaming_Declaration_Id
- (Obj_Decl, Original_Node (Obj_Decl));
+ else
+ Call_Deref :=
+ Make_Explicit_Dereference (Obj_Loc,
+ Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
+
+ Rewrite (Obj_Decl,
+ Make_Object_Renaming_Declaration (Obj_Loc,
+ Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
+ Subtype_Mark =>
+ New_Occurrence_Of (Designated_Type, Obj_Loc),
+ Name => Call_Deref));
+
+ Set_Renamed_Object (Obj_Def_Id, Call_Deref);
+
+ -- If the original entity comes from source, then mark the new
+ -- entity as needing debug information, even though it's defined
+ -- by a generated renaming that does not come from source, so that
+ -- the Materialize_Entity flag will be set on the entity when
+ -- Debug_Renaming_Declaration is called during analysis.
+
+ if Comes_From_Source (Obj_Def_Id) then
+ Set_Debug_Info_Needed (Obj_Def_Id);
end if;
- end;
-
- -- If the object entity has a class-wide Etype, then we need to change
- -- it to the result subtype of the function call, because otherwise the
- -- object will be class-wide without an explicit initialization and
- -- won't be allocated properly by the back end. It seems unclean to make
- -- such a revision to the type at this point, and we should try to
- -- improve this treatment when build-in-place functions with class-wide
- -- results are implemented. ???
- if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then
- Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt);
+ Analyze (Obj_Decl);
+ Replace_Renaming_Declaration_Id
+ (Obj_Decl, Original_Node (Obj_Decl));
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
with Exp_Ch6; use Exp_Ch6;
with Exp_CG; use Exp_CG;
and then not Is_CPP_Class (Root_Typ);
end Building_Static_DT;
+ ----------------------------------
+ -- Building_Static_Secondary_DT --
+ ----------------------------------
+
+ function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
+ Full_Typ : Entity_Id := Typ;
+ Root_Typ : Entity_Id := Root_Type (Typ);
+
+ begin
+ -- Handle private types
+
+ if Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+ end if;
+
+ if Present (Full_View (Root_Typ)) then
+ Root_Typ := Full_View (Root_Typ);
+ end if;
+
+ return Building_Static_DT (Full_Typ)
+ and then not Is_Interface (Full_Typ)
+ and then Has_Interfaces (Full_Typ)
+ and then (Full_Typ = Root_Typ
+ or else not Is_Variable_Size_Record (Etype (Full_Typ)));
+ end Building_Static_Secondary_DT;
+
----------------------------------
-- Build_Static_Dispatch_Tables --
----------------------------------
if From_Limited_With (Actual_Typ) then
- -- If the type of the actual parameter comes from a
- -- limited with-clause and the non-limited view is already
- -- available, we replace the anonymous access type by
- -- a duplicate declaration whose designated type is the
- -- non-limited view.
+ -- If the type of the actual parameter comes from a limited
+ -- with_clause and the nonlimited view is already available,
+ -- we replace the anonymous access type by a duplicate
+ -- declaration whose designated type is the nonlimited view.
if Has_Non_Limited_View (Actual_DDT) then
Anon := New_Copy (Actual_Typ);
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
+ Dummy_Object : Entity_Id := Empty;
+ -- Extra nonexistent object of type Typ internally used to compute the
+ -- offset to the components that reference secondary dispatch tables.
+ -- Used to statically allocate secondary dispatch tables.
+
procedure Check_Premature_Freezing
(Subp : Entity_Id;
Tagged_Type : Entity_Id;
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Iface_Comp : Node_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Iface_Comp : Node_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
Prefix => New_Occurrence_Of (Predef_Prims, Loc),
Attribute_Name => Name_Address));
- -- Note: The correct value of Offset_To_Top will be set by the init
- -- subprogram
+ -- If the location of the component that references this secondary
+ -- dispatch table is variable then we have not declared the internal
+ -- dummy object; the value of Offset_To_Top will be set by the init
+ -- subprogram.
- Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+ if No (Dummy_Object) then
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+
+ else
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Dummy_Object, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Comp, Loc)),
+ Attribute_Name => Name_Position));
+ end if;
-- Generate the Object Specific Data table required to dispatch calls
-- through synchronized interfaces.
Append_Elmt (New_Node, DT_Aggr);
- -- Note: Secondary dispatch tables cannot be declared constant
- -- because the component Offset_To_Top is currently initialized
- -- by the IP routine.
+ -- Note: Secondary dispatch tables are declared constant only if
+ -- we can compute their offset field by means of the extra dummy
+ -- object; otherwise they cannot be declared constant and the
+ -- Offset_To_Top component is initialized by the IP routine.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT,
Aliased_Present => True,
- Constant_Present => False,
+ Constant_Present => Present (Dummy_Object),
Object_Definition =>
Make_Subtype_Indication (Loc,
end;
end if;
+ if Building_Static_Secondary_DT (Typ) then
+ declare
+ Cannot_Have_Null_Disc : Boolean := False;
+ Name_Dummy_Object : constant Name_Id :=
+ New_External_Name (Tname,
+ 'P', Suffix_Index => -1);
+ begin
+ Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object);
+
+ -- Define the extra object imported and constant to avoid linker
+ -- errors (since this object is never declared). Required because
+ -- we implement RM 13.3(19) for exported and imported (variable)
+ -- objects by making them volatile.
+
+ Set_Is_Imported (Dummy_Object);
+ Set_Ekind (Dummy_Object, E_Constant);
+ Set_Is_True_Constant (Dummy_Object);
+ Set_Related_Type (Dummy_Object, Typ);
+
+ -- The scope must be set now to call Get_External_Name
+
+ Set_Scope (Dummy_Object, Current_Scope);
+
+ Get_External_Name (Dummy_Object);
+ Set_Interface_Name (Dummy_Object,
+ Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
+
+ -- Ensure proper Sprint output of this implicit importation
+
+ Set_Is_Internal (Dummy_Object);
+
+ if not Has_Discriminants (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dummy_Object,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc)));
+ else
+ declare
+ Constr_List : constant List_Id := New_List;
+ Discrim : Node_Id;
+
+ begin
+ Discrim := First_Discriminant (Typ);
+ while Present (Discrim) loop
+ if Is_Discrete_Type (Etype (Discrim)) then
+ Append_To (Constr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Etype (Discrim), Loc),
+ Attribute_Name => Name_First));
+
+ else
+ pragma Assert (Is_Access_Type (Etype (Discrim)));
+ Cannot_Have_Null_Disc :=
+ Cannot_Have_Null_Disc
+ or else Can_Never_Be_Null (Etype (Discrim));
+ Append_To (Constr_List, Make_Null (Loc));
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dummy_Object,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constr_List))));
+ end;
+ end if;
+
+ -- Given that the dummy object will not be declared at run time,
+ -- analyze its declaration with expansion disabled and warnings
+ -- and error messages ignored.
+
+ Expander_Mode_Save_And_Set (False);
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ Analyze (Last (Result), Suppress => All_Checks);
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ Expander_Mode_Restore;
+ end;
+ end if;
+
-- Ada 2005 (AI-251): Build the secondary dispatch tables
if Has_Interfaces (Typ) then
(Typ => Typ,
Iface => Base_Type
(Related_Type (Node (AI_Tag_Comp))),
+ Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => Suffix_Index,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
(Typ => Typ,
Iface => Base_Type
(Related_Type (Node (AI_Tag_Comp))),
+ Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => -1,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
git://gcc.gnu.org / gcc.git / commitdiff