Skip to content

R
riscv-gcc-1
Commit f937473f by Robert Dewar Committed by Arnaud Charlet
Options

einfo.ads, einfo.adb: (First_Component_Or_Discriminant): New function 

2007-04-06  Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>

	* einfo.ads, einfo.adb: (First_Component_Or_Discriminant): New function
	(Next_Component_Or_Discriminant): New function and procedure
	(First_Index, First_Literal, Master_Id,
	Set_First_Index, Set_First_Literal, Set_Master_Id):
	Add missing Ekind assertions.
	(Is_Access_Protected_Subprogram_Type): New predicate.
	(Has_RACW): New entity flag, set on package entities to indicate that
	the package contains the declaration of a remote accecss-to-classwide
	type.
	(E_Return_Statement): This node type has the Finalization_Chain_Entity
	attribute, in case the result type has controlled parts.
	(Requires_Overriding): Add this new flag, because "requires
	overriding" is subtly different from "is abstract" (see AI-228).
	(Is_Abstract): Split Is_Abstract flag into Is_Abstract_Subprogram and
	Is_Abstract_Type. Make sure these are called only when appropriate.
	(Has_Pragma_Unreferenced_Objects): New flag

	* exp_ch5.adb (Expand_N_Assignment_Statement): If the left-hand side is
	class-wide, the tag of the right-hand side must be an exact match, not
	an ancestor of that of the object on left-hand side.
	(Move_Activation_Chain): New procedure to create the call to
	System.Tasking.Stages.Move_Activation_Chain.
	(Expand_N_Extended_Return_Statement): Generate code to call
	System.Finalization_Implementation.Move_Final_List at the end of a
	return statement if the function's result type has controlled parts.
	Move asserts to Build_In_Place_Formal.
	(Move_Final_List): New function to create the call statement.
	(Expand_N_Assignment_Statement): In case of assignment to a class-wide
	tagged type, replace generation of call to the run-time subprogram
	CW_Membership by call to Build_CW_Membership.
	(Expand_N_Return_Statement): Replace generation of call to the run-time
	subprogram Get_Access_Level by call to Build_Get_Access_Level.
	(Expand_N_Simple_Function_Return): Replace generation of call to the
	run-time subprogram Get_Access_Level by call to Build_Get_Access_Level.

	* exp_ch6.ads, exp_ch6.adb (Expand_Call): Use new predicate
	Is_Access_Protected_Subprogram_Type, to handle both named and anonymous
	access to protected operations.
	(Add_Task_Actuals_To_Build_In_Place_Call): New procedure to add the
	master and chain actual parameters to a build-in-place function call
	involving tasks.
	(BIP_Formal_Suffix): Add new enumeration literals to complete the case
	statement.
	(Make_Build_In_Place_Call_In_Allocator,
	Make_Build_In_Place_Call_In_Anonymous_Context,
	Make_Build_In_Place_Call_In_Assignment,
	Make_Build_In_Place_Call_In_Object_Declaration): Call
	Add_Task_Actuals_To_Build_In_Place_Call with the appropriate master.
	(Expand_Inlined_Call): If the subprogram is a null procedure, or a
	stubbed procedure with a null body, replace the call with a null
	statement without using the full inlining machinery, for efficiency
	and to avoid invalid values in source file table entries.

	* exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Add support for
	renamings of calls to build-in-place functions.

	* rtsfind.adb (RTE_Record_Component_Available): New subprogram that
	provides the functionality of RTE_Available to record components.
	(RTU_Entity): The function Entity has been renamed to RTU_Entity
	to avoid undesired overloading.
	(Entity): New subprogram that returns the entity for the referened
	unit. If this unit has not been loaded, it returns Empty.
	(RE_Activation_Chain_Access, RE_Move_Activation_Chain): New entities.
	Remove no longer used entities.
	(RE_Finalizable_Ptr_Ptr, RE_Move_Final_List): New entities.
	(RE_Type_Specific_Data): New entity.
	(RE_Move_Any_Value): New entity.
	(RE_TA_A, RE_Get_Any_Type): New entities.
	(RE_Access_Level, RE_Dispatch_Table, E_Default_Prim_Op_Count,
	 RE_Prims_Ptr, RE_RC_Offset, RE_Remotely_Callable,
	 RE_DT_Typeinfo_Ptr_Size, RE_Cstring_Ptr, RE_DT_Expanded_Name): Added.
	(Entity): New subprogram that returns the entity for the referened
	unit. If this unit has not been loaded, it returns Empty.
	(RTE): Addition of a new formal that extends the search to the scopes
	of the record types found in the chain of the package.

	* sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Print
	"abstract subprograms must be visible" message, whether or not the type
	is an interface; that is, remove the special case for interface types.
	(Analyze_Function_Return): Remove error message "return of task objects
	is not yet implemented" because this is now implemented.
	(Create_Extra_Formals): Add the extra master and activation chain
	formals in case the result type has tasks.
	Remove error message "return of limited controlled objects is not yet
	implemented".
	(Create_Extra_Formals): Add the extra caller's finalization list formal
	in case the result type has controlled parts.
	(Process_Formals): In case of access formal types there is no need
	to continue with the analysis of the formals if we already notified
	errors.
	(Check_Overriding_Indicator): Add code to check overriding of predefined
	operators.
	(Create_Extra_Formals): Prevent creation of useless Extra_Constrained
	flags for formals that do not require them,.
	(Enter_Overloaded_Entity): Do not give -gnatwh warning message unless
	hidden entity is use visible or directly visible.
	(Analyze_Abstract_Subprogram_Declaration,Analyze_Subprogram_Body,
	Analyze_Subprogram_Declaration,Analyze_Subprogram_Specification,
	Check_Conventions,Check_Delayed_Subprogram,Make_Inequality_Operator,
	New_Overloaded_Entity): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type.

	* s-finimp.ads, s-finimp.adb (Move_Final_List): New procedure to move
	a return statement's finalization list to the caller's list, used for
	build-in-place functions with result type with controlled parts.
	Remove no longer used entities.

	* s-taskin.ads (Activation_Chain): Remove pragma Volatile. It is no
	longer needed, because the full type is now limited, and therefore a
	pass-by-reference type.
	(Foreign_Task_Level): New constant.

	* s-tassta.ads, s-tassta.adb (Move_Activation_Chain): New procedure to
	move tasks from the activation chain belonging to a return statement to
	the one passed in by the caller, and update the master to the one
	passed in by the caller.
	(Vulnerable_Complete_Master, Check_Unactivated_Tasks): Check the master
	of unactivated tasks, so we don't kill the ones that are being returned
	by a build-in-place function.
	(Create_Task): Ignore AI-280 for foreign threads.

From-SVN: r123558
parent 9dac0a42
Showing with 1979 additions and 1261 deletions
gcc/ada/einfo.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/einfo.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_ch5.adb
...@@ -29,6 +29,7 @@ with Checks; use Checks; ...@@ -29,6 +29,7 @@ with Checks; use Checks;
with Debug; use Debug; with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6; with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
...@@ -127,10 +128,6 @@ package body Exp_Ch5 is ...@@ -127,10 +128,6 @@ package body Exp_Ch5 is
-- pointers which are not 'part of the value' and must not be changed -- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node. -- upon assignment. N is the original Assignment node.
procedure No_Secondary_Stack_Case (N : Node_Id);
-- Obsolete code to deal with functions for which
-- Function_Returns_With_DSP is True.
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or -- This function is used in processing the assignment of a record or
-- indexed component. The argument N is either the left hand or right -- indexed component. The argument N is either the left hand or right
...@@ -1401,7 +1398,7 @@ package body Exp_Ch5 is ...@@ -1401,7 +1398,7 @@ package body Exp_Ch5 is
begin begin
-- Ada 2005 (AI-327): Handle assignment to priority of protected object -- Ada 2005 (AI-327): Handle assignment to priority of protected object
-- Rewrite an assignment to X'Priority into a run-time call. -- Rewrite an assignment to X'Priority into a run-time call
-- For example: X'Priority := New_Prio_Expr; -- For example: X'Priority := New_Prio_Expr;
-- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr); -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr);
...@@ -1759,7 +1756,7 @@ package body Exp_Ch5 is ...@@ -1759,7 +1756,7 @@ package body Exp_Ch5 is
-- Build-in-place function call case. Note that we're not yet doing -- Build-in-place function call case. Note that we're not yet doing
-- build-in-place for user-written assignment statements; the -- build-in-place for user-written assignment statements; the
-- assignment here came from can aggregate. -- assignment here came from an aggregate.
elsif Ada_Version >= Ada_05 elsif Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Rhs) and then Is_Build_In_Place_Function_Call (Rhs)
...@@ -1830,7 +1827,7 @@ package body Exp_Ch5 is ...@@ -1830,7 +1827,7 @@ package body Exp_Ch5 is
-- In case of assignment to a class-wide tagged type, before -- In case of assignment to a class-wide tagged type, before
-- the assignment we generate run-time check to ensure that -- the assignment we generate run-time check to ensure that
-- the tag of the Target is covered by the tag of the source -- the tags of source and target match.
if Is_Class_Wide_Type (Typ) if Is_Class_Wide_Type (Typ)
and then Is_Tagged_Type (Typ) and then Is_Tagged_Type (Typ)
...@@ -1839,21 +1836,19 @@ package body Exp_Ch5 is ...@@ -1839,21 +1836,19 @@ package body Exp_Ch5 is
Append_To (L, Append_To (L,
Make_Raise_Constraint_Error (Loc, Make_Raise_Constraint_Error (Loc,
Condition => Condition =>
Make_Op_Not (Loc, Make_Op_Ne (Loc,
Make_Function_Call (Loc, Left_Opnd =>
Name => New_Reference_To
(RTE (RE_CW_Membership), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix => Duplicate_Subexpr (Lhs),
Duplicate_Subexpr (Lhs),
Selector_Name => Selector_Name =>
Make_Identifier (Loc, Name_uTag)), Make_Identifier (Loc,
Chars => Name_uTag)),
Right_Opnd =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix => Duplicate_Subexpr (Rhs),
Duplicate_Subexpr (Rhs),
Selector_Name => Selector_Name =>
Make_Identifier (Loc, Name_uTag))))), Make_Identifier (Loc,
Chars => Name_uTag))),
Reason => CE_Tag_Check_Failed)); Reason => CE_Tag_Check_Failed));
end if; end if;
...@@ -1861,7 +1856,8 @@ package body Exp_Ch5 is ...@@ -1861,7 +1856,8 @@ package body Exp_Ch5 is
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Op, Loc), Name => New_Reference_To (Op, Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Unchecked_Convert_To (F_Typ, Duplicate_Subexpr (Lhs)), Unchecked_Convert_To (F_Typ,
Duplicate_Subexpr (Lhs)),
Unchecked_Convert_To (F_Typ, Unchecked_Convert_To (F_Typ,
Duplicate_Subexpr (Rhs))))); Duplicate_Subexpr (Rhs)))));
end; end;
...@@ -1872,8 +1868,8 @@ package body Exp_Ch5 is ...@@ -1872,8 +1868,8 @@ package body Exp_Ch5 is
-- We can't afford to have destructive Finalization Actions -- We can't afford to have destructive Finalization Actions
-- in the Self assignment case, so if the target and the -- in the Self assignment case, so if the target and the
-- source are not obviously different, code is generated to -- source are not obviously different, code is generated to
-- avoid the self assignment case -- avoid the self assignment case:
--
-- if lhs'address /= rhs'address then -- if lhs'address /= rhs'address then
-- <code for controlled and/or tagged assignment> -- <code for controlled and/or tagged assignment>
-- end if; -- end if;
...@@ -1901,7 +1897,7 @@ package body Exp_Ch5 is ...@@ -1901,7 +1897,7 @@ package body Exp_Ch5 is
-- We need to set up an exception handler for implementing -- We need to set up an exception handler for implementing
-- 7.6.1 (18). The remaining adjustments are tackled by the -- 7.6.1 (18). The remaining adjustments are tackled by the
-- implementation of adjust for record_controllers (see -- implementation of adjust for record_controllers (see
-- s-finimp.adb) -- s-finimp.adb).
-- This is skipped if we have no finalization -- This is skipped if we have no finalization
...@@ -1914,7 +1910,7 @@ package body Exp_Ch5 is ...@@ -1914,7 +1910,7 @@ package body Exp_Ch5 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => L, Statements => L,
Exception_Handlers => New_List ( Exception_Handlers => New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => Exception_Choices =>
New_List (Make_Others_Choice (Loc)), New_List (Make_Others_Choice (Loc)),
Statements => New_List ( Statements => New_List (
...@@ -1931,7 +1927,7 @@ package body Exp_Ch5 is ...@@ -1931,7 +1927,7 @@ package body Exp_Ch5 is
Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
-- If no restrictions on aborts, protect the whole assignement -- If no restrictions on aborts, protect the whole assignement
-- for controlled objects as per 9.8(11) -- for controlled objects as per 9.8(11).
if Controlled_Type (Typ) if Controlled_Type (Typ)
and then Expand_Ctrl_Actions and then Expand_Ctrl_Actions
...@@ -2366,61 +2362,6 @@ package body Exp_Ch5 is ...@@ -2366,61 +2362,6 @@ package body Exp_Ch5 is
-- initial values might need to be set). -- initial values might need to be set).
procedure Expand_N_Extended_Return_Statement (N : Node_Id) is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
function Is_Build_In_Place_Function (Fun : Entity_Id) return Boolean;
-- F must be of type E_Function or E_Generic_Function. Return True if it
-- uses build-in-place for the result object. In Ada 95, this must be
-- False for inherently limited result type. In Ada 2005, this must be
-- True for inherently limited result type. For other types, we have a
-- choice -- build-in-place is usually more efficient for large things,
-- and less efficient for small things. However, we had better not use
-- build-in-place if the Convention is other than Ada, because that
-- would disturb mixed-language programs.
--
-- Note that for the non-inherently-limited cases, we must make the same
-- decision for Ada 95 and 2005, so that mixed-dialect programs work.
--
-- ???This function will be needed when compiling the call sites;
-- we will have to move it to a more global place.
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
function Is_Build_In_Place_Function (Fun : Entity_Id) return Boolean is
R_Type : constant Entity_Id := Underlying_Type (Etype (Fun));
begin
-- First, the cases that matter for correctness
if Is_Inherently_Limited_Type (R_Type) then
return Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L;
-- Note: If you have Convention (C) on an inherently limited
-- type, you're on your own. That is, the C code will have to be
-- carefully written to know about the Ada conventions.
elsif
Has_Foreign_Convention (R_Type)
or else
Has_Foreign_Convention (Fun)
then
return False;
-- Second, the efficiency-related decisions. It would be obnoxiously
-- inefficient to use build-in-place for elementary types. For
-- composites, we could return False if the subtype is known to be
-- small (<= one or two words?) but we don't bother with that yet.
else
return Is_Composite_Type (R_Type);
end if;
end Is_Build_In_Place_Function;
------------------------
-- Local Declarations --
------------------------
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Return_Object_Entity : constant Entity_Id := Return_Object_Entity : constant Entity_Id :=
...@@ -2433,10 +2374,83 @@ package body Exp_Ch5 is ...@@ -2433,10 +2374,83 @@ package body Exp_Ch5 is
Is_Build_In_Place_Function (Parent_Function); Is_Build_In_Place_Function (Parent_Function);
Return_Stm : Node_Id; Return_Stm : Node_Id;
Statements : List_Id;
Handled_Stm_Seq : Node_Id; Handled_Stm_Seq : Node_Id;
Result : Node_Id; Result : Node_Id;
Exp : Node_Id; Exp : Node_Id;
function Move_Activation_Chain return Node_Id;
-- Construct a call to System.Tasking.Stages.Move_Activation_Chain
-- with parameters:
-- From current activation chain
-- To activation chain passed in by the caller
-- New_Master master passed in by the caller
function Move_Final_List return Node_Id;
-- Construct call to System.Finalization_Implementation.Move_Final_List
-- with parameters:
-- From finalization list of the return statement
-- To finalization list passed in by the caller
---------------------
-- Move_Activation_Chain --
---------------------
function Move_Activation_Chain return Node_Id is
Activation_Chain_Formal : constant Entity_Id :=
Build_In_Place_Formal (Parent_Function, BIP_Activation_Chain);
To : constant Node_Id :=
New_Reference_To (Activation_Chain_Formal, Loc);
Master_Formal : constant Entity_Id :=
Build_In_Place_Formal (Parent_Function, BIP_Master);
New_Master : constant Node_Id :=
New_Reference_To (Master_Formal, Loc);
Chain_Entity : Entity_Id;
From : Node_Id;
begin
Chain_Entity := First_Entity (Return_Statement_Entity (N));
while Chars (Chain_Entity) /= Name_uChain loop
Chain_Entity := Next_Entity (Chain_Entity);
end loop;
From :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Chain_Entity, Loc),
Attribute_Name => Name_Unrestricted_Access);
-- ??? I'm not sure why "Make_Identifier (Loc, Name_uChain)" doesn't
-- work, instead of "New_Reference_To (Chain_Entity, Loc)" above.
return
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc),
Parameter_Associations => New_List (From, To, New_Master));
end Move_Activation_Chain;
---------------------
-- Move_Final_List --
---------------------
function Move_Final_List return Node_Id is
Flist : constant Entity_Id :=
Finalization_Chain_Entity (Return_Statement_Entity (N));
From : constant Node_Id := New_Reference_To (Flist, Loc);
Caller_Final_List : constant Entity_Id :=
Build_In_Place_Formal
(Parent_Function, BIP_Final_List);
To : constant Node_Id :=
New_Reference_To (Caller_Final_List, Loc);
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Move_Final_List), Loc),
Parameter_Associations => New_List (From, To));
end Move_Final_List;
-- Start of processing for Expand_N_Extended_Return_Statement -- Start of processing for Expand_N_Extended_Return_Statement
begin begin
...@@ -2448,27 +2462,63 @@ package body Exp_Ch5 is ...@@ -2448,27 +2462,63 @@ package body Exp_Ch5 is
Handled_Stm_Seq := Handled_Statement_Sequence (N); Handled_Stm_Seq := Handled_Statement_Sequence (N);
-- Build a simple_return_statement that returns the return object when
-- there is a statement sequence, or no expression, or the result will
-- be built in place. Note however that we currently do this for all
-- composite cases, even though nonlimited composite results are not yet
-- built in place (though we plan to do so eventually).
if Present (Handled_Stm_Seq) if Present (Handled_Stm_Seq)
or else Is_Build_In_Place or else Is_Composite_Type (Etype (Parent_Function))
or else No (Exp) or else No (Exp)
then then
-- Build simple_return_statement that returns the return object Statements := New_List;
if Present (Handled_Stm_Seq) then
Append_To (Statements, Handled_Stm_Seq);
end if;
-- If control gets past the above Statements, we have successfully
-- completed the return statement. If the result type has controlled
-- parts, we call Move_Final_List to transfer responsibility for
-- finalization of the return object to the caller. An alternative
-- would be to declare a Success flag in the function, initialize it
-- to False, and set it to True here. Then move the Move_Final_List
-- call into the cleanup code, and check Success. If Success then
-- Move_Final_List else do finalization. Then we can remove the
-- abort-deferral and the nulling-out of the From parameter from
-- Move_Final_List. Note that the current method is not quite
-- correct in the rather obscure case of a select-then-abort
-- statement whose abortable part contains the return statement.
if Is_Controlled (Etype (Parent_Function))
or else Has_Controlled_Component (Etype (Parent_Function))
then
Append_To (Statements, Move_Final_List);
end if;
-- Similarly to the above Move_Final_List, if the result type
-- contains tasks, we call Move_Activation_Chain. Later, the cleanup
-- code will call Complete_Master, which will terminate any
-- unactivated tasks belonging to the return statement master. But
-- Move_Activation_Chain updates their master to be that of the
-- caller, so they will not be terminated unless the return
-- statement completes unsuccessfully due to exception, abort, goto,
-- or exit.
if Has_Task (Etype (Parent_Function)) then
Append_To (Statements, Move_Activation_Chain);
end if;
-- Build a simple_return_statement that returns the return object
Return_Stm := Return_Stm :=
Make_Return_Statement (Loc, Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); Expression => New_Occurrence_Of (Return_Object_Entity, Loc));
Append_To (Statements, Return_Stm);
if Present (Handled_Stm_Seq) then Handled_Stm_Seq :=
Handled_Stm_Seq := Make_Handled_Sequence_Of_Statements (Loc, Statements);
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Handled_Stm_Seq, Return_Stm));
else
Handled_Stm_Seq :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stm));
end if;
pragma Assert (Present (Handled_Stm_Seq));
end if; end if;
-- Case where we build a block -- Case where we build a block
...@@ -2479,7 +2529,29 @@ package body Exp_Ch5 is ...@@ -2479,7 +2529,29 @@ package body Exp_Ch5 is
Declarations => Return_Object_Declarations (N), Declarations => Return_Object_Declarations (N),
Handled_Statement_Sequence => Handled_Stm_Seq); Handled_Statement_Sequence => Handled_Stm_Seq);
if Is_Build_In_Place then -- We set the entity of the new block statement to be that of the
-- return statement. This is necessary so that various fields, such
-- as Finalization_Chain_Entity carry over from the return statement
-- to the block. Note that this block is unusual, in that its entity
-- is an E_Return_Statement rather than an E_Block.
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
-- 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_Build_In_Place
and then
Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration
then
Set_By_Ref (Return_Stm); -- Return build-in-place results by ref
elsif Is_Build_In_Place then
-- Locate the implicit access parameter associated with the -- Locate the implicit access parameter associated with the
-- the caller-supplied return object and convert the return -- the caller-supplied return object and convert the return
...@@ -2503,84 +2575,282 @@ package body Exp_Ch5 is ...@@ -2503,84 +2575,282 @@ package body Exp_Ch5 is
-- ... -- ...
declare declare
Return_Obj_Id : constant Entity_Id := Return_Obj_Id : constant Entity_Id :=
Defining_Identifier (Return_Object_Decl); Defining_Identifier (Return_Object_Decl);
Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id);
Return_Obj_Expr : constant Node_Id := Return_Obj_Expr : constant Node_Id :=
Expression (Return_Object_Decl); Expression (Return_Object_Decl);
Obj_Acc_Formal : Entity_Id := Extra_Formals (Parent_Function); Result_Subt : constant Entity_Id :=
Obj_Acc_Deref : Node_Id; Etype (Parent_Function);
Init_Assignment : Node_Id; Constr_Result : constant Boolean :=
Is_Constrained (Result_Subt);
Obj_Alloc_Formal : Entity_Id;
Object_Access : Entity_Id;
Obj_Acc_Deref : Node_Id;
Init_Assignment : Node_Id := Empty;
begin begin
-- Build-in-place results must be returned by reference -- Build-in-place results must be returned by reference
Set_By_Ref (Return_Stm); Set_By_Ref (Return_Stm);
-- Locate the implicit access parameter passed by the caller. -- Retrieve the implicit access parameter passed by the caller
-- It might be better to search for that with a symbol table
-- lookup, but for now we traverse the extra actuals to find
-- the access parameter (currently there can only be one).
while Present (Obj_Acc_Formal) loop Object_Access :=
exit when Build_In_Place_Formal (Parent_Function, BIP_Object_Access);
Ekind (Etype (Obj_Acc_Formal)) = E_Anonymous_Access_Type;
Next_Formal_With_Extras (Obj_Acc_Formal);
end loop;
-- ??? pragma Assert (Present (Obj_Acc_Formal)); -- 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).
-- For now we only rewrite the object if we can locate the if Present (Return_Obj_Expr)
-- implicit access parameter. Normally there should be one and then not No_Initialization (Return_Object_Decl)
-- if Build_In_Place is true, but at the moment it's only then
-- created in the more restrictive case of constrained Init_Assignment :=
-- inherently limited result subtypes. ??? Make_Assignment_Statement (Loc,
Name => New_Reference_To (Return_Obj_Id, Loc),
Expression => Relocate_Node (Return_Obj_Expr));
Set_Assignment_OK (Name (Init_Assignment));
Set_No_Ctrl_Actions (Init_Assignment);
if Present (Obj_Acc_Formal) then Set_Parent (Expression (Init_Assignment), Init_Assignment);
-- If the return object's declaration includes an expression Set_Expression (Return_Object_Decl, Empty);
-- 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).
if Present (Return_Obj_Expr) if Is_Class_Wide_Type (Etype (Return_Obj_Id))
and then not No_Initialization (Return_Object_Decl) and then not Is_Class_Wide_Type
(Etype (Expression (Init_Assignment)))
then then
Init_Assignment := Rewrite (Expression (Init_Assignment),
Make_Assignment_Statement (Loc, Make_Type_Conversion (Loc,
Name => New_Reference_To (Return_Obj_Id, Loc), Subtype_Mark =>
Expression => Relocate_Node (Return_Obj_Expr)); New_Occurrence_Of
Set_Assignment_OK (Name (Init_Assignment)); (Etype (Return_Obj_Id), Loc),
Set_No_Ctrl_Actions (Init_Assignment); Expression =>
Relocate_Node (Expression (Init_Assignment))));
-- ??? Should we be setting the parent of the expression end if;
-- here?
-- Set_Parent
-- (Expression (Init_Assignment), Init_Assignment);
Set_Expression (Return_Object_Decl, Empty);
if Constr_Result then
Insert_After (Return_Object_Decl, Init_Assignment); Insert_After (Return_Object_Decl, Init_Assignment);
end if; end if;
end if;
-- Replace the return object declaration with a renaming -- When the function's subtype is unconstrained, a run-time
-- of a dereference of the implicit access formal. -- test is needed to determine the form of allocation to use
-- for the return object. The function has an implicit formal
-- parameter that indicates 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. Currently the last case is 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.
if not Constr_Result then
Obj_Alloc_Formal :=
Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form);
declare
Ref_Type : Entity_Id;
Ptr_Type_Decl : Node_Id;
Alloc_Obj_Id : Entity_Id;
Alloc_Obj_Decl : Node_Id;
Alloc_If_Stmt : Node_Id;
SS_Allocator : Node_Id;
Heap_Allocator : Node_Id;
begin
-- Reuse the itype created for the function's implicit
-- access formal. This avoids the need to create a new
-- access type here, plus it allows assigning the access
-- formal directly without applying a conversion.
-- Ref_Type := Etype (Object_Access);
-- Create an access type designating the function's
-- result subtype.
Ref_Type :=
Make_Defining_Identifier (Loc, New_Internal_Name ('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_Reference_To (Return_Obj_Typ, Loc)));
Insert_Before_And_Analyze
(Return_Object_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_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
Set_Etype (Alloc_Obj_Id, Ref_Type);
Alloc_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Alloc_Obj_Id,
Object_Definition => New_Reference_To
(Ref_Type, Loc));
Insert_Before_And_Analyze
(Return_Object_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 (Return_Obj_Expr)
and then not No_Initialization (Return_Object_Decl)
then
Heap_Allocator :=
Make_Allocator (Loc,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Reference_To (Return_Obj_Typ, Loc),
Expression =>
New_Copy_Tree (Return_Obj_Expr)));
SS_Allocator := New_Copy_Tree (Heap_Allocator);
else
Heap_Allocator :=
Make_Allocator (Loc,
New_Reference_To (Return_Obj_Typ, Loc));
Obj_Acc_Deref := -- If the object requires default initialization then
Make_Explicit_Dereference (Loc, -- that will happen later following the elaboration of
Prefix => New_Reference_To (Obj_Acc_Formal, Loc)); -- the object renaming. If we don't turn it off here
-- then the object will be default initialized twice.
Rewrite (Return_Object_Decl, Set_No_Initialization (Heap_Allocator);
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Return_Obj_Id,
Access_Definition => Empty,
Subtype_Mark => New_Occurrence_Of
(Return_Obj_Typ, Loc),
Name => Obj_Acc_Deref));
Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); SS_Allocator := New_Copy_Tree (Heap_Allocator);
end if;
Set_Storage_Pool
(SS_Allocator, RTE (RE_SS_Pool));
Set_Procedure_To_Call
(SS_Allocator, RTE (RE_SS_Allocate));
-- 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 = 0), the
-- result of allocaing the object in the secondary stack
-- (BIP_Alloc_Form = 1), or else an allocator to create
-- the return object in the heap (BIP_Alloc_Form = 2).
-- ??? 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_Reference_To (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_Reference_To
(Alloc_Obj_Id, Loc),
Expression =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (Ref_Type, Loc),
Expression =>
New_Reference_To
(Object_Access, Loc)))),
Elsif_Parts =>
New_List (Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To
(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_Reference_To
(Alloc_Obj_Id, Loc),
Expression =>
SS_Allocator)))),
Else_Statements =>
New_List (Make_Assignment_Statement (Loc,
Name =>
New_Reference_To
(Alloc_Obj_Id, Loc),
Expression =>
Heap_Allocator)));
-- 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.
if Present (Init_Assignment) then
Append_To
(Then_Statements (Alloc_If_Stmt),
Init_Assignment);
end if;
Insert_After_And_Analyze (Alloc_Obj_Decl, Alloc_If_Stmt);
-- Remember the local access object for use in the
-- dereference of the renaming created below.
Object_Access := Alloc_Obj_Id;
end;
end if; 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_Reference_To (Object_Access, Loc));
Rewrite (Return_Object_Decl,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Return_Obj_Id,
Access_Definition => Empty,
Subtype_Mark => New_Occurrence_Of
(Return_Obj_Typ, Loc),
Name => Obj_Acc_Deref));
Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref);
end; end;
end if; end if;
...@@ -2622,8 +2892,8 @@ package body Exp_Ch5 is ...@@ -2622,8 +2892,8 @@ package body Exp_Ch5 is
-- Expand_N_If_Statement -- -- Expand_N_If_Statement --
--------------------------- ---------------------------
-- First we deal with the case of C and Fortran convention boolean -- First we deal with the case of C and Fortran convention boolean values,
-- values, with zero/non-zero semantics. -- with zero/non-zero semantics.
-- Second, we deal with the obvious rewriting for the cases where the -- Second, we deal with the obvious rewriting for the cases where the
-- condition of the IF is known at compile time to be True or False. -- condition of the IF is known at compile time to be True or False.
...@@ -2647,8 +2917,8 @@ package body Exp_Ch5 is ...@@ -2647,8 +2917,8 @@ package body Exp_Ch5 is
-- end if; -- end if;
-- This rewriting is needed if at least one elsif part has a non-empty -- This rewriting is needed if at least one elsif part has a non-empty
-- Condition_Actions list. We also do the same processing if there is -- Condition_Actions list. We also do the same processing if there is a
-- a constant condition in an elsif part (in conjunction with the first -- constant condition in an elsif part (in conjunction with the first
-- processing step mentioned above, for the recursive call made to deal -- processing step mentioned above, for the recursive call made to deal
-- with the created inner if, this deals with properly optimizing the -- with the created inner if, this deals with properly optimizing the
-- cases of constant elsif conditions). -- cases of constant elsif conditions).
...@@ -2668,8 +2938,8 @@ package body Exp_Ch5 is ...@@ -2668,8 +2938,8 @@ package body Exp_Ch5 is
while Compile_Time_Known_Value (Condition (N)) loop while Compile_Time_Known_Value (Condition (N)) loop
-- If condition is True, we can simply rewrite the if statement -- If condition is True, we can simply rewrite the if statement now
-- now by replacing it by the series of then statements. -- by replacing it by the series of then statements.
if Is_True (Expr_Value (Condition (N))) then if Is_True (Expr_Value (Condition (N))) then
...@@ -2687,10 +2957,10 @@ package body Exp_Ch5 is ...@@ -2687,10 +2957,10 @@ package body Exp_Ch5 is
-- the Then statements -- the Then statements
else else
-- We do not delete the condition if constant condition -- We do not delete the condition if constant condition warnings
-- warnings are enabled, since otherwise we end up deleting -- are enabled, since otherwise we end up deleting the desired
-- the desired warning. Of course the backend will get rid -- warning. Of course the backend will get rid of this True/False
-- of this True/False test anyway, so nothing is lost here. -- test anyway, so nothing is lost here.
if not Constant_Condition_Warnings then if not Constant_Condition_Warnings then
Kill_Dead_Code (Condition (N)); Kill_Dead_Code (Condition (N));
...@@ -2698,8 +2968,8 @@ package body Exp_Ch5 is ...@@ -2698,8 +2968,8 @@ package body Exp_Ch5 is
Kill_Dead_Code (Then_Statements (N), Warn_On_Deleted_Code); Kill_Dead_Code (Then_Statements (N), Warn_On_Deleted_Code);
-- If there are no elsif statements, then we simply replace -- If there are no elsif statements, then we simply replace the
-- the entire if statement by the sequence of else statements. -- entire if statement by the sequence of else statements.
if No (Elsif_Parts (N)) then if No (Elsif_Parts (N)) then
if No (Else_Statements (N)) if No (Else_Statements (N))
...@@ -2715,9 +2985,9 @@ package body Exp_Ch5 is ...@@ -2715,9 +2985,9 @@ package body Exp_Ch5 is
return; return;
-- If there are elsif statements, the first of them becomes -- If there are elsif statements, the first of them becomes the
-- the if/then section of the rebuilt if statement This is -- if/then section of the rebuilt if statement This is the case
-- the case where we loop to reprocess this copied condition. -- where we loop to reprocess this copied condition.
else else
Hed := Remove_Head (Elsif_Parts (N)); Hed := Remove_Head (Elsif_Parts (N));
...@@ -2747,18 +3017,18 @@ package body Exp_Ch5 is ...@@ -2747,18 +3017,18 @@ package body Exp_Ch5 is
while Present (E) loop while Present (E) loop
Adjust_Condition (Condition (E)); Adjust_Condition (Condition (E));
-- If there are condition actions, then we rewrite the if -- If there are condition actions, then rewrite the if statement
-- statement as indicated above. We also do the same rewrite -- as indicated above. We also do the same rewrite for a True or
-- if the condition is True or False. The further processing -- False condition. The further processing of this constant
-- of this constant condition is then done by the recursive -- condition is then done by the recursive call to expand the
-- call to expand the newly created if statement -- newly created if statement
if Present (Condition_Actions (E)) if Present (Condition_Actions (E))
or else Compile_Time_Known_Value (Condition (E)) or else Compile_Time_Known_Value (Condition (E))
then then
-- Note this is not an implicit if statement, since it is -- Note this is not an implicit if statement, since it is part
-- part of an explicit if statement in the source (or of an -- of an explicit if statement in the source (or of an implicit
-- implicit if statement that has already been tested). -- if statement that has already been tested).
New_If := New_If :=
Make_If_Statement (Sloc (E), Make_If_Statement (Sloc (E),
...@@ -2913,9 +3183,9 @@ package body Exp_Ch5 is ...@@ -2913,9 +3183,9 @@ package body Exp_Ch5 is
-- range bounds here, since they were frozen with constant declarations -- range bounds here, since they were frozen with constant declarations
-- and it is during that process that the validity checking is done. -- and it is during that process that the validity checking is done.
-- Handle the case where we have a for loop with the range type being -- Handle the case where we have a for loop with the range type being an
-- an enumeration type with non-standard representation. In this case -- enumeration type with non-standard representation. In this case we
-- we expand: -- expand:
-- for x in [reverse] a .. b loop -- for x in [reverse] a .. b loop
-- ... -- ...
...@@ -2952,8 +3222,8 @@ package body Exp_Ch5 is ...@@ -2952,8 +3222,8 @@ package body Exp_Ch5 is
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Loop_Id), 'P')); Chars => New_External_Name (Chars (Loop_Id), 'P'));
-- If the type has a contiguous representation, successive -- If the type has a contiguous representation, successive values
-- values can be generated as offsets from the first literal. -- can be generated as offsets from the first literal.
if Has_Contiguous_Rep (Btype) then if Has_Contiguous_Rep (Btype) then
Expr := Expr :=
...@@ -3033,8 +3303,8 @@ package body Exp_Ch5 is ...@@ -3033,8 +3303,8 @@ package body Exp_Ch5 is
Analyze (N); Analyze (N);
end; end;
-- Second case, if we have a while loop with Condition_Actions set, -- Second case, if we have a while loop with Condition_Actions set, then
-- then we change it into a plain loop: -- we change it into a plain loop:
-- while C loop -- while C loop
-- ... -- ...
...@@ -3064,10 +3334,10 @@ package body Exp_Ch5 is ...@@ -3064,10 +3334,10 @@ package body Exp_Ch5 is
Prepend (ES, Statements (N)); Prepend (ES, Statements (N));
Insert_List_Before (ES, Condition_Actions (Isc)); Insert_List_Before (ES, Condition_Actions (Isc));
-- This is not an implicit loop, since it is generated in -- This is not an implicit loop, since it is generated in response
-- response to the loop statement being processed. If this -- to the loop statement being processed. If this is itself
-- is itself implicit, the restriction has already been -- implicit, the restriction has already been checked. If not,
-- checked. If not, it is an explicit loop. -- it is an explicit loop.
Rewrite (N, Rewrite (N,
Make_Loop_Statement (Sloc (N), Make_Loop_Statement (Sloc (N),
...@@ -3167,8 +3437,8 @@ package body Exp_Ch5 is ...@@ -3167,8 +3437,8 @@ package body Exp_Ch5 is
pragma Assert (Is_Entry (Scope_Id)); pragma Assert (Is_Entry (Scope_Id));
-- Look at the enclosing block to see whether the return is from -- Look at the enclosing block to see whether the return is from an
-- an accept statement or an entry body. -- accept statement or an entry body.
for J in reverse 0 .. Cur_Idx loop for J in reverse 0 .. Cur_Idx loop
Scope_Id := Scope_Stack.Table (J).Entity; Scope_Id := Scope_Stack.Table (J).Entity;
...@@ -3249,9 +3519,9 @@ package body Exp_Ch5 is ...@@ -3249,9 +3519,9 @@ package body Exp_Ch5 is
-- Deal with returning variable length objects and controlled types -- Deal with returning variable length objects and controlled types
-- Nothing to do if we are returning by reference, or this is not a -- Nothing to do if we are returning by reference, or this is not type
-- type that requires special processing (indicated by the fact that -- that requires special processing (indicated by the fact that it
-- it requires a cleanup scope for the secondary stack case). -- requires a cleanup scope for the secondary stack case).
if Is_Inherently_Limited_Type (T) then if Is_Inherently_Limited_Type (T) then
null; null;
...@@ -3282,158 +3552,6 @@ package body Exp_Ch5 is ...@@ -3282,158 +3552,6 @@ package body Exp_Ch5 is
end if; end if;
end; end;
-- Case of secondary stack not used
elsif Function_Returns_With_DSP (Scope_Id) then
-- The DSP method is no longer in use. We would like to ignore DSP
-- while implementing AI-318; hence the raise below.
if True then
raise Program_Error;
end if;
-- Here what we need to do is to always return by reference, since
-- we will return with the stack pointer depressed. We may need to
-- do a copy to a local temporary before doing this return.
No_Secondary_Stack_Case : declare
Local_Copy_Required : Boolean := False;
-- Set to True if a local copy is required
Copy_Ent : Entity_Id;
-- Used for the target entity if a copy is required
Decl : Node_Id;
-- Declaration used to create copy if needed
procedure Test_Copy_Required (Expr : Node_Id);
-- Determines if Expr represents a return value for which a
-- copy is required. More specifically, a copy is not required
-- if Expr represents an object or component of an object that
-- is either in the local subprogram frame, or is constant.
-- If a copy is required, then Local_Copy_Required is set True.
------------------------
-- Test_Copy_Required --
------------------------
procedure Test_Copy_Required (Expr : Node_Id) is
Ent : Entity_Id;
begin
-- If component, test prefix (object containing component)
if Nkind (Expr) = N_Indexed_Component
or else
Nkind (Expr) = N_Selected_Component
then
Test_Copy_Required (Prefix (Expr));
return;
-- See if we have an entity name
elsif Is_Entity_Name (Expr) then
Ent := Entity (Expr);
-- Constant entity is always OK, no copy required
if Ekind (Ent) = E_Constant then
return;
-- No copy required for local variable
elsif Ekind (Ent) = E_Variable
and then Scope (Ent) = Current_Subprogram
then
return;
end if;
end if;
-- All other cases require a copy
Local_Copy_Required := True;
end Test_Copy_Required;
-- Start of processing for No_Secondary_Stack_Case
begin
-- No copy needed if result is from a function call.
-- In this case the result is already being returned by
-- reference with the stack pointer depressed.
-- To make up for a gcc 2.8.1 deficiency (???), we perform
-- the copy for array types if the constrained status of the
-- target type is different from that of the expression.
if Requires_Transient_Scope (T)
and then
(not Is_Array_Type (T)
or else Is_Constrained (T) = Is_Constrained (Return_Type)
or else Controlled_Type (T))
and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
-- We always need a local copy for a controlled type, since
-- we are required to finalize the local value before return.
-- The copy will automatically include the required finalize.
-- Moreover, gigi cannot make this copy, since we need special
-- processing to ensure proper behavior for finalization.
-- Note: the reason we are returning with a depressed stack
-- pointer in the controlled case (even if the type involved
-- is constrained) is that we must make a local copy to deal
-- properly with the requirement that the local result be
-- finalized.
elsif Controlled_Type (Utyp) then
Copy_Ent :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
-- Build declaration to do the copy, and insert it, setting
-- Assignment_OK, because we may be copying a limited type.
-- In addition we set the special flag to inhibit finalize
-- attachment if this is a controlled type (since this attach
-- must be done by the caller, otherwise if we attach it here
-- we will finalize the returned result prematurely).
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Ent,
Object_Definition => New_Occurrence_Of (Return_Type, Loc),
Expression => Relocate_Node (Exp));
Set_Assignment_OK (Decl);
Set_Delay_Finalize_Attach (Decl);
Insert_Action (N, Decl);
-- Now the actual return uses the copied value
Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc));
Analyze_And_Resolve (Exp, Return_Type);
-- Since we have made the copy, gigi does not have to, so
-- we set the By_Ref flag to prevent another copy being made.
Set_By_Ref (N);
-- Non-controlled cases
else
Test_Copy_Required (Exp);
-- If a local copy is required, then gigi will make the
-- copy, otherwise, we can return the result directly,
-- so set By_Ref to suppress the gigi copy.
if not Local_Copy_Required then
Set_By_Ref (N);
end if;
end if;
end No_Secondary_Stack_Case;
-- Here if secondary stack is used -- Here if secondary stack is used
else else
...@@ -3457,12 +3575,12 @@ package body Exp_Ch5 is ...@@ -3457,12 +3575,12 @@ package body Exp_Ch5 is
-- case either the result is already on the secondary stack, or is -- case either the result is already on the secondary stack, or is
-- already being returned with the stack pointer depressed and no -- already being returned with the stack pointer depressed and no
-- further processing is required except to set the By_Ref flag to -- further processing is required except to set the By_Ref flag to
-- ensure that gigi does not attempt an extra unnecessary copy. -- ensure that gigi does not attempt an extra unnecessary copy
-- (actually not just unnecessary but harmfully wrong in the case -- (actually not just unnecessary but harmfully wrong in the case of
-- of a controlled type, where gigi does not know how to do a copy). -- a controlled type, where gigi does not know how to do a copy). To
-- To make up for a gcc 2.8.1 deficiency (???), we perform -- make up for a gcc 2.8.1 deficiency (???), we perform the copy for
-- the copy for array types if the constrained status of the -- array types if the constrained status of the target type is
-- target type is different from that of the expression. -- different from that of the expression.
if Requires_Transient_Scope (T) if Requires_Transient_Scope (T)
and then and then
...@@ -3474,25 +3592,25 @@ package body Exp_Ch5 is ...@@ -3474,25 +3592,25 @@ package body Exp_Ch5 is
then then
Set_By_Ref (N); Set_By_Ref (N);
-- Remove side effects from the expression now so that -- Remove side effects from the expression now so that other parts
-- other part of the expander do not have to reanalyze -- of the expander do not have to reanalyze the node without this
-- this node without this optimization -- optimization.
Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
-- For controlled types, do the allocation on the secondary stack -- For controlled types, do the allocation on the secondary stack
-- manually in order to call adjust at the right time: -- manually in order to call adjust at the right time:
-- type Anon1 is access Return_Type; -- type Anon1 is access Return_Type;
-- for Anon1'Storage_pool use ss_pool; -- for Anon1'Storage_pool use ss_pool;
-- Anon2 : anon1 := new Return_Type'(expr); -- Anon2 : anon1 := new Return_Type'(expr);
-- return Anon2.all; -- return Anon2.all;
-- We do the same for classwide types that are not potentially -- We do the same for classwide types that are not potentially
-- controlled (by the virtue of restriction No_Finalization) because -- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types. -- gigi is not able to properly allocate class-wide types.
elsif Is_Class_Wide_Type (Utyp) elsif CW_Or_Controlled_Type (Utyp) then
or else Controlled_Type (Utyp)
then
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id := Temp : constant Entity_Id :=
...@@ -3550,13 +3668,12 @@ package body Exp_Ch5 is ...@@ -3550,13 +3668,12 @@ package body Exp_Ch5 is
end if; end if;
end if; end if;
-- Implement the rules of 6.5(8-10), which require a tag check in -- Implement the rules of 6.5(8-10), which require a tag check in the
-- the case of a limited tagged return type, and tag reassignment -- case of a limited tagged return type, and tag reassignment for
-- for nonlimited tagged results. These actions are needed when -- nonlimited tagged results. These actions are needed when the return
-- the return type is a specific tagged type and the result -- type is a specific tagged type and the result expression is a
-- expression is a conversion or a formal parameter, because in -- conversion or a formal parameter, because in that case the tag of the
-- that case the tag of the expression might differ from the tag -- expression might differ from the tag of the specific result type.
-- of the specific result type.
if Is_Tagged_Type (Utyp) if Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp) and then not Is_Class_Wide_Type (Utyp)
...@@ -3565,8 +3682,8 @@ package body Exp_Ch5 is ...@@ -3565,8 +3682,8 @@ package body Exp_Ch5 is
or else (Is_Entity_Name (Exp) or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind)) and then Ekind (Entity (Exp)) in Formal_Kind))
then then
-- When the return type is limited, perform a check that the -- When the return type is limited, perform a check that the tag of
-- tag of the result is the same as the tag of the return type. -- the result is the same as the tag of the return type.
if Is_Limited_Type (Return_Type) then if Is_Limited_Type (Return_Type) then
Insert_Action (Exp, Insert_Action (Exp,
...@@ -3586,14 +3703,13 @@ package body Exp_Ch5 is ...@@ -3586,14 +3703,13 @@ package body Exp_Ch5 is
Loc))), Loc))),
Reason => CE_Tag_Check_Failed)); Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type, -- If the result type is a specific nonlimited tagged type, then we
-- then we have to ensure that the tag of the result is that -- have to ensure that the tag of the result is that of the result
-- of the result type. This is handled by making a copy of the -- type. This is handled by making a copy of the expression in the
-- expression in the case where it might have a different tag, -- case where it might have a different tag, namely when the
-- namely when the expression is a conversion or a formal -- expression is a conversion or a formal parameter. We create a new
-- parameter. We create a new object of the result type and -- object of the result type and initialize it from the expression,
-- initialize it from the expression, which will implicitly -- which will implicitly force the tag to be set appropriately.
-- force the tag to be set appropriately.
else else
Result_Id := Result_Id :=
...@@ -3640,16 +3756,10 @@ package body Exp_Ch5 is ...@@ -3640,16 +3756,10 @@ package body Exp_Ch5 is
Condition => Condition =>
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Left_Opnd =>
Make_Function_Call (Loc, Build_Get_Access_Level (Loc,
Name => Make_Attribute_Reference (Loc,
New_Reference_To Prefix => Duplicate_Subexpr (Exp),
(RTE (RE_Get_Access_Level), Loc), Attribute_Name => Name_Tag)),
Parameter_Associations =>
New_List (Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Exp),
Attribute_Name =>
Name_Tag))),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
...@@ -3683,8 +3793,8 @@ package body Exp_Ch5 is ...@@ -3683,8 +3793,8 @@ package body Exp_Ch5 is
if Kind = E_Procedure or else Kind = E_Generic_Procedure then if Kind = E_Procedure or else Kind = E_Generic_Procedure then
return; return;
-- If it is a nested return within an extended one, replace it -- If it is a nested return within an extended one, replace it with a
-- with a return of the previously declared return object. -- return of the previously declared return object.
elsif Kind = E_Return_Statement then elsif Kind = E_Return_Statement then
Rewrite (N, Rewrite (N,
...@@ -3699,8 +3809,8 @@ package body Exp_Ch5 is ...@@ -3699,8 +3809,8 @@ package body Exp_Ch5 is
pragma Assert (Is_Entry (Scope_Id)); pragma Assert (Is_Entry (Scope_Id));
-- Look at the enclosing block to see whether the return is from -- Look at the enclosing block to see whether the return is from an
-- an accept statement or an entry body. -- accept statement or an entry body.
for J in reverse 0 .. Scope_Stack.Last loop for J in reverse 0 .. Scope_Stack.Last loop
Scope_Id := Scope_Stack.Table (J).Entity; Scope_Id := Scope_Stack.Table (J).Entity;
...@@ -3740,8 +3850,8 @@ package body Exp_Ch5 is ...@@ -3740,8 +3850,8 @@ package body Exp_Ch5 is
Rewrite (N, Goto_Stat); Rewrite (N, Goto_Stat);
Analyze (N); Analyze (N);
-- If it is a return from an entry body, put a Complete_Entry_Body -- If it is a return from an entry body, put a Complete_Entry_Body call
-- call in front of the return. -- in front of the return.
elsif Is_Protected_Type (Scope_Id) then elsif Is_Protected_Type (Scope_Id) then
Call := Call :=
...@@ -3818,25 +3928,20 @@ package body Exp_Ch5 is ...@@ -3818,25 +3928,20 @@ package body Exp_Ch5 is
-- The type of the expression (not necessarily the same as R_Type) -- The type of the expression (not necessarily the same as R_Type)
begin begin
-- The DSP method is no longer in use
pragma Assert (not Function_Returns_With_DSP (Scope_Id));
-- We rewrite "return <expression>;" to be: -- We rewrite "return <expression>;" to be:
-- return _anon_ : <return_subtype> := <expression> -- return _anon_ : <return_subtype> := <expression>
-- The expansion produced by Expand_N_Extended_Return_Statement will -- The expansion produced by Expand_N_Extended_Return_Statement will
-- contain simple return statements (for example, a block containing a -- contain simple return statements (for example, a block containing
-- simple return of the return object), which brings us back here with -- simple return of the return object), which brings us back here with
-- Comes_From_Extended_Return_Statement set. To avoid infinite -- Comes_From_Extended_Return_Statement set. To avoid infinite
-- recursion, we do not transform into an extended return if -- recursion, we do not transform into an extended return if
-- Comes_From_Extended_Return_Statement is True. -- Comes_From_Extended_Return_Statement is True.
-- The reason for this design is that for Ada 2005 limited returns, we -- The reason for this design is that for Ada 2005 limited returns, we
-- need to reify the return object, so we can build it "in place", -- need to reify the return object, so we can build it "in place", and
-- and we need a block statement to hang finalization and tasking stuff -- we need a block statement to hang finalization and tasking stuff.
-- off of.
-- ??? In order to avoid disruption, we avoid translating to extended -- ??? In order to avoid disruption, we avoid translating to extended
-- return except in the cases where we really need to (Ada 2005 -- return except in the cases where we really need to (Ada 2005
...@@ -3878,11 +3983,11 @@ package body Exp_Ch5 is ...@@ -3878,11 +3983,11 @@ package body Exp_Ch5 is
-- of an extended return statement (either written by the user, or -- of an extended return statement (either written by the user, or
-- generated by the above code). -- generated by the above code).
-- Always normalize C/Fortran boolean result. This is not always -- Always normalize C/Fortran boolean result. This is not always needed,
-- necessary, but it seems a good idea to minimize the passing -- but it seems a good idea to minimize the passing around of non-
-- around of non-normalized values, and in any case this handles -- normalized values, and in any case this handles the processing of
-- the processing of barrier functions for protected types, which -- barrier functions for protected types, which turn the condition into
-- turn the condition into a return statement. -- a return statement.
if Is_Boolean_Type (Exptyp) if Is_Boolean_Type (Exptyp)
and then Nonzero_Is_True (Exptyp) and then Nonzero_Is_True (Exptyp)
...@@ -3943,18 +4048,6 @@ package body Exp_Ch5 is ...@@ -3943,18 +4048,6 @@ package body Exp_Ch5 is
end if; end if;
end; end;
-- Case of secondary stack not used
elsif Function_Returns_With_DSP (Scope_Id) then
-- The DSP method is no longer in use. We would like to ignore DSP
-- while implementing AI-318; hence the following assertion. Keep the
-- old code around in case DSP is revived someday.
pragma Assert (False);
No_Secondary_Stack_Case (N);
-- Here if secondary stack is used -- Here if secondary stack is used
else else
...@@ -3989,15 +4082,14 @@ package body Exp_Ch5 is ...@@ -3989,15 +4082,14 @@ package body Exp_Ch5 is
and then and then
(not Is_Array_Type (Exptyp) (not Is_Array_Type (Exptyp)
or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
or else Is_Class_Wide_Type (Utyp) or else CW_Or_Controlled_Type (Utyp))
or else Controlled_Type (Exptyp))
and then Nkind (Exp) = N_Function_Call and then Nkind (Exp) = N_Function_Call
then then
Set_By_Ref (N); Set_By_Ref (N);
-- Remove side effects from the expression now so that -- Remove side effects from the expression now so that other parts
-- other part of the expander do not have to reanalyze -- of the expander do not have to reanalyze this node without this
-- this node without this optimization -- optimization
Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
...@@ -4013,9 +4105,7 @@ package body Exp_Ch5 is ...@@ -4013,9 +4105,7 @@ package body Exp_Ch5 is
-- controlled (by the virtue of restriction No_Finalization) because -- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types. -- gigi is not able to properly allocate class-wide types.
elsif Is_Class_Wide_Type (Utyp) elsif CW_Or_Controlled_Type (Utyp) then
or else Controlled_Type (Utyp)
then
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id := Temp : constant Entity_Id :=
...@@ -4073,13 +4163,12 @@ package body Exp_Ch5 is ...@@ -4073,13 +4163,12 @@ package body Exp_Ch5 is
end if; end if;
end if; end if;
-- Implement the rules of 6.5(8-10), which require a tag check in -- Implement the rules of 6.5(8-10), which require a tag check in the
-- the case of a limited tagged return type, and tag reassignment -- case of a limited tagged return type, and tag reassignment for
-- for nonlimited tagged results. These actions are needed when -- nonlimited tagged results. These actions are needed when the return
-- the return type is a specific tagged type and the result -- type is a specific tagged type and the result expression is a
-- expression is a conversion or a formal parameter, because in -- conversion or a formal parameter, because in that case the tag of the
-- that case the tag of the expression might differ from the tag -- expression might differ from the tag of the specific result type.
-- of the specific result type.
if Is_Tagged_Type (Utyp) if Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp) and then not Is_Class_Wide_Type (Utyp)
...@@ -4109,14 +4198,13 @@ package body Exp_Ch5 is ...@@ -4109,14 +4198,13 @@ package body Exp_Ch5 is
Loc))), Loc))),
Reason => CE_Tag_Check_Failed)); Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type, -- If the result type is a specific nonlimited tagged type, then we
-- then we have to ensure that the tag of the result is that -- have to ensure that the tag of the result is that of the result
-- of the result type. This is handled by making a copy of the -- type. This is handled by making a copy of the expression in the
-- expression in the case where it might have a different tag, -- case where it might have a different tag, namely when the
-- namely when the expression is a conversion or a formal -- expression is a conversion or a formal parameter. We create a new
-- parameter. We create a new object of the result type and -- object of the result type and initialize it from the expression,
-- initialize it from the expression, which will implicitly -- which will implicitly force the tag to be set appropriately.
-- force the tag to be set appropriately.
else else
declare declare
...@@ -4168,16 +4256,10 @@ package body Exp_Ch5 is ...@@ -4168,16 +4256,10 @@ package body Exp_Ch5 is
Condition => Condition =>
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Left_Opnd =>
Make_Function_Call (Loc, Build_Get_Access_Level (Loc,
Name => Make_Attribute_Reference (Loc,
New_Reference_To Prefix => Duplicate_Subexpr (Exp),
(RTE (RE_Get_Access_Level), Loc), Attribute_Name => Name_Tag)),
Parameter_Associations =>
New_List (Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Exp),
Attribute_Name =>
Name_Tag))),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
...@@ -4200,8 +4282,8 @@ package body Exp_Ch5 is ...@@ -4200,8 +4282,8 @@ package body Exp_Ch5 is
Save_Tag : constant Boolean := Is_Tagged_Type (T) Save_Tag : constant Boolean := Is_Tagged_Type (T)
and then not No_Ctrl_Actions (N) and then not No_Ctrl_Actions (N)
and then not Java_VM; and then not Java_VM;
-- Tags are not saved and restored when Java_VM because JVM tags -- Tags are not saved and restored when Java_VM because JVM tags are
-- are represented implicitly in objects. -- represented implicitly in objects.
Res : List_Id; Res : List_Id;
Tag_Tmp : Entity_Id; Tag_Tmp : Entity_Id;
...@@ -4271,8 +4353,8 @@ package body Exp_Ch5 is ...@@ -4271,8 +4353,8 @@ package body Exp_Ch5 is
-- specific to each object of the type, not to the value being assigned. -- specific to each object of the type, not to the value being assigned.
-- Thus they need to be left intact during the assignment. We achieve -- Thus they need to be left intact during the assignment. We achieve
-- this by constructing a Storage_Array subtype, and by overlaying -- this by constructing a Storage_Array subtype, and by overlaying
-- objects of this type on the source and target of the assignment. -- objects of this type on the source and target of the assignment. The
-- The assignment is then rewritten to assignments of slices of these -- assignment is then rewritten to assignments of slices of these
-- arrays, copying the user data, and leaving the pointers untouched. -- arrays, copying the user data, and leaving the pointers untouched.
if Ctrl_Act then if Ctrl_Act then
...@@ -4306,10 +4388,9 @@ package body Exp_Ch5 is ...@@ -4306,10 +4388,9 @@ package body Exp_Ch5 is
(Rec : Entity_Id; (Rec : Entity_Id;
Lo : Node_Id; Lo : Node_Id;
Hi : Node_Id) return Node_Id; Hi : Node_Id) return Node_Id;
-- Build and return a slice of an array of type S overlaid -- Build and return a slice of an array of type S overlaid on
-- on object Rec, with bounds specified by Lo and Hi. If either -- object Rec, with bounds specified by Lo and Hi. If either bound
-- bound is empty, a default of S'First (respectively S'Last) -- is empty, a default of S'First (respectively S'Last) is used.
-- is used.
----------------- -----------------
-- Build_Slice -- -- Build_Slice --
...@@ -4328,12 +4409,12 @@ package body Exp_Ch5 is ...@@ -4328,12 +4409,12 @@ package body Exp_Ch5 is
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Rec, Prefix => Rec,
Attribute_Name => Name_Address)); Attribute_Name => Name_Address));
-- Access value designating an opaque storage array of -- Access value designating an opaque storage array of type S
-- type S overlaid on record Rec. -- overlaid on record Rec.
begin begin
-- Compute slice bounds using S'First (1) and S'Last -- Compute slice bounds using S'First (1) and S'Last as default
-- as default values when not specified by the caller. -- values when not specified by the caller.
if No (Lo) then if No (Lo) then
Lo_Bound := Make_Integer_Literal (Loc, 1); Lo_Bound := Make_Integer_Literal (Loc, 1);
...@@ -4613,161 +4694,6 @@ package body Exp_Ch5 is ...@@ -4613,161 +4694,6 @@ package body Exp_Ch5 is
return Empty_List; return Empty_List;
end Make_Tag_Ctrl_Assignment; end Make_Tag_Ctrl_Assignment;
-----------------------------
-- No_Secondary_Stack_Case --
-----------------------------
procedure No_Secondary_Stack_Case (N : Node_Id) is
pragma Assert (False); -- DSP method no longer in use
Loc : constant Source_Ptr := Sloc (N);
Exp : constant Node_Id := Expression (N);
T : constant Entity_Id := Etype (Exp);
Scope_Id : constant Entity_Id :=
Return_Applies_To (Return_Statement_Entity (N));
Return_Type : constant Entity_Id := Etype (Scope_Id);
Utyp : constant Entity_Id := Underlying_Type (Return_Type);
-- Here what we need to do is to always return by reference, since
-- we will return with the stack pointer depressed. We may need to
-- do a copy to a local temporary before doing this return.
Local_Copy_Required : Boolean := False;
-- Set to True if a local copy is required
Copy_Ent : Entity_Id;
-- Used for the target entity if a copy is required
Decl : Node_Id;
-- Declaration used to create copy if needed
procedure Test_Copy_Required (Expr : Node_Id);
-- Determines if Expr represents a return value for which a
-- copy is required. More specifically, a copy is not required
-- if Expr represents an object or component of an object that
-- is either in the local subprogram frame, or is constant.
-- If a copy is required, then Local_Copy_Required is set True.
------------------------
-- Test_Copy_Required --
------------------------
procedure Test_Copy_Required (Expr : Node_Id) is
Ent : Entity_Id;
begin
-- If component, test prefix (object containing component)
if Nkind (Expr) = N_Indexed_Component
or else
Nkind (Expr) = N_Selected_Component
then
Test_Copy_Required (Prefix (Expr));
return;
-- See if we have an entity name
elsif Is_Entity_Name (Expr) then
Ent := Entity (Expr);
-- Constant entity is always OK, no copy required
if Ekind (Ent) = E_Constant then
return;
-- No copy required for local variable
elsif Ekind (Ent) = E_Variable
and then Scope (Ent) = Current_Subprogram
then
return;
end if;
end if;
-- All other cases require a copy
Local_Copy_Required := True;
end Test_Copy_Required;
-- Start of processing for No_Secondary_Stack_Case
begin
-- No copy needed if result is from a function call.
-- In this case the result is already being returned by
-- reference with the stack pointer depressed.
-- To make up for a gcc 2.8.1 deficiency (???), we perform
-- the copy for array types if the constrained status of the
-- target type is different from that of the expression.
if Requires_Transient_Scope (T)
and then
(not Is_Array_Type (T)
or else Is_Constrained (T) = Is_Constrained (Return_Type)
or else Controlled_Type (T))
and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
-- We always need a local copy for a controlled type, since
-- we are required to finalize the local value before return.
-- The copy will automatically include the required finalize.
-- Moreover, gigi cannot make this copy, since we need special
-- processing to ensure proper behavior for finalization.
-- Note: the reason we are returning with a depressed stack
-- pointer in the controlled case (even if the type involved
-- is constrained) is that we must make a local copy to deal
-- properly with the requirement that the local result be
-- finalized.
elsif Controlled_Type (Utyp) then
Copy_Ent :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
-- Build declaration to do the copy, and insert it, setting
-- Assignment_OK, because we may be copying a limited type.
-- In addition we set the special flag to inhibit finalize
-- attachment if this is a controlled type (since this attach
-- must be done by the caller, otherwise if we attach it here
-- we will finalize the returned result prematurely).
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Ent,
Object_Definition => New_Occurrence_Of (Return_Type, Loc),
Expression => Relocate_Node (Exp));
Set_Assignment_OK (Decl);
Set_Delay_Finalize_Attach (Decl);
Insert_Action (N, Decl);
-- Now the actual return uses the copied value
Rewrite (Exp, New_Occurrence_Of (Copy_Ent, Loc));
Analyze_And_Resolve (Exp, Return_Type);
-- Since we have made the copy, gigi does not have to, so
-- we set the By_Ref flag to prevent another copy being made.
Set_By_Ref (N);
-- Non-controlled cases
else
Test_Copy_Required (Exp);
-- If a local copy is required, then gigi will make the
-- copy, otherwise, we can return the result directly,
-- so set By_Ref to suppress the gigi copy.
if not Local_Copy_Required then
Set_By_Ref (N);
end if;
end if;
end No_Secondary_Stack_Case;
------------------------------------ ------------------------------------
-- Possible_Bit_Aligned_Component -- -- Possible_Bit_Aligned_Component --
------------------------------------ ------------------------------------
...@@ -4821,9 +4747,9 @@ package body Exp_Ch5 is ...@@ -4821,9 +4747,9 @@ package body Exp_Ch5 is
end if; end if;
end; end;
-- If we have neither a record nor array component, it means that -- If we have neither a record nor array component, it means that we
-- we have fallen off the top testing prefixes recursively, and -- have fallen off the top testing prefixes recursively, and we now
-- we now have a stand alone object, where we don't have a problem -- have a stand alone object, where we don't have a problem.
when others => when others =>
return False; return False;
......
gcc/ada/exp_ch6.adb
...@@ -30,6 +30,7 @@ with Debug; use Debug; ...@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Elists; use Elists; with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Ch2; use Exp_Ch2; with Exp_Ch2; use Exp_Ch2;
with Exp_Ch3; use Exp_Ch3; with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
...@@ -62,7 +63,6 @@ with Sem_Disp; use Sem_Disp; ...@@ -62,7 +63,6 @@ with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist; with Sem_Dist; use Sem_Dist;
with Sem_Mech; use Sem_Mech; with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res; with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
...@@ -81,11 +81,53 @@ package body Exp_Ch6 is ...@@ -81,11 +81,53 @@ package body Exp_Ch6 is
procedure Add_Access_Actual_To_Build_In_Place_Call procedure Add_Access_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id; (Function_Call : Node_Id;
Function_Id : Entity_Id; Function_Id : Entity_Id;
Return_Object : Node_Id); Return_Object : Node_Id;
Is_Access : Boolean := False);
-- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the
-- object name given by Return_Object and add the attribute to the end of -- object name given by Return_Object and add the attribute to the end of
-- the actual parameter list associated with the build-in-place function -- the actual parameter list associated with the build-in-place function
-- call denoted by Function_Call. -- call denoted by Function_Call. However, if Is_Access is True, then
-- Return_Object is already an access expression, in which case it's passed
-- along directly to the build-in-place function. Finally, if Return_Object
-- is empty, then pass a null literal as the actual.
procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
-- if any, to be done by a build-in-place function. If Alloc_Form_Exp is
-- present, then use it, otherwise pass a literal corresponding to the
-- Alloc_Form parameter (which must not be Unspecified in that case).
procedure Add_Extra_Actual_To_Call
(Subprogram_Call : Node_Id;
Extra_Formal : Entity_Id;
Extra_Actual : Node_Id);
-- Adds Extra_Actual as a named parameter association for the formal
-- Extra_Formal in Subprogram_Call.
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
-- controlled parts, add an actual parameter that is a pointer to caller's
-- finalization list.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
-- contains tasks, add two actual parameters: the master, and a pointer to
-- the caller's activation chain. Master_Actual is the actual parameter
-- expression to pass for the master. In most cases, this is the current
-- master (_master). The two exceptions are: If the function call is the
-- initialization expression for an allocator, we pass the master of the
-- access type. If the function call is the initialization expression for
-- a return object, we pass along the master passed in by the caller. The
-- activation chain to pass is always the local one.
procedure Check_Overriding_Operation (Subp : Entity_Id); procedure Check_Overriding_Operation (Subp : Entity_Id);
-- Subp is a dispatching operation. Check whether it may override an -- Subp is a dispatching operation. Check whether it may override an
...@@ -172,66 +214,296 @@ package body Exp_Ch6 is ...@@ -172,66 +214,296 @@ package body Exp_Ch6 is
procedure Add_Access_Actual_To_Build_In_Place_Call procedure Add_Access_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id; (Function_Call : Node_Id;
Function_Id : Entity_Id; Function_Id : Entity_Id;
Return_Object : Node_Id) Return_Object : Node_Id;
Is_Access : Boolean := False)
is is
Loc : constant Source_Ptr := Sloc (Function_Call); Loc : constant Source_Ptr := Sloc (Function_Call);
Obj_Address : Node_Id; Obj_Address : Node_Id;
Obj_Acc_Formal : Node_Id; Obj_Acc_Formal : Entity_Id;
Param_Assoc : Node_Id;
begin begin
-- Locate the implicit access parameter in the called function. Maybe -- Locate the implicit access parameter in the called function
-- we should be testing for the name of the access parameter (or perhaps
-- better, each implicit formal for build-in-place could have an
-- identifying flag, or a Uint attribute to identify it). ???
Obj_Acc_Formal := Extra_Formals (Function_Id); Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);
while Present (Obj_Acc_Formal) loop -- If no return object is provided, then pass null
exit when Ekind (Etype (Obj_Acc_Formal)) = E_Anonymous_Access_Type;
Next_Formal_With_Extras (Obj_Acc_Formal); if not Present (Return_Object) then
end loop; Obj_Address := Make_Null (Loc);
pragma Assert (Present (Obj_Acc_Formal)); -- If Return_Object is already an expression of an access type, then use
-- it directly, since it must be an access value denoting the return
-- object, and couldn't possibly be the return object itself.
elsif Is_Access then
Obj_Address := Return_Object;
-- Apply Unrestricted_Access to caller's return object -- Apply Unrestricted_Access to caller's return object
Obj_Address := else
Make_Attribute_Reference (Loc, Obj_Address :=
Prefix => Return_Object, Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access); Prefix => Return_Object,
Attribute_Name => Name_Unrestricted_Access);
end if;
Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
-- Build the parameter association for the new actual and add it to the -- Build the parameter association for the new actual and add it to the
-- end of the function's actuals. -- end of the function's actuals.
Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
end Add_Access_Actual_To_Build_In_Place_Call;
--------------------------------------------------
-- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
--------------------------------------------------
procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Alloc_Form : BIP_Allocation_Form := Unspecified;
Alloc_Form_Exp : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Alloc_Form_Actual : Node_Id;
Alloc_Form_Formal : Node_Id;
begin
-- Locate the implicit allocation form parameter in the called function.
-- Maybe it would be better for each implicit formal of a build-in-place
-- function to have a flag or a Uint attribute to identify it. ???
Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);
if Present (Alloc_Form_Exp) then
pragma Assert (Alloc_Form = Unspecified);
Alloc_Form_Actual := Alloc_Form_Exp;
else
pragma Assert (Alloc_Form /= Unspecified);
Alloc_Form_Actual :=
Make_Integer_Literal (Loc,
Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));
end if;
Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
------------------------------
-- Add_Extra_Actual_To_Call --
------------------------------
procedure Add_Extra_Actual_To_Call
(Subprogram_Call : Node_Id;
Extra_Formal : Entity_Id;
Extra_Actual : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Subprogram_Call);
Param_Assoc : Node_Id;
begin
Param_Assoc := Param_Assoc :=
Make_Parameter_Association (Loc, Make_Parameter_Association (Loc,
Selector_Name => New_Occurrence_Of (Obj_Acc_Formal, Loc), Selector_Name => New_Occurrence_Of (Extra_Formal, Loc),
Explicit_Actual_Parameter => Obj_Address); Explicit_Actual_Parameter => Extra_Actual);
Set_Parent (Param_Assoc, Function_Call); Set_Parent (Param_Assoc, Subprogram_Call);
Set_Parent (Obj_Address, Param_Assoc); Set_Parent (Extra_Actual, Param_Assoc);
if Present (Parameter_Associations (Function_Call)) then if Present (Parameter_Associations (Subprogram_Call)) then
if Nkind (Last (Parameter_Associations (Function_Call))) = if Nkind (Last (Parameter_Associations (Subprogram_Call))) =
N_Parameter_Association N_Parameter_Association
then then
Set_Next_Named_Actual
(Last (Parameter_Associations (Function_Call)), -- Find last named actual, and append
Obj_Address);
declare
L : Node_Id;
begin
L := First_Actual (Subprogram_Call);
while Present (L) loop
if No (Next_Actual (L)) then
Set_Next_Named_Actual (Parent (L), Extra_Actual);
exit;
end if;
Next_Actual (L);
end loop;
end;
else else
Set_First_Named_Actual (Function_Call, Obj_Address); Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
end if; end if;
Append (Param_Assoc, To => Parameter_Associations (Function_Call)); Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));
else else
Set_Parameter_Associations (Function_Call, New_List (Param_Assoc)); Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));
Set_First_Named_Actual (Function_Call, Obj_Address); Set_First_Named_Actual (Subprogram_Call, Extra_Actual);
end if; end if;
end Add_Access_Actual_To_Build_In_Place_Call; end Add_Extra_Actual_To_Call;
--------------------------------------------------
-- Add_Final_List_Actual_To_Build_In_Place_Call --
--------------------------------------------------
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Final_List : Node_Id;
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
begin
-- No such extra parameter is needed if there are no controlled parts
if not (Is_Controlled (Etype (Function_Id))
or else Has_Controlled_Component (Etype (Function_Id))) then
return;
end if;
-- Locate implicit finalization list parameter in the called function
Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);
-- Create the actual which is a pointer to the current finalization list
Final_List := Find_Final_List (Current_Scope);
Final_List_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Final_List,
Attribute_Name => Name_Unrestricted_Access);
Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal));
-- Build the parameter association for the new actual and add it to the
-- end of the function's actuals.
Add_Extra_Actual_To_Call
(Function_Call, Final_List_Formal, Final_List_Actual);
end Add_Final_List_Actual_To_Build_In_Place_Call;
---------------------------------------------
-- Add_Task_Actuals_To_Build_In_Place_Call --
---------------------------------------------
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id)
-- Note: Master_Actual can be Empty, but only if there are no tasks
is
Loc : constant Source_Ptr := Sloc (Function_Call);
begin
-- No such extra parameters are needed if there are no tasks
if not Has_Task (Etype (Function_Id)) then
return;
end if;
-- The master
declare
Master_Formal : Node_Id;
begin
-- Locate implicit master parameter in the called function
Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master);
Analyze_And_Resolve (Master_Actual, Etype (Master_Formal));
-- Build the parameter association for the new actual and add it to
-- the end of the function's actuals.
Add_Extra_Actual_To_Call
(Function_Call, Master_Formal, Master_Actual);
end;
-- The activation chain
declare
Activation_Chain_Actual : Node_Id;
Activation_Chain_Formal : Node_Id;
begin
-- Locate implicit activation chain parameter in the called function
Activation_Chain_Formal := Build_In_Place_Formal
(Function_Id, BIP_Activation_Chain);
-- Create the actual which is a pointer to the current activation
-- chain
Activation_Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uChain),
Attribute_Name => Name_Unrestricted_Access);
Analyze_And_Resolve
(Activation_Chain_Actual, Etype (Activation_Chain_Formal));
-- Build the parameter association for the new actual and add it to
-- the end of the function's actuals.
Add_Extra_Actual_To_Call
(Function_Call, Activation_Chain_Formal, Activation_Chain_Actual);
end;
end Add_Task_Actuals_To_Build_In_Place_Call;
-----------------------
-- BIP_Formal_Suffix --
-----------------------
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
when BIP_Alloc_Form =>
return "BIPalloc";
when BIP_Final_List =>
return "BIPfinallist";
when BIP_Master =>
return "BIPmaster";
when BIP_Activation_Chain =>
return "BIPactivationchain";
when BIP_Object_Access =>
return "BIPaccess";
end case;
end BIP_Formal_Suffix;
---------------------------
-- Build_In_Place_Formal --
---------------------------
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id
is
Extra_Formal : Entity_Id := Extra_Formals (Func);
begin
-- Maybe it would be better for each implicit formal of a build-in-place
-- function to have a flag or a Uint attribute to identify it. ???
loop
exit when
Chars (Extra_Formal) =
New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
Next_Formal_With_Extras (Extra_Formal);
end loop;
pragma Assert (Present (Extra_Formal));
return Extra_Formal;
end Build_In_Place_Formal;
-------------------------------- --------------------------------
-- Check_Overriding_Operation -- -- Check_Overriding_Operation --
...@@ -1088,10 +1360,10 @@ package body Exp_Ch6 is ...@@ -1088,10 +1360,10 @@ package body Exp_Ch6 is
-- Ada 2005 (AI-318-02): If the actual parameter is a call to a -- Ada 2005 (AI-318-02): If the actual parameter is a call to a
-- build-in-place function, then a temporary return object needs -- build-in-place function, then a temporary return object needs
-- to be created and access to it must be passed to the function. -- to be created and access to it must be passed to the function.
-- Currently we limit such functions to those with constrained -- Currently we limit such functions to those with inherently
-- inherently limited result subtypes, but eventually we plan to -- limited result subtypes, but eventually we plan to expand the
-- expand the allowed forms of funtions that are treated as -- functions that are treated as build-in-place to include other
-- build-in-place. -- composite result types.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Actual) and then Is_Build_In_Place_Function_Call (Actual)
...@@ -2001,8 +2273,11 @@ package body Exp_Ch6 is ...@@ -2001,8 +2273,11 @@ package body Exp_Ch6 is
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Condition =>
Make_Op_Not (Loc, Make_Op_Not (Loc,
Get_Remotely_Callable Build_Get_Remotely_Callable (Loc,
(Duplicate_Subexpr_Move_Checks (Actual))), Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (Actual),
Selector_Name =>
Make_Identifier (Loc, Name_uTag)))),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
Reason => PE_Illegal_RACW_E_4_18)))); Reason => PE_Illegal_RACW_E_4_18))));
...@@ -2161,7 +2436,7 @@ package body Exp_Ch6 is ...@@ -2161,7 +2436,7 @@ package body Exp_Ch6 is
Set_Entity (Name (N), Parent_Subp); Set_Entity (Name (N), Parent_Subp);
if Is_Abstract (Parent_Subp) if Is_Abstract_Subprogram (Parent_Subp)
and then not In_Instance and then not In_Instance
then then
Error_Msg_NE Error_Msg_NE
...@@ -2270,8 +2545,8 @@ package body Exp_Ch6 is ...@@ -2270,8 +2545,8 @@ package body Exp_Ch6 is
-- Handle case of access to protected subprogram type -- Handle case of access to protected subprogram type
if Ekind (Base_Type (Etype (Prefix (Name (N))))) = if Is_Access_Protected_Subprogram_Type
E_Access_Protected_Subprogram_Type (Base_Type (Etype (Prefix (Name (N)))))
then then
-- If this is a call through an access to protected operation, -- If this is a call through an access to protected operation,
-- the prefix has the form (object'address, operation'access). -- the prefix has the form (object'address, operation'access).
...@@ -2717,6 +2992,10 @@ package body Exp_Ch6 is ...@@ -2717,6 +2992,10 @@ package body Exp_Ch6 is
-- If the type returned by the function is unconstrained and the -- If the type returned by the function is unconstrained and the
-- call can be inlined, special processing is required. -- call can be inlined, special processing is required.
function Is_Null_Procedure return Boolean;
-- Predicate to recognize stubbed procedures and null procedures, for
-- which there is no need for the full inlining mechanism.
procedure Make_Exit_Label; procedure Make_Exit_Label;
-- Build declaration for exit label to be used in Return statements -- Build declaration for exit label to be used in Return statements
...@@ -2743,6 +3022,50 @@ package body Exp_Ch6 is ...@@ -2743,6 +3022,50 @@ package body Exp_Ch6 is
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod -- Determine whether a formal parameter is used only once in Orig_Bod
-----------------------
-- Is_Null_Procedure --
-----------------------
function Is_Null_Procedure return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
begin
if Ekind (Subp) /= E_Procedure then
return False;
elsif Nkind (Orig_Bod) /= N_Subprogram_Body then
return False;
-- Check if this is an ada 2005 null procedure
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Null_Present (Specification (Decl))
then
return True;
-- Check if the body contains only a null statement, followed by the
-- return statement added during expansion.
else
declare
Stat : constant Node_Id :=
First
(Statements (Handled_Statement_Sequence (Orig_Bod)));
Stat2 : constant Node_Id := Next (Stat);
begin
return
Nkind (Stat) = N_Null_Statement
and then
(No (Stat2)
or else
(Nkind (Stat2) = N_Return_Statement
and then No (Next (Stat2))));
end;
end if;
end Is_Null_Procedure;
--------------------- ---------------------
-- Make_Exit_Label -- -- Make_Exit_Label --
--------------------- ---------------------
...@@ -3076,6 +3399,10 @@ package body Exp_Ch6 is ...@@ -3076,6 +3399,10 @@ package body Exp_Ch6 is
(RTE (RE_Address), (RTE (RE_Address),
Relocate_Node (First_Actual (N)))); Relocate_Node (First_Actual (N))));
return; return;
elsif Is_Null_Procedure then
Rewrite (N, Make_Null_Statement (Loc));
return;
end if; end if;
-- Check for an illegal attempt to inline a recursive procedure. If the -- Check for an illegal attempt to inline a recursive procedure. If the
...@@ -3786,7 +4113,7 @@ package body Exp_Ch6 is ...@@ -3786,7 +4113,7 @@ package body Exp_Ch6 is
Chars => Name_uE); Chars => Name_uE);
Excep_Handlers := New_List ( Excep_Handlers := New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Choice_Parameter => Ent_EO, Choice_Parameter => Ent_EO,
Exception_Choices => New_List ( Exception_Choices => New_List (
Make_Others_Choice (Loc)), Make_Others_Choice (Loc)),
...@@ -4003,9 +4330,7 @@ package body Exp_Ch6 is ...@@ -4003,9 +4330,7 @@ package body Exp_Ch6 is
elsif Is_Inherently_Limited_Type (Typ) then elsif Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Spec_Id); Set_Returns_By_Ref (Spec_Id);
elsif Present (Utyp) elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
and then (Is_Class_Wide_Type (Utyp) or else Controlled_Type (Utyp))
then
Set_Returns_By_Ref (Spec_Id); Set_Returns_By_Ref (Spec_Id);
end if; end if;
end; end;
...@@ -4403,16 +4728,20 @@ package body Exp_Ch6 is ...@@ -4403,16 +4728,20 @@ package body Exp_Ch6 is
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
begin begin
-- For now we test whether E denotes a function or access-to-function -- For now we test whether E denotes a function or access-to-function
-- type whose result subtype is constrained and inherently limited. -- type whose result subtype is inherently limited. Later this test may
-- Later this test will be revised to include unconstrained limited -- be revised to allow composite nonlimited types. Functions with a
-- types and composite nonlimited types in general. Functions with -- foreign convention or whose result type has a foreign convention
-- a foreign convention or whose result type has a foreign convention
-- never qualify. -- never qualify.
if Ekind (E) = E_Function if Ekind (E) = E_Function
or else Ekind (E) = E_Generic_Function
or else (Ekind (E) = E_Subprogram_Type or else (Ekind (E) = E_Subprogram_Type
and then Etype (E) /= Standard_Void_Type) and then Etype (E) /= Standard_Void_Type)
then then
-- Note: If you have Convention (C) on an inherently limited type,
-- you're on your own. That is, the C code will have to be carefully
-- written to know about the Ada conventions.
if Has_Foreign_Convention (E) if Has_Foreign_Convention (E)
or else Has_Foreign_Convention (Etype (E)) or else Has_Foreign_Convention (Etype (E))
then then
...@@ -4420,7 +4749,8 @@ package body Exp_Ch6 is ...@@ -4420,7 +4749,8 @@ package body Exp_Ch6 is
else else
return Is_Inherently_Limited_Type (Etype (E)) return Is_Inherently_Limited_Type (Etype (E))
and then Is_Constrained (Etype (E)); and then Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L;
end if; end if;
else else
...@@ -4456,6 +4786,22 @@ package body Exp_Ch6 is ...@@ -4456,6 +4786,22 @@ package body Exp_Ch6 is
end if; end if;
end Is_Build_In_Place_Function_Call; end Is_Build_In_Place_Function_Call;
---------------------------------------
-- Is_Build_In_Place_Function_Return --
---------------------------------------
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
begin
if Nkind (N) = N_Return_Statement
or else Nkind (N) = N_Extended_Return_Statement
then
return Is_Build_In_Place_Function
(Return_Applies_To (Return_Statement_Entity (N)));
else
return False;
end if;
end Is_Build_In_Place_Function_Return;
----------------------- -----------------------
-- Freeze_Subprogram -- -- Freeze_Subprogram --
----------------------- -----------------------
...@@ -4474,8 +4820,6 @@ package body Exp_Ch6 is ...@@ -4474,8 +4820,6 @@ package body Exp_Ch6 is
procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
Iface_DT_Ptr : Elmt_Id; Iface_DT_Ptr : Elmt_Id;
Iface_Typ : Entity_Id;
Iface_Elmt : Elmt_Id;
Tagged_Typ : Entity_Id; Tagged_Typ : Entity_Id;
Thunk_Id : Entity_Id; Thunk_Id : Entity_Id;
...@@ -4483,8 +4827,9 @@ package body Exp_Ch6 is ...@@ -4483,8 +4827,9 @@ package body Exp_Ch6 is
Tagged_Typ := Find_Dispatching_Type (Prim); Tagged_Typ := Find_Dispatching_Type (Prim);
if No (Access_Disp_Table (Tagged_Typ)) if No (Access_Disp_Table (Tagged_Typ))
or else No (Abstract_Interfaces (Tagged_Typ)) or else not Has_Abstract_Interfaces (Tagged_Typ)
or else not RTE_Available (RE_Interface_Tag) or else not RTE_Available (RE_Interface_Tag)
or else Restriction_Active (No_Dispatching_Calls)
then then
return; return;
end if; end if;
...@@ -4497,36 +4842,29 @@ package body Exp_Ch6 is ...@@ -4497,36 +4842,29 @@ package body Exp_Ch6 is
Iface_DT_Ptr := Iface_DT_Ptr :=
Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))); Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
Iface_Elmt := First_Elmt (Abstract_Interfaces (Tagged_Typ));
while Present (Iface_DT_Ptr) and then Present (Iface_Elmt) loop while Present (Iface_DT_Ptr) loop
Iface_Typ := Node (Iface_Elmt); Thunk_Id :=
Make_Defining_Identifier (Loc,
if not Is_Ancestor (Iface_Typ, Tagged_Typ) then Chars => New_Internal_Name ('T'));
Thunk_Id :=
Make_Defining_Identifier (Loc, Insert_Actions (N, New_List (
Chars => New_Internal_Name ('T')); Expand_Interface_Thunk
(N => Prim,
Insert_Actions (N, New_List ( Thunk_Alias => Prim,
Expand_Interface_Thunk Thunk_Id => Thunk_Id),
(N => Prim,
Thunk_Alias => Prim, Build_Set_Predefined_Prim_Op_Address (Loc,
Thunk_Id => Thunk_Id), Tag_Node =>
New_Reference_To (Node (Iface_DT_Ptr), Loc),
Make_DT_Access_Action (Iface_Typ, Position_Node =>
Action => Set_Predefined_Prim_Op_Address, Make_Integer_Literal (Loc, DT_Position (Prim)),
Args => New_List ( Address_Node =>
Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc,
New_Reference_To (Node (Iface_DT_Ptr), Loc)), Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address))));
Make_Integer_Literal (Loc, DT_Position (Prim)),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)))));
end if;
Next_Elmt (Iface_DT_Ptr); Next_Elmt (Iface_DT_Ptr);
Next_Elmt (Iface_Elmt);
end loop; end loop;
end Register_Predefined_DT_Entry; end Register_Predefined_DT_Entry;
...@@ -4537,8 +4875,7 @@ package body Exp_Ch6 is ...@@ -4537,8 +4875,7 @@ package body Exp_Ch6 is
-- whose constructor is in the CPP side (and therefore we don't need -- whose constructor is in the CPP side (and therefore we don't need
-- to generate code to register them in the dispatch table). -- to generate code to register them in the dispatch table).
if not Debug_Flag_QQ if Is_Imported (E)
and then Is_Imported (E)
and then Convention (E) = Convention_CPP and then Convention (E) = Convention_CPP
then then
return; return;
...@@ -4551,7 +4888,7 @@ package body Exp_Ch6 is ...@@ -4551,7 +4888,7 @@ package body Exp_Ch6 is
-- the dispatching mechanism is handled internally by the JVM. -- the dispatching mechanism is handled internally by the JVM.
if Is_Dispatching_Operation (E) if Is_Dispatching_Operation (E)
and then not Is_Abstract (E) and then not Is_Abstract_Subprogram (E)
and then Present (DTC_Entity (E)) and then Present (DTC_Entity (E))
and then not Java_VM and then not Java_VM
and then not Is_CPP_Class (Scope (DTC_Entity (E))) and then not Is_CPP_Class (Scope (DTC_Entity (E)))
...@@ -4560,43 +4897,48 @@ package body Exp_Ch6 is ...@@ -4560,43 +4897,48 @@ package body Exp_Ch6 is
-- Ada 95 case: Register the subprogram in the primary dispatch table -- Ada 95 case: Register the subprogram in the primary dispatch table
if Ada_Version < Ada_05 then -- Do not register the subprogram in the dispatch table if we are
-- compiling under No_Dispatching_Calls restriction.
-- Do not register the subprogram in the dispatch table if we if not Restriction_Active (No_Dispatching_Calls) then
-- are compiling with the No_Dispatching_Calls restriction.
if not Restriction_Active (No_Dispatching_Calls) then if Ada_Version < Ada_05 then
Insert_After (N, Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E)); Fill_DT_Entry (Sloc (N), Prim => E));
end if;
-- Ada 2005 case: Register the subprogram in the secondary dispatch -- Ada 2005 case: Register the subprogram in all the dispatch
-- tables associated with abstract interfaces. -- tables associated with the type
else else
declare declare
Typ : constant Entity_Id := Scope (DTC_Entity (E)); Typ : constant Entity_Id := Scope (DTC_Entity (E));
begin begin
-- There is no dispatch table associated with abstract if not Is_Interface (Typ)
-- interface types. Each type implementing interfaces will and then Is_Predefined_Dispatching_Operation (E)
-- fill the associated secondary DT entries. then
Register_Predefined_DT_Entry (E);
Insert_After (N, Fill_DT_Entry (Sloc (N), Prim => E));
if not Is_Interface (Typ) -- There is no dispatch table associated with abstract
or else Present (Alias (E)) -- interface types. Each type implementing interfaces will
then -- fill the associated secondary DT entries.
-- Ada 2005 (AI-251): Check if this entry corresponds with
-- a subprogram that covers an abstract interface type.
if Present (Abstract_Interface_Alias (E)) then elsif not Is_Interface (Typ)
Register_Interface_DT_Entry (N, E); or else Present (Alias (E))
then
-- Ada 2005 (AI-251): Check if this entry corresponds
-- with a subprogram that covers an abstract interface
-- type.
-- Common case: Primitive subprogram if Present (Abstract_Interface_Alias (E)) then
Register_Interface_DT_Entry (N, E);
else -- Common case: Primitive subprogram
-- Generate thunks for all the predefined operations
else
-- Generate thunks for all the predefined operations
if not Restriction_Active (No_Dispatching_Calls) then
if Is_Predefined_Dispatching_Operation (E) then if Is_Predefined_Dispatching_Operation (E) then
Register_Predefined_DT_Entry (E); Register_Predefined_DT_Entry (E);
end if; end if;
...@@ -4605,8 +4947,8 @@ package body Exp_Ch6 is ...@@ -4605,8 +4947,8 @@ package body Exp_Ch6 is
Fill_DT_Entry (Sloc (N), Prim => E)); Fill_DT_Entry (Sloc (N), Prim => E));
end if; end if;
end if; end if;
end if; end;
end; end if;
end if; end if;
end if; end if;
...@@ -4622,9 +4964,7 @@ package body Exp_Ch6 is ...@@ -4622,9 +4964,7 @@ package body Exp_Ch6 is
if Is_Inherently_Limited_Type (Typ) then if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (E); Set_Returns_By_Ref (E);
elsif Present (Utyp) elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
and then (Is_Class_Wide_Type (Utyp) or else Controlled_Type (Utyp))
then
Set_Returns_By_Ref (E); Set_Returns_By_Ref (E);
end if; end if;
end; end;
...@@ -4665,43 +5005,79 @@ package body Exp_Ch6 is ...@@ -4665,43 +5005,79 @@ package body Exp_Ch6 is
Result_Subt := Etype (Function_Id); Result_Subt := Etype (Function_Id);
-- Replace the initialized allocator of form "new T'(Func (...))" with -- When the result subtype is constrained, the return object must be
-- an uninitialized allocator of form "new T", where T is the result -- allocated on the caller side, and access to it is passed to the
-- subtype of the called function. The call to the function is handled -- function.
-- separately further below.
New_Allocator := if Is_Constrained (Result_Subt) then
Make_Allocator (Loc, New_Reference_To (Result_Subt, Loc));
Set_No_Initialization (New_Allocator);
Rewrite (Allocator, New_Allocator); -- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
-- result subtype of the called function. The call to the function
-- is handled separately further below.
-- Create a new access object and initialize it to the result of the new New_Allocator :=
-- uninitialized allocator. Make_Allocator (Loc, New_Reference_To (Result_Subt, Loc));
Return_Obj_Access := Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator));
Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator));
Set_Etype (Return_Obj_Access, Acc_Type); Set_No_Initialization (New_Allocator);
Insert_Action (Allocator, Rewrite (Allocator, New_Allocator);
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Obj_Access,
Object_Definition => New_Reference_To (Acc_Type, Loc),
Expression => Relocate_Node (Allocator)));
-- Add an implicit actual to the function call that provides access to -- Create a new access object and initialize it to the result of the
-- the allocated object. An unchecked conversion to the (specific) -- new uninitialized allocator.
-- result subtype of the function is inserted to handle the case where
-- the access type of the allocator has a class-wide designated type.
Add_Access_Actual_To_Build_In_Place_Call Return_Obj_Access :=
(Func_Call, Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Function_Id, Set_Etype (Return_Obj_Access, Acc_Type);
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Result_Subt, Loc), Insert_Action (Allocator,
Expression => Make_Object_Declaration (Loc,
Make_Explicit_Dereference (Loc, Defining_Identifier => Return_Obj_Access,
Prefix => New_Reference_To (Return_Obj_Access, Loc)))); Object_Definition => New_Reference_To (Acc_Type, Loc),
Expression => Relocate_Node (Allocator)));
-- Add an implicit actual to the function call that provides access
-- to the allocated object. An unchecked conversion to the (specific)
-- result subtype of the function is inserted to handle cases where
-- the access type of the allocator has a class-wide designated type.
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Result_Subt, Loc),
Expression =>
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Return_Obj_Access, Loc))));
-- When the result subtype is unconstrained, the function itself must
-- perform the allocation of the return object, so we pass parameters
-- indicating that. We don't yet handle the case where the allocation
-- must be done in a user-defined storage pool, which will require
-- passing another actual or two to provide allocation/deallocation
-- operations. ???
else
-- Pass an allocation parameter indicating that the function should
-- allocate its result on the heap.
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap);
-- The caller does not provide the return object in this case, so we
-- have to pass null for the object access actual.
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Object => Empty);
end if;
-- Finally, replace the allocator node with a reference to the result -- Finally, replace the allocator node with a reference to the result
-- of the function call itself (which will effectively be an access -- of the function call itself (which will effectively be an access
...@@ -4744,28 +5120,60 @@ package body Exp_Ch6 is ...@@ -4744,28 +5120,60 @@ package body Exp_Ch6 is
Result_Subt := Etype (Function_Id); Result_Subt := Etype (Function_Id);
-- Create a temporary object to hold the function result -- When the result subtype is constrained, an object of the subtype is
-- declared and an access value designating it is passed as an actual.
Return_Obj_Id := if Is_Constrained (Result_Subt) then
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
Set_Etype (Return_Obj_Id, Result_Subt);
Return_Obj_Decl := -- Create a temporary object to hold the function result
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Obj_Id, Return_Obj_Id :=
Aliased_Present => True, Make_Defining_Identifier (Loc,
Object_Definition => New_Reference_To (Result_Subt, Loc)); Chars => New_Internal_Name ('R'));
Set_Etype (Return_Obj_Id, Result_Subt);
Set_No_Initialization (Return_Obj_Decl); Return_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Obj_Id,
Aliased_Present => True,
Object_Definition => New_Reference_To (Result_Subt, Loc));
Insert_Action (Func_Call, Return_Obj_Decl); Set_No_Initialization (Return_Obj_Decl);
-- Add an implicit actual to the function call that provides access to Insert_Action (Func_Call, Return_Obj_Decl);
-- the caller's return object.
Add_Access_Actual_To_Build_In_Place_Call -- Add an implicit actual to the function call that provides access
(Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); -- to the caller's return object.
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc));
-- When the result subtype is unconstrained, the function must allocate
-- the return object in the secondary stack, so appropriate implicit
-- parameters are added to the call to indicate that. A transient
-- scope is established to ensure eventual cleanup of the result.
else
-- Pass an allocation parameter indicating that the function should
-- allocate its result on the secondary stack.
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
-- Pass a null value to the function since no return object is
-- available on the caller side.
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Empty);
Establish_Transient_Scope (Func_Call, Sec_Stack => True);
end if;
end Make_Build_In_Place_Call_In_Anonymous_Context; end Make_Build_In_Place_Call_In_Anonymous_Context;
--------------------------------------------------- ---------------------------------------------------
...@@ -4805,9 +5213,20 @@ package body Exp_Ch6 is ...@@ -4805,9 +5213,20 @@ package body Exp_Ch6 is
Result_Subt := Etype (Function_Id); Result_Subt := Etype (Function_Id);
-- When the result subtype is unconstrained, an additional actual must
-- be passed to indicate that the caller is providing the return object.
if not Is_Constrained (Result_Subt) then
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if;
-- Add an implicit actual to the function call that provides access to -- Add an implicit actual to the function call that provides access to
-- the caller's return object. -- the caller's return object.
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
Add_Access_Actual_To_Build_In_Place_Call Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, (Func_Call,
Function_Id, Function_Id,
...@@ -4860,14 +5279,20 @@ package body Exp_Ch6 is ...@@ -4860,14 +5279,20 @@ package body Exp_Ch6 is
(Object_Decl : Node_Id; (Object_Decl : Node_Id;
Function_Call : Node_Id) Function_Call : Node_Id)
is is
Loc : Source_Ptr; Loc : Source_Ptr;
Func_Call : Node_Id := Function_Call; Obj_Def_Id : constant Entity_Id :=
Function_Id : Entity_Id; Defining_Identifier (Object_Decl);
Result_Subt : Entity_Id; Func_Call : Node_Id := Function_Call;
Ref_Type : Entity_Id; Function_Id : Entity_Id;
Ptr_Typ_Decl : Node_Id; Result_Subt : Entity_Id;
Def_Id : Entity_Id; Caller_Object : Node_Id;
New_Expr : Node_Id; Call_Deref : Node_Id;
Ref_Type : Entity_Id;
Ptr_Typ_Decl : Node_Id;
Def_Id : Entity_Id;
New_Expr : Node_Id;
Enclosing_Func : Entity_Id;
Pass_Caller_Acc : Boolean := False;
begin begin
if Nkind (Func_Call) = N_Qualified_Expression then if Nkind (Func_Call) = N_Qualified_Expression then
...@@ -4888,18 +5313,96 @@ package body Exp_Ch6 is ...@@ -4888,18 +5313,96 @@ package body Exp_Ch6 is
Result_Subt := Etype (Function_Id); Result_Subt := Etype (Function_Id);
-- Add an implicit actual to the function call that provides access to -- In the constrained case, add an implicit actual to the function call
-- the declared object. An unchecked conversion to the (specific) result -- that provides access to the declared object. An unchecked conversion
-- type of the function is inserted to handle the case where the object -- to the (specific) result type of the function is inserted to handle
-- is declared with a class-wide type. -- the case where the object is declared with a class-wide type.
if Is_Constrained (Result_Subt) then
Caller_Object :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Result_Subt, Loc),
Expression => New_Reference_To (Obj_Def_Id, Loc));
-- If the function's result subtype is unconstrained and the object is
-- a return object of an enclosing build-in-place function, then the
-- implicit build-in-place parameters of the enclosing function must be
-- passed along to the called function.
elsif Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement then
Pass_Caller_Acc := True;
Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
-- If the enclosing function has a constrained result type, then
-- caller allocation will be used.
if Is_Constrained (Etype (Enclosing_Func)) then
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-- Otherwise, when the enclosing function has an unconstrained result
-- type, the BIP_Alloc_Form formal of the enclosing function must be
-- passed long to the callee.
else
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
Alloc_Form_Exp =>
New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
Loc));
end if;
-- 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_Reference_To
(Etype
(Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
Loc),
Expression =>
New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
Loc));
-- In other unconstrained 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.
else
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
Alloc_Form => Secondary_Stack);
Caller_Object := Empty;
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
and then Has_Task (Result_Subt)
then
Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id,
Master_Actual =>
New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc));
-- Here we're passing along the master that was passed in to this
-- function.
else
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
end if;
Add_Access_Actual_To_Build_In_Place_Call Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
Function_Id,
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Result_Subt, Loc),
Expression => New_Reference_To
(Defining_Identifier (Object_Decl), Loc)));
-- Create an access type designating the function's result subtype -- Create an access type designating the function's result subtype
...@@ -4915,7 +5418,18 @@ package body Exp_Ch6 is ...@@ -4915,7 +5418,18 @@ package body Exp_Ch6 is
Subtype_Indication => Subtype_Indication =>
New_Reference_To (Result_Subt, Loc))); New_Reference_To (Result_Subt, Loc)));
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); -- 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 unconstrained case,
-- 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.
if Is_Constrained (Result_Subt) then
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
else
Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl);
end if;
-- Finally, create an access object initialized to a reference to the -- Finally, create an access object initialized to a reference to the
-- function call. -- function call.
...@@ -4935,8 +5449,44 @@ package body Exp_Ch6 is ...@@ -4935,8 +5449,44 @@ package body Exp_Ch6 is
Object_Definition => New_Reference_To (Ref_Type, Loc), Object_Definition => New_Reference_To (Ref_Type, Loc),
Expression => New_Expr)); Expression => New_Expr));
Set_Expression (Object_Decl, Empty); if Is_Constrained (Result_Subt) then
Set_No_Initialization (Object_Decl); Set_Expression (Object_Decl, Empty);
Set_No_Initialization (Object_Decl);
-- In case of an unconstrained result subtype, 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;
else
Call_Deref :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Def_Id, Loc));
Rewrite (Object_Decl,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Access_Definition => Empty,
Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
Name => Call_Deref));
Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref);
Analyze (Object_Decl);
-- Replace the internal identifier of the renaming declaration's
-- entity with identifier of the original object entity. We also have
-- to exchange the entities containing their defining identifiers to
-- ensure the correct replacement of the object declaration by the
-- object renaming declaration to avoid homograph conflicts (since
-- the object declaration's defining identifier was already entered
-- in current scope).
Set_Chars (Defining_Identifier (Object_Decl), Chars (Obj_Def_Id));
Exchange_Entities (Defining_Identifier (Object_Decl), Obj_Def_Id);
end if;
-- If the object entity has a class-wide Etype, then we need to change -- 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 -- it to the result subtype of the function call, because otherwise the
...@@ -4980,7 +5530,7 @@ package body Exp_Ch6 is ...@@ -4980,7 +5530,7 @@ package body Exp_Ch6 is
pragma Assert (Is_Interface (Iface_Typ)); pragma Assert (Is_Interface (Iface_Typ));
if not Is_Ancestor (Iface_Typ, Tagged_Typ) then if not Is_Parent (Iface_Typ, Tagged_Typ) then
Thunk_Id := Thunk_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T')); Chars => New_Internal_Name ('T'));
......
gcc/ada/exp_ch6.ads
...@@ -40,21 +40,83 @@ package Exp_Ch6 is ...@@ -40,21 +40,83 @@ package Exp_Ch6 is
-- This procedure contains common processing for Expand_N_Function_Call, -- This procedure contains common processing for Expand_N_Function_Call,
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
procedure Freeze_Subprogram (N : Node_Id);
-- generate the appropriate expansions related to Subprogram freeze
-- nodes (e. g. the filling of the corresponding Dispatch Table for
-- Primitive Operations)
-- The following type defines the various forms of allocation used for the
-- results of build-in-place function calls.
type BIP_Allocation_Form is
(Unspecified,
Caller_Allocation,
Secondary_Stack,
Global_Heap,
User_Storage_Pool);
type BIP_Formal_Kind is
-- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra
-- formals created for build-in-place functions. The order of the above
-- enumeration literals matches the order in which the formals are
-- declared. See Sem_Ch6.Create_Extra_Formals.
(BIP_Alloc_Form,
-- Present if result subtype is unconstrained. Indicates whether the
-- return object is allocated by the caller or callee, and if the
-- callee, whether to use the secondary stack or the heap. See
-- Create_Extra_Formals.
BIP_Final_List,
-- Present if result type has controlled parts. Pointer to caller's
-- finalization list.
BIP_Master,
-- Present if result type contains tasks. Master associated with
-- calling context.
BIP_Activation_Chain,
-- Present if result type contains tasks. Caller's activation chain.
BIP_Object_Access);
-- Present for all build-in-place functions. Address at which to place
-- the return object, or null if BIP_Alloc_Form indicates
-- allocated by callee.
-- ??? We also need to be able to pass in some way to access a
-- user-defined storage pool at some point. And perhaps a constrained
-- flag.
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id;
-- Ada 2005 (AI-318-02): Locates and returns the entity for the implicit
-- build-in-place formal parameter of the given kind associated with the
-- function Func, and returns its Entity_Id. It is a bug if not found; the
-- caller should ensure this is called only when the extra formal exists.
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function or an -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- access-to-function type whose result must be built in place; otherwise -- function, or access-to-function type whose result must be built in
-- returns False. Currently this is restricted to the subset of functions -- place; otherwise returns False. For Ada 2005, this is currently
-- whose result subtype is a constrained inherently limited type. -- restricted to the set of functions whose result subtype is an inherently
-- limited type. In Ada 95, this must be False for inherently limited
-- result types (but currently returns False for all Ada 95 functions).
-- Eventually we plan to support build-in-place for nonlimited types.
-- Build-in-place is usually more efficient for large things, and less
-- efficient for small things. However, we never use build-in-place if the
-- convention is other than Ada, because that would disturb mixed-language
-- programs. Note that for the non-inherently-limited cases, we must make
-- the same decision for Ada 95 and 2005, so that mixed-dialect programs
-- will work.
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean; function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function
-- that requires handling as a build-in-place call or is a qualified -- that requires handling as a build-in-place call or is a qualified
-- expression applied to such a call; otherwise returns False. -- expression applied to such a call; otherwise returns False.
procedure Freeze_Subprogram (N : Node_Id); function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean;
-- generate the appropriate expansions related to Subprogram freeze -- Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or
-- nodes (e. g. the filling of the corresponding Dispatch Table for -- N_Extended_Return_Statement and it applies to a build-in-place function
-- Primitive Operations) -- or generic function.
procedure Make_Build_In_Place_Call_In_Allocator procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id; (Allocator : Node_Id;
...@@ -84,7 +146,7 @@ package Exp_Ch6 is ...@@ -84,7 +146,7 @@ package Exp_Ch6 is
Function_Call : Node_Id); Function_Call : Node_Id);
-- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
-- occurs as the right-hand side of an assignment statement by passing -- occurs as the right-hand side of an assignment statement by passing
-- access to the left-hand sid as an additional parameter of the function -- access to the left-hand side as an additional parameter of the function
-- call. Assign must denote a N_Assignment_Statement. Function_Call must -- call. Assign must denote a N_Assignment_Statement. Function_Call must
-- denote either an N_Function_Call node for which Is_Build_In_Place_Call -- denote either an N_Function_Call node for which Is_Build_In_Place_Call
-- is True, or an N_Qualified_Expression node applied to such a function -- is True, or an N_Qualified_Expression node applied to such a function
......
gcc/ada/exp_ch8.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -26,10 +26,12 @@ ...@@ -26,10 +26,12 @@
with Atree; use Atree; with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug; with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze; with Freeze; use Freeze;
with Nlists; use Nlists; with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
...@@ -268,6 +270,19 @@ package body Exp_Ch8 is ...@@ -268,6 +270,19 @@ package body Exp_Ch8 is
end if; end if;
end if; end if;
-- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
-- place function, then a temporary return object needs to be created
-- and access to it must be passed to the function. Currently we limit
-- such functions to those with inherently limited result subtypes, but
-- eventually we plan to expand the functions that are treated as
-- build-in-place to include other composite result types.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Nam)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information -- Create renaming entry for debug information
Decl := Debug_Renaming_Declaration (N); Decl := Debug_Renaming_Declaration (N);
......
gcc/ada/rtsfind.adb
...@@ -54,8 +54,10 @@ with Uname; use Uname; ...@@ -54,8 +54,10 @@ with Uname; use Uname;
package body Rtsfind is package body Rtsfind is
RTE_Available_Call : Boolean := False; RTE_Available_Call : Boolean := False;
-- Set True during call to RTE from RTE_Available. Tells RTE to set -- Set True during call to RTE from RTE_Available (or from call to
-- RTE_Is_Available to False rather than generating an error message. -- RTE_Record_Component from RTE_Record_Component_Available). Tells
-- the called subprogram to set RTE_Is_Available to False rather than
-- generating an error message.
RTE_Is_Available : Boolean; RTE_Is_Available : Boolean;
-- Set True by RTE_Available on entry. When RTE_Available_Call is set -- Set True by RTE_Available on entry. When RTE_Available_Call is set
...@@ -97,6 +99,11 @@ package body Rtsfind is ...@@ -97,6 +99,11 @@ package body Rtsfind is
-- first time, its ID is stored in this array, so that subsequent calls -- first time, its ID is stored in this array, so that subsequent calls
-- for the same entity can be satisfied immediately. -- for the same entity can be satisfied immediately.
-- NOTE: In order to avoid conflicts between record components and subprgs
-- that have the same name (ie. subprogram External_Tag and component
-- External_Tag of package Ada.Tags) this table is not used with
-- Record_Components.
RE_Table : array (RE_Id) of Entity_Id; RE_Table : array (RE_Id) of Entity_Id;
-------------------------- --------------------------
...@@ -123,11 +130,20 @@ package body Rtsfind is ...@@ -123,11 +130,20 @@ package body Rtsfind is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id;
-- Check entity Eid to ensure that configurable run-time restrictions
-- are met. May generate an error message and raise RE_Not_Available
-- if the entity E does not exist (i.e. Eid is Empty)
procedure Entity_Not_Defined (Id : RE_Id); procedure Entity_Not_Defined (Id : RE_Id);
-- Outputs error messages for an entity that is not defined in the -- Outputs error messages for an entity that is not defined in the
-- run-time library (the form of the error message is tailored for -- run-time library (the form of the error message is tailored for
-- no run time/configurable run time mode as required). -- no run time/configurable run time mode as required).
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumeration value in RTU_Id.
procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id);
-- Internal procedure called if we can't sucessfully locate or -- Internal procedure called if we can't sucessfully locate or
-- process a run-time unit. The parameters give information about -- process a run-time unit. The parameters give information about
...@@ -144,10 +160,6 @@ package body Rtsfind is ...@@ -144,10 +160,6 @@ package body Rtsfind is
-- a normal situation in configurable run-time mode (and the message in -- a normal situation in configurable run-time mode (and the message in
-- this case is suppressed unless we are operating in All_Errors_Mode). -- this case is suppressed unless we are operating in All_Errors_Mode).
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumeration value in RTU_Id.
procedure Load_RTU procedure Load_RTU
(U_Id : RTU_Id; (U_Id : RTU_Id;
Id : RE_Id := RE_Null; Id : RE_Id := RE_Null;
...@@ -165,6 +177,10 @@ package body Rtsfind is ...@@ -165,6 +177,10 @@ package body Rtsfind is
-- Id is used only for error message detail, and if it is RE_Null, then -- Id is used only for error message detail, and if it is RE_Null, then
-- the attempt to output the entity name is ignored. -- the attempt to output the entity name is ignored.
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use in
-- With_Clause.
procedure Output_Entity_Name (Id : RE_Id; Msg : String); procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity -- Output continuation error message giving qualified name of entity
-- corresponding to Id, appending the string given by Msg. This call -- corresponding to Id, appending the string given by Msg. This call
...@@ -181,6 +197,37 @@ package body Rtsfind is ...@@ -181,6 +197,37 @@ package body Rtsfind is
-- used if you are sure that the message comes directly or indirectly from -- used if you are sure that the message comes directly or indirectly from
-- a call to the RTE function. -- a call to the RTE function.
---------------
-- Check_CRT --
---------------
function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
begin
if No (Eid) then
Entity_Not_Defined (E);
raise RE_Not_Available;
-- Entity is available
else
-- If in No_Run_Time mode and entity is not in one of the
-- specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
then
Entity_Not_Defined (E);
raise RE_Not_Available;
end if;
-- Otherwise entity is accessible
return Eid;
end if;
end Check_CRT;
------------------------ ------------------------
-- Entity_Not_Defined -- -- Entity_Not_Defined --
------------------------ ------------------------
...@@ -658,6 +705,36 @@ package body Rtsfind is ...@@ -658,6 +705,36 @@ package body Rtsfind is
end if; end if;
end Load_RTU; end Load_RTU;
--------------------
-- Make_Unit_Name --
--------------------
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
Nam : Node_Id;
Scop : Entity_Id;
begin
Nam := New_Reference_To (U.Entity, Standard_Location);
Scop := Scope (U.Entity);
if Nkind (N) = N_Defining_Program_Unit_Name then
while Scop /= Standard_Standard loop
Nam :=
Make_Expanded_Name (Standard_Location,
Chars => Chars (U.Entity),
Prefix => New_Reference_To (Scop, Standard_Location),
Selector_Name => Nam);
Set_Entity (Nam, U.Entity);
Scop := Scope (Scop);
end loop;
end if;
return Nam;
end Make_Unit_Name;
----------------------- -----------------------
-- Output_Entity_Name -- -- Output_Entity_Name --
------------------------ ------------------------
...@@ -763,11 +840,6 @@ package body Rtsfind is ...@@ -763,11 +840,6 @@ package body Rtsfind is
Save_Front_End_Inlining : Boolean; Save_Front_End_Inlining : Boolean;
function Check_CRT (Eid : Entity_Id) return Entity_Id;
-- Check entity Eid to ensure that configurable run-time restrictions
-- are met. May generate an error message and raise RE_Not_Available
-- if the entity E does not exist (i.e. Eid is Empty)
procedure Check_RPC; procedure Check_RPC;
-- Reject programs that make use of distribution features not supported -- Reject programs that make use of distribution features not supported
-- on the current target. On such targets (VMS, Vxworks, others?) we -- on the current target. On such targets (VMS, Vxworks, others?) we
...@@ -778,39 +850,6 @@ package body Rtsfind is ...@@ -778,39 +850,6 @@ package body Rtsfind is
-- This function is used when entity E is in this compilation's main -- This function is used when entity E is in this compilation's main
-- unit. It gets the value from the already compiled declaration. -- unit. It gets the value from the already compiled declaration.
function Make_Unit_Name (N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use
-- in With_Clause.
---------------
-- Check_CRT --
---------------
function Check_CRT (Eid : Entity_Id) return Entity_Id is
begin
if No (Eid) then
Entity_Not_Defined (E);
raise RE_Not_Available;
-- Entity is available
else
-- If in No_Run_Time mode and entity is not in one of the
-- specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
then
Entity_Not_Defined (E);
raise RE_Not_Available;
end if;
-- Otherwise entity is accessible
return Eid;
end if;
end Check_CRT;
--------------- ---------------
-- Check_RPC -- -- Check_RPC --
--------------- ---------------
...@@ -847,9 +886,9 @@ package body Rtsfind is ...@@ -847,9 +886,9 @@ package body Rtsfind is
end if; end if;
end Check_RPC; end Check_RPC;
------------------------ -----------------------
-- Find_System_Entity -- -- Find_Local_Entity --
------------------------ -----------------------
function Find_Local_Entity (E : RE_Id) return Entity_Id is function Find_Local_Entity (E : RE_Id) return Entity_Id is
RE_Str : String renames RE_Id'Image (E); RE_Str : String renames RE_Id'Image (E);
...@@ -871,34 +910,6 @@ package body Rtsfind is ...@@ -871,34 +910,6 @@ package body Rtsfind is
return Ent; return Ent;
end Find_Local_Entity; end Find_Local_Entity;
--------------------
-- Make_Unit_Name --
--------------------
function Make_Unit_Name (N : Node_Id) return Node_Id is
Nam : Node_Id;
Scop : Entity_Id;
begin
Nam := New_Reference_To (U.Entity, Standard_Location);
Scop := Scope (U.Entity);
if Nkind (N) = N_Defining_Program_Unit_Name then
while Scop /= Standard_Standard loop
Nam :=
Make_Expanded_Name (Standard_Location,
Chars => Chars (U.Entity),
Prefix => New_Reference_To (Scop, Standard_Location),
Selector_Name => Nam);
Set_Entity (Nam, U.Entity);
Scop := Scope (Scop);
end loop;
end if;
return Nam;
end Make_Unit_Name;
-- Start of processing for RTE -- Start of processing for RTE
begin begin
...@@ -917,7 +928,7 @@ package body Rtsfind is ...@@ -917,7 +928,7 @@ package body Rtsfind is
and then Analyzed (Main_Unit_Entity) and then Analyzed (Main_Unit_Entity)
and then not Is_Child_Unit (Main_Unit_Entity) and then not Is_Child_Unit (Main_Unit_Entity)
then then
return Check_CRT (Find_Local_Entity (E)); return Check_CRT (E, Find_Local_Entity (E));
end if; end if;
Save_Front_End_Inlining := Front_End_Inlining; Save_Front_End_Inlining := Front_End_Inlining;
...@@ -947,16 +958,16 @@ package body Rtsfind is ...@@ -947,16 +958,16 @@ package body Rtsfind is
-- First we search the package entity chain -- First we search the package entity chain
Pkg_Ent := First_Entity (U.Entity); Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent; RE_Table (E) := Pkg_Ent;
Check_RPC; Check_RPC;
goto Found; goto Found;
end if; end if;
Next_Entity (Pkg_Ent); Next_Entity (Pkg_Ent);
end loop; end loop;
-- If we did not find the entity in the package entity chain, -- If we did not find the entity in the package entity chain,
-- then check if the package entity itself matches. Note that -- then check if the package entity itself matches. Note that
...@@ -979,7 +990,7 @@ package body Rtsfind is ...@@ -979,7 +990,7 @@ package body Rtsfind is
-- a WITH if the current unit is part of the extended main code -- a WITH if the current unit is part of the extended main code
-- unit, and if we have not already added the with. The WITH is -- unit, and if we have not already added the with. The WITH is
-- added to the appropriate unit (the current one). We do not need -- added to the appropriate unit (the current one). We do not need
-- to generate a WITH for an ???? -- to generate a WITH for a call issued from RTE_Available.
<<Found>> <<Found>>
if (not U.Withed) if (not U.Withed)
...@@ -999,7 +1010,7 @@ package body Rtsfind is ...@@ -999,7 +1010,7 @@ package body Rtsfind is
Make_With_Clause (Standard_Location, Make_With_Clause (Standard_Location,
Name => Name =>
Make_Unit_Name Make_Unit_Name
(Defining_Unit_Name (Specification (Lib_Unit)))); (E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum)); Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity); Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True); Set_First_Name (Withn, True);
...@@ -1012,7 +1023,7 @@ package body Rtsfind is ...@@ -1012,7 +1023,7 @@ package body Rtsfind is
end if; end if;
Front_End_Inlining := Save_Front_End_Inlining; Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (RE_Table (E)); return Check_CRT (E, RE_Table (E));
end RTE; end RTE;
------------------- -------------------
...@@ -1047,6 +1058,140 @@ package body Rtsfind is ...@@ -1047,6 +1058,140 @@ package body Rtsfind is
return False; return False;
end RTE_Available; end RTE_Available;
--------------------------
-- RTE_Record_Component --
--------------------------
function RTE_Record_Component (E : RE_Id) return Entity_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
E1 : Entity_Id;
Ename : Name_Id;
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
-- The following flag is used to disable front-end inlining when
-- RTE_Record_Component is invoked. This prevents the analysis of other
-- runtime bodies when a particular spec is loaded through Rtsfind. This
-- is both efficient, and it prevents spurious visibility conflicts
-- between use-visible user entities, and entities in run-time packages.
-- In configurable run-time mode, subprograms marked Inlined_Always must
-- be inlined, so in the case we retain the Front_End_Inlining mode.
Save_Front_End_Inlining : Boolean;
begin
-- Note: Contrary to subprogram RTE, there is no need to do any special
-- management with package system.ads because it has no record type
-- declarations.
Save_Front_End_Inlining := Front_End_Inlining;
Front_End_Inlining := Configurable_Run_Time_Mode;
-- Load unit if unit not previously loaded
if not Present (U.Entity) then
Load_RTU (U_Id, Id => E);
end if;
Lib_Unit := Unit (Cunit (U.Unum));
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
-- Search the entity in the components of record type declarations
-- found in the package entity chain.
Pkg_Ent := First_Entity (U.Entity);
Search : while Present (Pkg_Ent) loop
if Is_Record_Type (Pkg_Ent) then
E1 := First_Entity (Pkg_Ent);
while Present (E1) loop
if Ename = Chars (E1) then
exit Search;
end if;
Next_Entity (E1);
end loop;
end if;
Next_Entity (Pkg_Ent);
end loop Search;
-- If we didn't find the entity we want, something is wrong. The
-- appropriate action will be taken by Check_CRT when we exit.
-- Cenerate a with-clause if the current unit is part of the extended
-- main code unit, and if we have not already added the with. The clause
-- is added to the appropriate unit (the current one). We do not need to
-- generate it for a call issued from RTE_Component_Available.
if (not U.Withed)
and then
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
and then not RTE_Available_Call
then
U.Withed := True;
declare
Withn : Node_Id;
Lib_Unit : Node_Id;
begin
Lib_Unit := Unit (Cunit (U.Unum));
Withn :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, E1);
end RTE_Record_Component;
------------------------------------
-- RTE_Record_Component_Available --
------------------------------------
function RTE_Record_Component_Available (E : RE_Id) return Boolean is
Dummy : Entity_Id;
pragma Warnings (Off, Dummy);
Result : Boolean;
Save_RTE_Available_Call : constant Boolean := RTE_Available_Call;
Save_RTE_Is_Available : constant Boolean := RTE_Is_Available;
-- These are saved recursively because the call to load a unit
-- caused by an upper level call may perform a recursive call
-- to this routine during analysis of the corresponding unit.
begin
RTE_Available_Call := True;
RTE_Is_Available := True;
Dummy := RTE_Record_Component (E);
Result := RTE_Is_Available;
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return Result;
exception
when RE_Not_Available =>
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return False;
end RTE_Record_Component_Available;
------------------- -------------------
-- RTE_Error_Msg -- -- RTE_Error_Msg --
------------------- -------------------
...@@ -1069,6 +1214,15 @@ package body Rtsfind is ...@@ -1069,6 +1214,15 @@ package body Rtsfind is
end RTE_Error_Msg; end RTE_Error_Msg;
---------------- ----------------
-- RTU_Entity --
----------------
function RTU_Entity (U : RTU_Id) return Entity_Id is
begin
return RT_Unit_Table (U).Entity;
end RTU_Entity;
----------------
-- RTU_Loaded -- -- RTU_Loaded --
---------------- ----------------
......
gcc/ada/s-finimp.adb
...@@ -168,7 +168,7 @@ package body System.Finalization_Implementation is ...@@ -168,7 +168,7 @@ package body System.Finalization_Implementation is
Nb_Link : Short_Short_Integer) Nb_Link : Short_Short_Integer)
is is
begin begin
-- Simple case: attachement to a one way list -- Simple case: attachment to a one way list
if Nb_Link = 1 then if Nb_Link = 1 then
Obj.Next := L; Obj.Next := L;
...@@ -176,7 +176,7 @@ package body System.Finalization_Implementation is ...@@ -176,7 +176,7 @@ package body System.Finalization_Implementation is
-- Dynamically allocated objects: they are attached to a doubly linked -- Dynamically allocated objects: they are attached to a doubly linked
-- list, so that an element can be finalized at any moment by means of -- list, so that an element can be finalized at any moment by means of
-- an unchecked deallocation. Attachement is protected against -- an unchecked deallocation. Attachment is protected against
-- multi-threaded access. -- multi-threaded access.
elsif Nb_Link = 2 then elsif Nb_Link = 2 then
...@@ -203,7 +203,7 @@ package body System.Finalization_Implementation is ...@@ -203,7 +203,7 @@ package body System.Finalization_Implementation is
raise; raise;
end Locked_Processing; end Locked_Processing;
-- Attachement of arrays to the final list (used only for objects -- Attachment of arrays to the final list (used only for objects
-- returned by function). Obj, in this case is the last element, -- returned by function). Obj, in this case is the last element,
-- but all other elements are already threaded after it. We just -- but all other elements are already threaded after it. We just
-- attach the rest of the final list at the end of the array list. -- attach the rest of the final list at the end of the array list.
...@@ -231,32 +231,6 @@ package body System.Finalization_Implementation is ...@@ -231,32 +231,6 @@ package body System.Finalization_Implementation is
end Attach_To_Final_List; end Attach_To_Final_List;
--------------------- ---------------------
-- Deep_Tag_Adjust --
---------------------
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer)
is
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
if Controller /= null then
Adjust (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
end if;
-- Is controlled
if V.all in Finalizable then
Adjust (V.all);
Attach_To_Final_List (L, Finalizable (V.all), 1);
end if;
end Deep_Tag_Adjust;
---------------------
-- Deep_Tag_Attach -- -- Deep_Tag_Attach --
---------------------- ----------------------
...@@ -280,74 +254,6 @@ package body System.Finalization_Implementation is ...@@ -280,74 +254,6 @@ package body System.Finalization_Implementation is
end if; end if;
end Deep_Tag_Attach; end Deep_Tag_Attach;
-----------------------
-- Deep_Tag_Finalize --
-----------------------
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean)
is
pragma Warnings (Off, L);
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
if Controller /= null then
if B then
Finalize_One (Controller.all);
else
Finalize (Controller.all);
end if;
end if;
-- Is controlled
if V.all in Finalizable then
if B then
Finalize_One (V.all);
else
Finalize (V.all);
end if;
end if;
end Deep_Tag_Finalize;
-------------------------
-- Deep_Tag_Initialize --
-------------------------
procedure Deep_Tag_Initialize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer)
is
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
-- This procedure should not be called if the object has no
-- controlled components
if Controller = null then
raise Program_Error;
-- Has controlled components
else
Initialize (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
end if;
-- Is controlled
if V.all in Finalizable then
Initialize (V.all);
Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1);
end if;
end Deep_Tag_Initialize;
----------------------------- -----------------------------
-- Detach_From_Final_List -- -- Detach_From_Final_List --
----------------------------- -----------------------------
...@@ -441,7 +347,7 @@ package body System.Finalization_Implementation is ...@@ -441,7 +347,7 @@ package body System.Finalization_Implementation is
-- programs using controlled types heavily. -- programs using controlled types heavily.
if System.Restrictions.Abort_Allowed then if System.Restrictions.Abort_Allowed then
X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id; X := To_Ptr (SSL.Get_Current_Excep.all).Id;
end if; end if;
while P /= null loop while P /= null loop
...@@ -554,6 +460,34 @@ package body System.Finalization_Implementation is ...@@ -554,6 +460,34 @@ package body System.Finalization_Implementation is
Object.My_Address := Object'Address; Object.My_Address := Object'Address;
end Initialize; end Initialize;
---------------------
-- Move_Final_List --
---------------------
procedure Move_Final_List
(From : in out SFR.Finalizable_Ptr;
To : Finalizable_Ptr_Ptr)
is
begin
-- This is currently called at the end of the return statement, and the
-- caller does NOT defer aborts. We need to defer aborts to prevent
-- mangling the finalization lists.
SSL.Abort_Defer.all;
-- Put the return statement's finalization list onto the caller's one,
-- thus transferring responsibility for finalization of the return
-- object to the caller.
Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
-- Empty the return statement's finalization list, so that when the
-- cleanup code executes, there will be nothing to finalize.
From := null;
SSL.Abort_Undefer.all;
end Move_Final_List;
------------------------- -------------------------
-- Raise_From_Finalize -- -- Raise_From_Finalize --
------------------------- -------------------------
......
gcc/ada/s-finimp.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2006 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -51,15 +51,15 @@ package System.Finalization_Implementation is ...@@ -51,15 +51,15 @@ package System.Finalization_Implementation is
Collection_Finalization_Started : constant SFR.Finalizable_Ptr := Collection_Finalization_Started : constant SFR.Finalizable_Ptr :=
To_Finalizable_Ptr (SSE.To_Address (1)); To_Finalizable_Ptr (SSE.To_Address (1));
-- This is used to implement the rule in RM-4.8(10.2/2) that requires an -- This is used to implement the rule in RM 4.8(10.2/2) that requires an
-- allocator to raise Program_Error if the collection finalization has -- allocator to raise Program_Error if the collection finalization has
-- already started. See also Ada.Finalization.List_Controller. Finalize on -- already started. See also Ada.Finalization.List_Controller. Finalize on
-- List_Controller first sets the list to Collection_Finalization_Started, -- List_Controller first sets the list to Collection_Finalization_Started,
-- to indicate that finalization has started. An allocator will call -- to indicate that finalization has started. An allocator will call
-- Attach_To_Final_List, which checks for the special value and raises -- Attach_To_Final_List, which checks for the special value and raises
-- Program_Error if appropriate. The value of -- Program_Error if appropriate. The Collection_Finalization_Started value
-- Collection_Finalization_Started must be different from 'Access of any -- must be different from 'Access of any finalizable object, and different
-- finalizable object, and different from null. See AI-280. -- from null. See AI-280.
Global_Final_List : SFR.Finalizable_Ptr; Global_Final_List : SFR.Finalizable_Ptr;
-- This list stores the controlled objects defined in library-level -- This list stores the controlled objects defined in library-level
...@@ -72,60 +72,52 @@ package System.Finalization_Implementation is ...@@ -72,60 +72,52 @@ package System.Finalization_Implementation is
(L : in out SFR.Finalizable_Ptr; (L : in out SFR.Finalizable_Ptr;
Obj : in out SFR.Finalizable; Obj : in out SFR.Finalizable;
Nb_Link : Short_Short_Integer); Nb_Link : Short_Short_Integer);
-- Attach finalizable object Obj to the linked list L. Nb_Link controls -- Attach finalizable object Obj to the linked list L. Nb_Link controls the
-- the number of link of the linked_list, and can be either 0 for no -- number of link of the linked_list, and is one of: 0 for no attachment, 1
-- attachement, 1 for simple linked lists or 2 for doubly linked lists -- for simple linked lists or 2 for doubly linked lists or even 3 for a
-- or even 3 for a simple attachement of a whole array of elements. -- simple attachment of a whole array of elements. Attachment to a simply
-- Attachement to a simply linked list is not protected against -- linked list is not protected against concurrent access and should only
-- concurrent access and should only be used in contexts where it -- be used in contexts where it doesn't matter, such as for objects
-- doesn't matter, such as for objects allocated on the stack. In the -- allocated on the stack. In the case of an attachment on a doubly linked
-- case of an attachment on a doubly linked list, L must not be null -- list, L must not be null and Obj will be inserted AFTER the first
-- and Obj will be inserted AFTER the first element and the attachment -- element and the attachment is protected against concurrent call.
-- is protected against concurrent call. Typically used to attach to -- Typically used to attach to a dynamically allocated object to a
-- a dynamically allocated object to a List_Controller (whose first -- List_Controller (whose first element is always a dummy element)
-- element is always a dummy element)
type Finalizable_Ptr_Ptr is access all SFR.Finalizable_Ptr;
-- A pointer to a finalization list. This is used as the type of the extra
-- implicit formal which are passed to build-in-place functions that return
-- controlled types (see Sem_Ch6). That extra formal is then passed on to
-- Move_Final_List (below).
procedure Move_Final_List
(From : in out SFR.Finalizable_Ptr;
To : Finalizable_Ptr_Ptr);
-- Move all objects on From list to To list. This is used to implement
-- build-in-place function returns. The return object is initially placed
-- on a finalization list local to the return statement, in case the
-- return statement is left prematurely (due to raising an exception,
-- being aborted, or a goto or exit statement). Once the return statement
-- has completed successfully, Move_Final_List is called to move the
-- return object to the caller's finalization list.
procedure Finalize_List (L : SFR.Finalizable_Ptr); procedure Finalize_List (L : SFR.Finalizable_Ptr);
-- Call Finalize on each element of the list L; -- Call Finalize on each element of the list L;
procedure Finalize_One (Obj : in out SFR.Finalizable); procedure Finalize_One (Obj : in out SFR.Finalizable);
-- Call Finalize on Obj and remove its final list. -- Call Finalize on Obj and remove its final list
--------------------- ---------------------
-- Deep Procedures -- -- Deep Procedures --
--------------------- ---------------------
procedure Deep_Tag_Initialize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic initialize for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic adjust for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean);
-- Generic finalize for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Attach procedure Deep_Tag_Attach
(L : in out SFR.Finalizable_Ptr; (L : in out SFR.Finalizable_Ptr;
A : System.Address; A : System.Address;
B : Short_Short_Integer); B : Short_Short_Integer);
-- Generic attachement for tagged objects with controlled components. -- Generic attachment for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs -- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List). -- to be attached and B the attachment level (see Attach_To_Final_List).
----------------------------- -----------------------------
-- Record Controller Types -- -- Record Controller Types --
...@@ -141,11 +133,11 @@ package System.Finalization_Implementation is ...@@ -141,11 +133,11 @@ package System.Finalization_Implementation is
end record; end record;
procedure Initialize (Object : in out Limited_Record_Controller); procedure Initialize (Object : in out Limited_Record_Controller);
-- Does nothing. -- Does nothing currently.
procedure Finalize (Object : in out Limited_Record_Controller); procedure Finalize (Object : in out Limited_Record_Controller);
-- Finalize the controlled components of the enclosing record by -- Finalize the controlled components of the enclosing record by following
-- following the list starting at Object.F. -- the list starting at Object.F.
type Record_Controller is type Record_Controller is
new Limited_Record_Controller with record new Limited_Record_Controller with record
...@@ -156,13 +148,13 @@ package System.Finalization_Implementation is ...@@ -156,13 +148,13 @@ package System.Finalization_Implementation is
-- Initialize the field My_Address to the Object'Address -- Initialize the field My_Address to the Object'Address
procedure Adjust (Object : in out Record_Controller); procedure Adjust (Object : in out Record_Controller);
-- Adjust the components and their finalization pointers by subtracting -- Adjust the components and their finalization pointers by subtracting by
-- by the offset of the target and the source addresses of the assignment. -- the offset of the target and the source addresses of the assignment.
-- Inherit Finalize from Limited_Record_Controller -- Inherit Finalize from Limited_Record_Controller
procedure Detach_From_Final_List (Obj : in out SFR.Finalizable); procedure Detach_From_Final_List (Obj : in out SFR.Finalizable);
-- Remove the specified object from its Final list, which must be a -- Remove the specified object from its Final list, which must be a doubly
-- doubly linked list. -- linked list.
end System.Finalization_Implementation; end System.Finalization_Implementation;
gcc/ada/s-taskin.ads
...@@ -364,10 +364,12 @@ package System.Tasking is ...@@ -364,10 +364,12 @@ package System.Tasking is
------------------------------------ ------------------------------------
type Activation_Chain is limited private; type Activation_Chain is limited private;
-- Comment required ??? -- Linked list of to-be-activated tasks, linked through
-- Activation_Link. The order of tasks on the list is irrelevant, because
-- the priority rules will ensure that they actually start activating in
-- priority order.
type Activation_Chain_Access is access all Activation_Chain; type Activation_Chain_Access is access all Activation_Chain;
-- Comment required ???
type Task_Procedure_Access is access procedure (Arg : System.Address); type Task_Procedure_Access is access procedure (Arg : System.Address);
...@@ -651,11 +653,14 @@ package System.Tasking is ...@@ -651,11 +653,14 @@ package System.Tasking is
-- Normally, a task starts out with internal master nesting level one -- Normally, a task starts out with internal master nesting level one
-- larger than external master nesting level. It is incremented to one by -- larger than external master nesting level. It is incremented to one by
-- Enter_Master, which is called in the task body only if the compiler -- Enter_Master, which is called in the task body only if the compiler
-- thinks the task may have dependent tasks. It is set to for the -- thinks the task may have dependent tasks. It is set to 1 for the
-- environment task, the level 2 is reserved for server tasks of the -- environment task, the level 2 is reserved for server tasks of the
-- run-time system (the so called "independent tasks"), and the level 3 is -- run-time system (the so called "independent tasks"), and the level 3 is
-- for the library level tasks. -- for the library level tasks. Foreign threads which are detected by
-- the run-time have a level of 0, allowing these tasks to be easily
-- distinguished if needed.
Foreign_Task_Level : constant Master_Level := 0;
Environment_Task_Level : constant Master_Level := 1; Environment_Task_Level : constant Master_Level := 1;
Independent_Task_Level : constant Master_Level := 2; Independent_Task_Level : constant Master_Level := 2;
Library_Task_Level : constant Master_Level := 3; Library_Task_Level : constant Master_Level := 3;
...@@ -1062,14 +1067,14 @@ package System.Tasking is ...@@ -1062,14 +1067,14 @@ package System.Tasking is
private private
Null_Task : constant Task_Id := null; Null_Task : constant Task_Id := null;
type Activation_Chain is record type Activation_Chain is limited record
T_ID : Task_Id; T_ID : Task_Id;
end record; end record;
pragma Volatile (Activation_Chain);
-- Activation_chain is an in-out parameter of initialization procedures -- Activation_Chain is an in-out parameter of initialization procedures and
-- and it must be passed by reference because the init proc may terminate -- it must be passed by reference because the init proc may terminate
-- abnormally after creating task components, and these must be properly -- abnormally after creating task components, and these must be properly
-- registered for removal (Expunge_Unactivated_Tasks). -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces
-- Activation_Chain to be a by-reference type; see RM-6.2(4).
end System.Tasking; end System.Tasking;
gcc/ada/s-tassta.adb
...@@ -149,6 +149,9 @@ package body System.Tasking.Stages is ...@@ -149,6 +149,9 @@ package body System.Tasking.Stages is
-- trigger an automatic stack alignment suitable for GCC's assumptions if -- trigger an automatic stack alignment suitable for GCC's assumptions if
-- need be. -- need be.
-- "Vulnerable_..." in the procedure names below means they must be called
-- with abort deferred.
procedure Vulnerable_Complete_Task (Self_ID : Task_Id); procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
-- Complete the calling task. This procedure must be called with -- Complete the calling task. This procedure must be called with
-- abort deferred. It should only be called by Complete_Task and -- abort deferred. It should only be called by Complete_Task and
...@@ -520,9 +523,11 @@ package body System.Tasking.Stages is ...@@ -520,9 +523,11 @@ package body System.Tasking.Stages is
begin begin
-- If Master is greater than the current master, it means that Master -- If Master is greater than the current master, it means that Master
-- has already awaited its dependent tasks. This raises Program_Error, -- has already awaited its dependent tasks. This raises Program_Error,
-- by 4.8(10.3/2). See AI-280. -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
if Master > Self_ID.Master_Within then if Self_ID.Master_of_Task /= Foreign_Task_Level
and then Master > Self_ID.Master_Within
then
raise Program_Error with raise Program_Error with
"create task after awaiting termination"; "create task after awaiting termination";
end if; end if;
...@@ -877,6 +882,53 @@ package body System.Tasking.Stages is ...@@ -877,6 +882,53 @@ package body System.Tasking.Stages is
end if; end if;
end Free_Task; end Free_Task;
---------------------------
-- Move_Activation_Chain --
---------------------------
procedure Move_Activation_Chain
(From, To : Activation_Chain_Access;
New_Master : Master_ID)
is
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
begin
pragma Debug
(Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
-- Nothing to do if From is empty, and we can check that without
-- deferring aborts.
C := From.all.T_ID;
if C = null then
return;
end if;
Initialization.Defer_Abort (Self_ID);
-- Loop through the From chain, changing their Master_of_Task
-- fields, and to find the end of the chain.
loop
C.Master_of_Task := New_Master;
exit when C.Common.Activation_Link = null;
C := C.Common.Activation_Link;
end loop;
-- Hook From in at the start of To
C.Common.Activation_Link := To.all.T_ID;
To.all.T_ID := From.all.T_ID;
-- Set From to empty
From.all.T_ID := null;
Initialization.Undefer_Abort (Self_ID);
end Move_Activation_Chain;
------------------ ------------------
-- Task_Wrapper -- -- Task_Wrapper --
------------------ ------------------
...@@ -1407,7 +1459,7 @@ package body System.Tasking.Stages is ...@@ -1407,7 +1459,7 @@ package body System.Tasking.Stages is
C := All_Tasks_List; C := All_Tasks_List;
while C /= null loop while C /= null loop
if C.Common.Activator = Self_ID then if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
return False; return False;
end if; end if;
...@@ -1449,13 +1501,24 @@ package body System.Tasking.Stages is ...@@ -1449,13 +1501,24 @@ package body System.Tasking.Stages is
-- zero for new tasks, and the task should not exit the -- zero for new tasks, and the task should not exit the
-- sleep-loops that use this count until the count reaches zero. -- sleep-loops that use this count until the count reaches zero.
-- While we're counting, if we run across any unactivated tasks that
-- belong to this master, we summarily terminate them as required by
-- RM-9.2(6).
Lock_RTS; Lock_RTS;
Write_Lock (Self_ID); Write_Lock (Self_ID);
C := All_Tasks_List; C := All_Tasks_List;
while C /= null loop while C /= null loop
if C.Common.Activator = Self_ID then
-- Terminate unactivated (never-to-be activated) tasks
if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
pragma Assert (C.Common.State = Unactivated); pragma Assert (C.Common.State = Unactivated);
-- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
-- = CM. The only case where C is pending activation by this
-- task, but the master of C is not CM is in Ada 2005, when C is
-- part of a return object of a build-in-place function.
Write_Lock (C); Write_Lock (C);
C.Common.Activator := null; C.Common.Activator := null;
...@@ -1465,6 +1528,8 @@ package body System.Tasking.Stages is ...@@ -1465,6 +1528,8 @@ package body System.Tasking.Stages is
Unlock (C); Unlock (C);
end if; end if;
-- Count it if dependent on this master
if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
Write_Lock (C); Write_Lock (C);
...@@ -1733,9 +1798,9 @@ package body System.Tasking.Stages is ...@@ -1733,9 +1798,9 @@ package body System.Tasking.Stages is
-- Complete the calling task -- Complete the calling task
-- This procedure must be called with abort deferred. (That's why the -- This procedure must be called with abort deferred. It should only be
-- name has "Vulnerable" in it.) It should only be called by Complete_Task -- called by Complete_Task and Finalize_Global_Tasks (for the environment
-- and Finalize_Global_Tasks (for the environment task). -- task).
-- The effect is similar to that of Complete_Master. Differences include -- The effect is similar to that of Complete_Master. Differences include
-- the closing of entries here, and computation of the number of active -- the closing of entries here, and computation of the number of active
......
gcc/ada/s-tassta.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -143,6 +143,8 @@ package System.Tasking.Stages is ...@@ -143,6 +143,8 @@ package System.Tasking.Stages is
-- it is not needed if priority-based scheduling is supported, since all -- it is not needed if priority-based scheduling is supported, since all
-- the activated tasks synchronize on the activators lock before they -- the activated tasks synchronize on the activators lock before they
-- start activating and so they should start activating in priority order. -- start activating and so they should start activating in priority order.
-- ??? Actually, the body of this package DOES reverse the chain, so I
-- don't understand the above comment.
procedure Complete_Activation; procedure Complete_Activation;
-- Compiler interface only. Do not call from within the RTS. -- Compiler interface only. Do not call from within the RTS.
...@@ -255,6 +257,22 @@ package System.Tasking.Stages is ...@@ -255,6 +257,22 @@ package System.Tasking.Stages is
-- if T has terminated. Do nothing in the other case. It is called from -- if T has terminated. Do nothing in the other case. It is called from
-- Unchecked_Deallocation, for objects that are or contain tasks. -- Unchecked_Deallocation, for objects that are or contain tasks.
procedure Move_Activation_Chain
(From, To : Activation_Chain_Access;
New_Master : Master_ID);
-- Compiler interface only. Do not call from within the RTS.
-- Move all tasks on From list to To list, and change their Master_of_Task
-- to be New_Master. This is used to implement build-in-place function
-- returns. Tasks that are part of the return object are initially placed
-- on an activation chain local to the return statement, and their master
-- is the return statement, in case the return statement is left
-- prematurely (due to raising an exception, being aborted, or a goto or
-- exit statement). Once the return statement has completed successfully,
-- Move_Activation_Chain is called to move them to the caller's activation
-- chain, and change their master to the one passed in by the caller. If
-- that doesn't happen, they will never be activated, and will become
-- terminated on leaving the return statement.
function Terminated (T : Task_Id) return Boolean; function Terminated (T : Task_Id) return Boolean;
-- This is called by the compiler to implement the 'Terminated attribute. -- This is called by the compiler to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to synchronize -- Though is not required to be so by the ARM, we choose to synchronize
......
gcc/ada/sem_ch6.adb
...@@ -124,11 +124,6 @@ package body Sem_Ch6 is ...@@ -124,11 +124,6 @@ package body Sem_Ch6 is
-- If proper warnings are enabled and the subprogram contains a construct -- If proper warnings are enabled and the subprogram contains a construct
-- that cannot be inlined, the offending construct is flagged accordingly. -- that cannot be inlined, the offending construct is flagged accordingly.
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
-- Conformance type used for following call, meaning matches the
-- RM definitions of the corresponding terms.
procedure Check_Conformance procedure Check_Conformance
(New_Id : Entity_Id; (New_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
...@@ -177,15 +172,6 @@ package body Sem_Ch6 is ...@@ -177,15 +172,6 @@ package body Sem_Ch6 is
-- True otherwise. Proc is the entity for the procedure case and is used -- True otherwise. Proc is the entity for the procedure case and is used
-- in posting the warning message. -- in posting the warning message.
function Conforming_Types
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean;
-- Check that two formal parameter types conform, checking both for
-- equality of base types, and where required statically matching
-- subtypes, depending on the setting of Ctype.
procedure Enter_Overloaded_Entity (S : Entity_Id); procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible -- This procedure makes S, a new overloaded entity, into the first visible
-- entity with that name. -- entity with that name.
...@@ -367,7 +353,7 @@ package body Sem_Ch6 is ...@@ -367,7 +353,7 @@ package body Sem_Ch6 is
begin begin
Generate_Definition (Designator); Generate_Definition (Designator);
Set_Is_Abstract (Designator); Set_Is_Abstract_Subprogram (Designator);
New_Overloaded_Entity (Designator); New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator); Check_Delayed_Subprogram (Designator);
...@@ -638,41 +624,6 @@ package body Sem_Ch6 is ...@@ -638,41 +624,6 @@ package body Sem_Ch6 is
end; end;
end if; end if;
-- ???Check for not-yet-implemented cases of AI-318. Currently we
-- warn, because that's convenient for our own use. We might want to
-- change these warnings to errors at some point. This will go away
-- once AI-318 is fully implemented.
--
-- In the first version, we plan not to implement limited function
-- returns when the result type contains tasks or protected objects,
-- and when the result subtype is unconstrained.
if Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
and then Is_Inherently_Limited_Type (R_Type)
then
if Has_Task (R_Type) then
Error_Msg_N ("(Ada 2005) return of task objects" &
" is not yet implemented", N);
end if;
if Is_Controlled (R_Type)
or else Has_Controlled_Component (R_Type)
then
Error_Msg_N
("(Ada 2005) return of limited controlled objects" &
" is not yet implemented", N);
end if;
if
Is_Composite_Type (R_Type) and then not Is_Constrained (R_Type)
then
Error_Msg_N
("(Ada 2005) return of unconstrained limited composite objects" &
" is not yet implemented", N);
end if;
end if;
if Present (Expr) if Present (Expr)
and then Present (Etype (Expr)) -- Could be False in case of errors. and then Present (Etype (Expr)) -- Could be False in case of errors.
then then
...@@ -1373,7 +1324,9 @@ package body Sem_Ch6 is ...@@ -1373,7 +1324,9 @@ package body Sem_Ch6 is
-- subprogram declaration for it, in order to attach the body to inline. -- subprogram declaration for it, in order to attach the body to inline.
procedure Copy_Parameter_List (Plist : List_Id); procedure Copy_Parameter_List (Plist : List_Id);
-- Comment required ??? -- Utility to create a parameter profile for a new subprogram spec,
-- when the subprogram has a body that acts as spec. This is done for
-- some cases of inlining, and for private protected ops.
procedure Verify_Overriding_Indicator; procedure Verify_Overriding_Indicator;
-- If there was a previous spec, the entity has been entered in the -- If there was a previous spec, the entity has been entered in the
...@@ -1767,7 +1720,7 @@ package body Sem_Ch6 is ...@@ -1767,7 +1720,7 @@ package body Sem_Ch6 is
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
if Is_Abstract (Spec_Id) then if Is_Abstract_Subprogram (Spec_Id) then
Error_Msg_N ("an abstract subprogram cannot have a body", N); Error_Msg_N ("an abstract subprogram cannot have a body", N);
return; return;
else else
...@@ -1843,36 +1796,6 @@ package body Sem_Ch6 is ...@@ -1843,36 +1796,6 @@ package body Sem_Ch6 is
(Etype (First_Entity (Spec_Id)))); (Etype (First_Entity (Spec_Id))));
end if; end if;
-- Ada 2005: A formal that is an access parameter may have a
-- designated type imported through a limited_with clause, while
-- the body has a regular with clause. Update the types of the
-- formals accordingly, so that the non-limited view of each type
-- is available in the body. We have already verified that the
-- declarations are type-conformant.
if Ada_Version >= Ada_05 then
declare
F_Spec : Entity_Id;
F_Body : Entity_Id;
begin
F_Spec := First_Formal (Spec_Id);
F_Body := First_Formal (Body_Id);
while Present (F_Spec) loop
if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type
and then
From_With_Type (Designated_Type (Etype (F_Spec)))
then
Set_Etype (F_Spec, Etype (F_Body));
end if;
Next_Formal (F_Spec);
Next_Formal (F_Body);
end loop;
end;
end if;
-- Now make the formals visible, and place subprogram -- Now make the formals visible, and place subprogram
-- on scope stack. -- on scope stack.
...@@ -2296,7 +2219,7 @@ package body Sem_Ch6 is ...@@ -2296,7 +2219,7 @@ package body Sem_Ch6 is
end if; end if;
if Is_Interface (Etyp) if Is_Interface (Etyp)
and then not Is_Abstract (Designator) and then not Is_Abstract_Subprogram (Designator)
and then not (Ekind (Designator) = E_Procedure and then not (Ekind (Designator) = E_Procedure
and then Null_Present (Specification (N))) and then Null_Present (Specification (N)))
then then
...@@ -2441,7 +2364,7 @@ package body Sem_Ch6 is ...@@ -2441,7 +2364,7 @@ package body Sem_Ch6 is
-- interface types the following error message will be reported later -- interface types the following error message will be reported later
-- (see Analyze_Subprogram_Declaration). -- (see Analyze_Subprogram_Declaration).
if Is_Abstract (Etype (Designator)) if Is_Abstract_Type (Etype (Designator))
and then not Is_Interface (Etype (Designator)) and then not Is_Interface (Etype (Designator))
and then Nkind (Parent (N)) and then Nkind (Parent (N))
/= N_Abstract_Subprogram_Declaration /= N_Abstract_Subprogram_Declaration
...@@ -2449,7 +2372,8 @@ package body Sem_Ch6 is ...@@ -2449,7 +2372,8 @@ package body Sem_Ch6 is
/= N_Formal_Abstract_Subprogram_Declaration /= N_Formal_Abstract_Subprogram_Declaration
and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
or else not Is_Entity_Name (Name (Parent (N))) or else not Is_Entity_Name (Name (Parent (N)))
or else not Is_Abstract (Entity (Name (Parent (N))))) or else not Is_Abstract_Subprogram
(Entity (Name (Parent (N)))))
then then
Error_Msg_N Error_Msg_N
("function that returns abstract type must be abstract", N); ("function that returns abstract type must be abstract", N);
...@@ -2464,7 +2388,7 @@ package body Sem_Ch6 is ...@@ -2464,7 +2388,7 @@ package body Sem_Ch6 is
-------------------------- --------------------------
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
Decl : constant Node_Id := Unit_Declaration_Node (Subp); Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Original_Body : Node_Id; Original_Body : Node_Id;
Body_To_Analyze : Node_Id; Body_To_Analyze : Node_Id;
Max_Size : constant := 10; Max_Size : constant := 10;
...@@ -2479,24 +2403,24 @@ package body Sem_Ch6 is ...@@ -2479,24 +2403,24 @@ package body Sem_Ch6 is
-- elementary statements, as a measure of acceptable size. -- elementary statements, as a measure of acceptable size.
function Has_Pending_Instantiation return Boolean; function Has_Pending_Instantiation return Boolean;
-- If some enclosing body contains instantiations that appear before -- If some enclosing body contains instantiations that appear before the
-- the corresponding generic body, the enclosing body has a freeze node -- corresponding generic body, the enclosing body has a freeze node so
-- so that it can be elaborated after the generic itself. This might -- that it can be elaborated after the generic itself. This might
-- conflict with subsequent inlinings, so that it is unsafe to try to -- conflict with subsequent inlinings, so that it is unsafe to try to
-- inline in such a case. -- inline in such a case.
function Has_Single_Return return Boolean; function Has_Single_Return return Boolean;
-- In general we cannot inline functions that return unconstrained -- In general we cannot inline functions that return unconstrained type.
-- type. However, we can handle such functions if all return statements -- However, we can handle such functions if all return statements return
-- return a local variable that is the only declaration in the body -- a local variable that is the only declaration in the body of the
-- of the function. In that case the call can be replaced by that -- function. In that case the call can be replaced by that local
-- local variable as is done for other inlined calls. -- variable as is done for other inlined calls.
procedure Remove_Pragmas; procedure Remove_Pragmas;
-- A pragma Unreferenced that mentions a formal parameter has no -- A pragma Unreferenced that mentions a formal parameter has no meaning
-- meaning when the body is inlined and the formals are rewritten. -- when the body is inlined and the formals are rewritten. Remove it
-- Remove it from body to inline. The analysis of the non-inlined body -- from body to inline. The analysis of the non-inlined body will handle
-- will handle the pragma properly. -- the pragma properly.
function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
-- If the body of the subprogram includes a call that returns an -- If the body of the subprogram includes a call that returns an
...@@ -3462,7 +3386,7 @@ package body Sem_Ch6 is ...@@ -3462,7 +3386,7 @@ package body Sem_Ch6 is
-- are left by an erroneous overriding. -- are left by an erroneous overriding.
if not Is_Predefined_Dispatching_Operation (Prim_Op) if not Is_Predefined_Dispatching_Operation (Prim_Op)
and then not Is_Abstract (Prim_Op) and then not Is_Abstract_Subprogram (Prim_Op)
and then Chars (Prim_Op) = Chars (Op) and then Chars (Prim_Op) = Chars (Op)
and then Type_Conformant (Prim_Op, Op) and then Type_Conformant (Prim_Op, Op)
and then Convention (Prim_Op) /= Convention (Op) and then Convention (Prim_Op) /= Convention (Op)
...@@ -3503,7 +3427,7 @@ package body Sem_Ch6 is ...@@ -3503,7 +3427,7 @@ package body Sem_Ch6 is
-- of abstract primitives left from an erroneous overriding. -- of abstract primitives left from an erroneous overriding.
if not Is_Predefined_Dispatching_Operation (Prim_Op) if not Is_Predefined_Dispatching_Operation (Prim_Op)
and then not Is_Abstract (Prim_Op) and then not Is_Abstract_Subprogram (Prim_Op)
then then
Check_Convention Check_Convention
(Op => Prim_Op, (Op => Prim_Op,
...@@ -3550,7 +3474,9 @@ package body Sem_Ch6 is ...@@ -3550,7 +3474,9 @@ package body Sem_Ch6 is
begin begin
-- Never need to freeze abstract subprogram -- Never need to freeze abstract subprogram
if Is_Abstract (Designator) then if Ekind (Designator) /= E_Subprogram_Type
and then Is_Abstract_Subprogram (Designator)
then
null; null;
else else
-- Need delayed freeze if return type itself needs a delayed -- Need delayed freeze if return type itself needs a delayed
...@@ -3585,7 +3511,7 @@ package body Sem_Ch6 is ...@@ -3585,7 +3511,7 @@ package body Sem_Ch6 is
if Is_Inherently_Limited_Type (Typ) then if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Designator); Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then Controlled_Type (Utyp) then elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
Set_Returns_By_Ref (Designator); Set_Returns_By_Ref (Designator);
end if; end if;
end; end;
...@@ -3801,6 +3727,7 @@ package body Sem_Ch6 is ...@@ -3801,6 +3727,7 @@ package body Sem_Ch6 is
if Nkind (Decl) = N_Subprogram_Body if Nkind (Decl) = N_Subprogram_Body
or else Nkind (Decl) = N_Subprogram_Body_Stub or else Nkind (Decl) = N_Subprogram_Body_Stub
or else Nkind (Decl) = N_Subprogram_Declaration or else Nkind (Decl) = N_Subprogram_Declaration
or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
or else Nkind (Decl) = N_Subprogram_Renaming_Declaration or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
then then
Spec := Specification (Decl); Spec := Specification (Decl);
...@@ -3819,15 +3746,41 @@ package body Sem_Ch6 is ...@@ -3819,15 +3746,41 @@ package body Sem_Ch6 is
if Ekind (Subp) = E_Entry then if Ekind (Subp) = E_Entry then
Error_Msg_NE ("entry & overrides inherited operation #", Error_Msg_NE ("entry & overrides inherited operation #",
Spec, Subp); Spec, Subp);
else else
Error_Msg_NE ("subprogram & overrides inherited operation #", Error_Msg_NE ("subprogram & overrides inherited operation #",
Spec, Subp); Spec, Subp);
end if; end if;
end if; end if;
-- If Subp is an operator, it may override a predefined operation.
-- In that case overridden_subp is empty because of our implicit
-- representation for predefined operators. We have to check whether
-- the signature of Subp matches that of a predefined operator.
-- Note that first argument provides the name of the operator, and
-- the second argument the signature that may match that of a standard
-- operation.
elsif Nkind (Subp) = N_Defining_Operator_Symbol
and then Must_Not_Override (Spec)
then
if Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
("subprogram & overrides predefined operation ",
Spec, Subp);
end if;
else else
if Must_Override (Spec) then if Must_Override (Spec) then
if Ekind (Subp) = E_Entry then if Ekind (Subp) = E_Entry then
Error_Msg_NE ("entry & is not overriding", Spec, Subp); Error_Msg_NE ("entry & is not overriding", Spec, Subp);
elsif Nkind (Subp) = N_Defining_Operator_Symbol then
if not Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
("subprogram & is not overriding", Spec, Subp);
end if;
else else
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
end if; end if;
...@@ -3936,7 +3889,6 @@ package body Sem_Ch6 is ...@@ -3936,7 +3889,6 @@ package body Sem_Ch6 is
declare declare
Arg : constant Node_Id := Arg : constant Node_Id :=
Original_Node (First_Actual (Last_Stm)); Original_Node (First_Actual (Last_Stm));
begin begin
if Nkind (Arg) = N_Attribute_Reference if Nkind (Arg) = N_Attribute_Reference
and then Attribute_Name (Arg) = Name_Identity and then Attribute_Name (Arg) = Name_Identity
...@@ -4379,28 +4331,11 @@ package body Sem_Ch6 is ...@@ -4379,28 +4331,11 @@ package body Sem_Ch6 is
-- treated recursively because they carry a signature. -- treated recursively because they carry a signature.
Are_Anonymous_Access_To_Subprogram_Types := Are_Anonymous_Access_To_Subprogram_Types :=
Ekind (Type_1) = Ekind (Type_2)
-- Case 1: Anonymous access to subprogram types and then
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type or else
and then Ekind (Type_2) = E_Anonymous_Access_Subprogram_Type) Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
-- Case 2: Anonymous access to PROTECTED subprogram types. In this
-- case the anonymous type_declaration has been replaced by an
-- occurrence of an internal access to subprogram type declaration
-- available through the Original_Access_Type attribute
or else
(Ekind (Type_1) = E_Access_Protected_Subprogram_Type
and then Ekind (Type_2) = E_Access_Protected_Subprogram_Type
and then not Comes_From_Source (Type_1)
and then not Comes_From_Source (Type_2)
and then Present (Original_Access_Type (Type_1))
and then Present (Original_Access_Type (Type_2))
and then Ekind (Original_Access_Type (Type_1)) =
E_Anonymous_Access_Protected_Subprogram_Type
and then Ekind (Original_Access_Type (Type_2)) =
E_Anonymous_Access_Protected_Subprogram_Type);
-- Test anonymous access type case. For this case, static subtype -- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15)) -- matching is required for mode conformance (RM 6.3.1(15))
...@@ -4544,16 +4479,9 @@ package body Sem_Ch6 is ...@@ -4544,16 +4479,9 @@ package body Sem_Ch6 is
EF : constant Entity_Id := EF : constant Entity_Id :=
Make_Defining_Identifier (Sloc (Assoc_Entity), Make_Defining_Identifier (Sloc (Assoc_Entity),
Chars => New_External_Name (Chars (Assoc_Entity), Chars => New_External_Name (Chars (Assoc_Entity),
Suffix => Suffix)); Suffix => Suffix));
begin begin
-- We never generate extra formals if expansion is not active
-- because we don't need them unless we are generating code.
if not Expander_Active then
return Empty;
end if;
-- A little optimization. Never generate an extra formal for the -- A little optimization. Never generate an extra formal for the
-- _init operand of an initialization procedure, since it could -- _init operand of an initialization procedure, since it could
-- never be used. -- never be used.
...@@ -4586,6 +4514,13 @@ package body Sem_Ch6 is ...@@ -4586,6 +4514,13 @@ package body Sem_Ch6 is
-- Start of processing for Create_Extra_Formals -- Start of processing for Create_Extra_Formals
begin begin
-- We never generate extra formals if expansion is not active
-- because we don't need them unless we are generating code.
if not Expander_Active then
return;
end if;
-- If this is a derived subprogram then the subtypes of the parent -- If this is a derived subprogram then the subtypes of the parent
-- subprogram's formal parameters will be used to to determine the need -- subprogram's formal parameters will be used to to determine the need
-- for extra formals. -- for extra formals.
...@@ -4601,7 +4536,7 @@ package body Sem_Ch6 is ...@@ -4601,7 +4536,7 @@ package body Sem_Ch6 is
Next_Formal (Formal); Next_Formal (Formal);
end loop; end loop;
-- If Extra_formals where already created, don't do it again. This -- If Extra_formals were already created, don't do it again. This
-- situation may arise for subprogram types created as part of -- situation may arise for subprogram types created as part of
-- dispatching calls (see Expand_Dispatching_Call) -- dispatching calls (see Expand_Dispatching_Call)
...@@ -4642,10 +4577,8 @@ package body Sem_Ch6 is ...@@ -4642,10 +4577,8 @@ package body Sem_Ch6 is
end if; end if;
if Has_Discriminants (Formal_Type) if Has_Discriminants (Formal_Type)
and then and then not Is_Constrained (Formal_Type)
((not Is_Constrained (Formal_Type) and then not Is_Indefinite_Subtype (Formal_Type)
and then not Is_Indefinite_Subtype (Formal_Type))
or else Present (Extra_Formal (Formal)))
then then
Set_Extra_Constrained Set_Extra_Constrained
(Formal, (Formal,
...@@ -4657,7 +4590,7 @@ package body Sem_Ch6 is ...@@ -4657,7 +4590,7 @@ package body Sem_Ch6 is
-- Create extra formal for supporting accessibility checking -- Create extra formal for supporting accessibility checking
-- This is suppressed if we specifically suppress accessibility -- This is suppressed if we specifically suppress accessibility
-- checks at the pacage level for either the subprogram, or the -- checks at the package level for either the subprogram, or the
-- package in which it resides. However, we do not suppress it -- package in which it resides. However, we do not suppress it
-- simply if the scope has accessibility checks suppressed, since -- simply if the scope has accessibility checks suppressed, since
-- this could cause trouble when clients are compiled with a -- this could cause trouble when clients are compiled with a
...@@ -4687,63 +4620,110 @@ package body Sem_Ch6 is ...@@ -4687,63 +4620,110 @@ package body Sem_Ch6 is
end if; end if;
end if; end if;
if Present (P_Formal) then
Next_Formal (P_Formal);
end if;
-- This label is required when skipping extra formal generation for -- This label is required when skipping extra formal generation for
-- Unchecked_Union parameters. -- Unchecked_Union parameters.
<<Skip_Extra_Formal_Generation>> <<Skip_Extra_Formal_Generation>>
if Present (P_Formal) then
Next_Formal (P_Formal);
end if;
Next_Formal (Formal); Next_Formal (Formal);
end loop; end loop;
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- an extra formal that will be passed the address of the return object -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
-- within the caller. This is added as the last extra formal, but
-- eventually will be accompanied by other implicit formals related to if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then
-- build-in-place functions (such as allocate/deallocate subprograms,
-- finalization list, constrained flag, task master, task activation
-- list, etc.).
if Expander_Active
and then Ada_Version >= Ada_05
and then Is_Build_In_Place_Function (E)
then
declare declare
Formal_Type : constant Entity_Id := Result_Subt : constant Entity_Id := Etype (E);
Create_Itype
(E_Anonymous_Access_Type, Discard : Entity_Id;
E, Scope_Id => Scope (E)); pragma Warnings (Off, Discard);
Result_Subt : constant Entity_Id := Etype (E);
Result_Addr_Formal : Entity_Id;
begin begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt); -- In the case of functions with unconstrained result subtypes,
Set_Etype (Formal_Type, Formal_Type); -- add a 3-state formal indicating whether the return object is
Init_Size_Align (Formal_Type); -- allocated by the caller (0), or should be allocated by the
Set_Depends_On_Private -- callee on the secondary stack (1) or in the global heap (2).
(Formal_Type, Has_Private_Component (Formal_Type)); -- For the moment we just use Natural for the type of this formal.
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); -- Note that this formal isn't needed in the case where the
Set_Is_Access_Constant (Formal_Type, False); -- result subtype is constrained.
Set_Can_Never_Be_Null (Formal_Type);
if not Is_Constrained (Result_Subt) then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
E, BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
-- Ada 2005 (AI-50217): Propagate the attribute that indicates -- In the case of functions whose result type has controlled
-- the designated type comes from the limited view (for back-end -- parts, we have an extra formal of type
-- purposes). -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
-- is, we are passing a pointer to a finalization list (which is
-- itself a pointer). This extra formal is then passed along to
-- Move_Final_List in case of successful completion of a return
-- statement. We cannot pass an 'in out' parameter, because we
-- need to update the finalization list during an abort-deferred
-- region, rather than using copy-back after the function
-- returns. This is true even if we are able to get away with
-- having 'in out' parameters, which are normally illegal for
-- functions.
if Is_Controlled (Result_Subt)
or else Has_Controlled_Component (Result_Subt)
then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalizable_Ptr_Ptr),
E, BIP_Formal_Suffix (BIP_Final_List));
end if;
-- If the result type contains tasks, we have two extra formals:
-- the master of the tasks to be created, and the caller's
-- activation chain.
if Has_Task (Result_Subt) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Master_Id),
E, BIP_Formal_Suffix (BIP_Master));
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
E, BIP_Formal_Suffix (BIP_Activation_Chain));
end if;
Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt)); -- All build-in-place functions get an extra formal that will be
-- passed the address of the return object within the caller.
Layout_Type (Formal_Type); declare
Formal_Type : constant Entity_Id :=
Create_Itype
(E_Anonymous_Access_Type, E,
Scope_Id => Scope (E));
begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt);
Set_Etype (Formal_Type, Formal_Type);
Init_Size_Align (Formal_Type);
Set_Depends_On_Private
(Formal_Type, Has_Private_Component (Formal_Type));
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
Set_Is_Access_Constant (Formal_Type, False);
Result_Addr_Formal := Add_Extra_Formal (E, Formal_Type, E, "RA"); -- Ada 2005 (AI-50217): Propagate the attribute that indicates
-- the designated type comes from the limited view (for
-- back-end purposes).
-- For some reason the following is not effective and the Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
-- dereference of the formal within the function still gets
-- a check. ???
Set_Can_Never_Be_Null (Result_Addr_Formal); Layout_Type (Formal_Type);
Discard :=
Add_Extra_Formal
(E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
end;
end; end;
end if; end if;
end Create_Extra_Formals; end Create_Extra_Formals;
...@@ -4813,8 +4793,10 @@ package body Sem_Ch6 is ...@@ -4813,8 +4793,10 @@ package body Sem_Ch6 is
-- Warn unless genuine overloading -- Warn unless genuine overloading
if (not Is_Overloadable (E)) if (not Is_Overloadable (E) or else Subtype_Conformant (E, S))
or else Subtype_Conformant (E, S) and then (Is_Immediately_Visible (E)
or else
Is_Potentially_Use_Visible (S))
then then
Error_Msg_Sloc := Sloc (E); Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("declaration of & hides one#?", S); Error_Msg_N ("declaration of & hides one#?", S);
...@@ -5698,7 +5680,7 @@ package body Sem_Ch6 is ...@@ -5698,7 +5680,7 @@ package body Sem_Ch6 is
Remove (Decl); Remove (Decl);
Set_Has_Completion (Op_Name); Set_Has_Completion (Op_Name);
Set_Corresponding_Equality (Op_Name, S); Set_Corresponding_Equality (Op_Name, S);
Set_Is_Abstract (Op_Name, Is_Abstract (S)); Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
end; end;
end Make_Inequality_Operator; end Make_Inequality_Operator;
...@@ -5827,7 +5809,7 @@ package body Sem_Ch6 is ...@@ -5827,7 +5809,7 @@ package body Sem_Ch6 is
-- declarations because they don't have interface lists. -- declarations because they don't have interface lists.
if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then
Collect_Synchronized_Interfaces (Typ, Ifaces_List); Collect_Abstract_Interfaces (Typ, Ifaces_List);
if not Is_Empty_Elmt_List (Ifaces_List) then if not Is_Empty_Elmt_List (Ifaces_List) then
Overridden_Subp := Overridden_Subp :=
...@@ -5900,22 +5882,14 @@ package body Sem_Ch6 is ...@@ -5900,22 +5882,14 @@ package body Sem_Ch6 is
and then Visible_Part_Type (T) and then Visible_Part_Type (T)
and then not In_Instance and then not In_Instance
then then
if Is_Abstract (T) if Is_Abstract_Type (T)
and then Is_Abstract (S) and then Is_Abstract_Subprogram (S)
and then (not Is_Overriding or else not Is_Abstract (E)) and then (not Is_Overriding
or else not Is_Abstract_Subprogram (E))
then then
if not Is_Interface (T) then Error_Msg_N ("abstract subprograms must be visible "
Error_Msg_N ("abstract subprograms must be visible "
& "('R'M 3.9.3(10))!", S); & "('R'M 3.9.3(10))!", S);
-- Ada 2005 (AI-251)
else
Error_Msg_N ("primitive subprograms of interface types "
& "declared in a visible part, must be declared in "
& "the visible part ('R'M 3.9.4)!", S);
end if;
elsif Ekind (S) = E_Function elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T) and then Is_Tagged_Type (T)
and then T = Base_Type (Etype (S)) and then T = Base_Type (Etype (S))
...@@ -6609,6 +6583,12 @@ package body Sem_Ch6 is ...@@ -6609,6 +6583,12 @@ package body Sem_Ch6 is
Formal_Type := Formal_Type :=
Access_Definition (Related_Nod, Parameter_Type (Param_Spec)); Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
-- No need to continue if we already notified errors
if not Present (Formal_Type) then
return;
end if;
-- Ada 2005 (AI-254) -- Ada 2005 (AI-254)
declare declare
...@@ -6619,7 +6599,7 @@ package body Sem_Ch6 is ...@@ -6619,7 +6599,7 @@ package body Sem_Ch6 is
if Present (AD) and then Protected_Present (AD) then if Present (AD) and then Protected_Present (AD) then
Formal_Type := Formal_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram Replace_Anonymous_Access_To_Protected_Subprogram
(Param_Spec, Formal_Type); (Param_Spec);
end if; end if;
end; end;
end if; end if;
......
gcc/ada/sem_ch6.ads
...@@ -27,6 +27,12 @@ ...@@ -27,6 +27,12 @@
with Types; use Types; with Types; use Types;
package Sem_Ch6 is package Sem_Ch6 is
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
-- Conformance type used in conformance checks between specs and bodies,
-- and for overriding. The literals match the RM definitions of the
-- corresponding terms.
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Extended_Return_Statement (N : Node_Id); procedure Analyze_Extended_Return_Statement (N : Node_Id);
procedure Analyze_Function_Call (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id);
...@@ -39,7 +45,8 @@ package Sem_Ch6 is ...@@ -39,7 +45,8 @@ package Sem_Ch6 is
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id;
-- Analyze subprogram specification in both subprogram declarations -- Analyze subprogram specification in both subprogram declarations
-- and body declarations. Returns the defining entity for the spec. -- and body declarations. Returns the defining entity for the
-- specification N.
procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id); procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id);
-- This procedure is called if the node N, an instance of a call to -- This procedure is called if the node N, an instance of a call to
...@@ -55,9 +62,9 @@ package Sem_Ch6 is ...@@ -55,9 +62,9 @@ package Sem_Ch6 is
-- their respective counterparts. -- their respective counterparts.
procedure Check_Delayed_Subprogram (Designator : Entity_Id); procedure Check_Delayed_Subprogram (Designator : Entity_Id);
-- Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a -- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. If a
-- type in its profile depends on a private type without a full -- type in its profile depends on a private type without a full
-- declaration, indicate that the subprogram is delayed. -- declaration, indicate that the subprogram or type is delayed.
procedure Check_Discriminant_Conformance procedure Check_Discriminant_Conformance
(N : Node_Id; (N : Node_Id;
...@@ -112,6 +119,16 @@ package Sem_Ch6 is ...@@ -112,6 +119,16 @@ package Sem_Ch6 is
-- the flag being placed on the Err_Loc node if it is specified, and -- the flag being placed on the Err_Loc node if it is specified, and
-- on the appropriate component of the New_Id construct if not. -- on the appropriate component of the New_Id construct if not.
function Conforming_Types
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean;
-- Check that the types of two formal parameters are conforming. In most
-- cases this is just a name comparison, but within an instance it involves
-- generic actual types, and in the presence of anonymous access types
-- it must examine the designated types.
procedure Create_Extra_Formals (E : Entity_Id); procedure Create_Extra_Formals (E : Entity_Id);
-- For each parameter of a subprogram or entry that requires an additional -- For each parameter of a subprogram or entry that requires an additional
-- formal (such as for access parameters and indefinite discriminated -- formal (such as for access parameters and indefinite discriminated
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment