Skip to content

R
riscv-gcc-1
Commit bd28782c by Ed Schonberg Committed by Arnaud Charlet
Options

exp_ch5.adb (Expand_Assign_Array): If source or target of assignment is a… 

exp_ch5.adb (Expand_Assign_Array): If source or target of assignment is a variable that renames a slice...

2007-08-14  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_Assign_Array): If source or target of assignment
	is a variable that renames a slice, use the variable itself in the
	expannsion when the renamed expression itself may be modified between
	the declaration of the renaming and the array assignment.

From-SVN: r127430
parent fa57ac97
Showing with 105 additions and 509 deletions
gcc/ada/exp_ch5.adb
...@@ -64,12 +64,6 @@ with Validsw; use Validsw; ...@@ -64,12 +64,6 @@ with Validsw; use Validsw;
package body Exp_Ch5 is package body Exp_Ch5 is
Enable_New_Return_Processing : constant Boolean := True;
-- ??? This flag is temporary. False causes the compiler to use the old
-- version of Analyze_Return_Statement; True, the new version, which does
-- not yet work. We probably want this to match the corresponding thing
-- in sem_ch6.adb.
function Change_Of_Representation (N : Node_Id) return Boolean; function Change_Of_Representation (N : Node_Id) return Boolean;
-- Determine if the right hand side of the assignment N is a type -- Determine if the right hand side of the assignment N is a type
-- conversion which requires a change of representation. Called -- conversion which requires a change of representation. Called
...@@ -110,17 +104,15 @@ package body Exp_Ch5 is ...@@ -110,17 +104,15 @@ package body Exp_Ch5 is
-- of representation. -- of representation.
procedure Expand_Non_Function_Return (N : Node_Id); procedure Expand_Non_Function_Return (N : Node_Id);
-- Called by Expand_Simple_Return in case we're returning from a procedure -- Called by Expand_N_Simple_Return_Statement in case we're returning from
-- body, entry body, accept statement, or extended returns statement. -- a procedure body, entry body, accept statement, or extended return
-- Note that all non-function returns are simple return statements. -- statement. Note that all non-function returns are simple return
-- statements.
procedure Expand_Simple_Function_Return (N : Node_Id); procedure Expand_Simple_Function_Return (N : Node_Id);
-- Expand simple return from function. Called by Expand_Simple_Return in -- Expand simple return from function. Called by
-- case we're returning from a function body. -- Expand_N_Simple_Return_Statement in case we're returning from a function
-- body.
procedure Expand_Simple_Return (N : Node_Id);
-- Expansion for simple return statements. Calls either
-- Expand_Simple_Function_Return or Expand_Non_Function_Return.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and tagged assignment, -- Generate the necessary code for controlled and tagged assignment,
...@@ -179,7 +171,7 @@ package body Exp_Ch5 is ...@@ -179,7 +171,7 @@ package body Exp_Ch5 is
-- This switch is set to True if the array move must be done using -- This switch is set to True if the array move must be done using
-- an explicit front end generated loop. -- an explicit front end generated loop.
procedure Apply_Dereference (Arg : in out Node_Id); procedure Apply_Dereference (Arg : Node_Id);
-- If the argument is an access to an array, and the assignment is -- If the argument is an access to an array, and the assignment is
-- converted into a procedure call, apply explicit dereference. -- converted into a procedure call, apply explicit dereference.
...@@ -202,7 +194,7 @@ package body Exp_Ch5 is ...@@ -202,7 +194,7 @@ package body Exp_Ch5 is
-- Apply_Dereference -- -- Apply_Dereference --
----------------------- -----------------------
procedure Apply_Dereference (Arg : in out Node_Id) is procedure Apply_Dereference (Arg : Node_Id) is
Typ : constant Entity_Id := Etype (Arg); Typ : constant Entity_Id := Etype (Arg);
begin begin
if Is_Access_Type (Typ) then if Is_Access_Type (Typ) then
...@@ -260,31 +252,26 @@ package body Exp_Ch5 is ...@@ -260,31 +252,26 @@ package body Exp_Ch5 is
-- Start of processing for Expand_Assign_Array -- Start of processing for Expand_Assign_Array
begin begin
-- Deal with length check, note that the length check is done with -- Deal with length check. Note that the length check is done with
-- respect to the right hand side as given, not a possible underlying -- respect to the right hand side as given, not a possible underlying
-- renamed object, since this would generate incorrect extra checks. -- renamed object, since this would generate incorrect extra checks.
Apply_Length_Check (Rhs, L_Type); Apply_Length_Check (Rhs, L_Type);
-- We start by assuming that the move can be done in either -- We start by assuming that the move can be done in either direction,
-- direction, i.e. that the two sides are completely disjoint. -- i.e. that the two sides are completely disjoint.
Set_Forwards_OK (N, True); Set_Forwards_OK (N, True);
Set_Backwards_OK (N, True); Set_Backwards_OK (N, True);
-- Normally it is only the slice case that can lead to overlap, and -- Normally it is only the slice case that can lead to overlap, and
-- explicit checks for slices are made below. But there is one case -- explicit checks for slices are made below. But there is one case
-- where the slice can be implicit and invisible to us and that is the -- where the slice can be implicit and invisible to us: when we have a
-- case where we have a one dimensional array, and either both operands -- one dimensional array, and either both operands are parameters, or
-- are parameters, or one is a parameter and the other is a global -- one is a parameter (which can be a slice passed by reference) and the
-- variable. In this case the parameter could be a slice that overlaps -- other is a non-local variable. In this case the parameter could be a
-- with the other parameter. -- slice that overlaps with the other operand.
-- Check for the case of slices requiring an explicit loop. Normally it
-- is only the explicit slice cases that bother us, but in the case of
-- one dimensional arrays, parameters can be slices that are passed by
-- reference, so we can have aliasing for assignments from one parameter
-- to another, or assignments between parameters and nonlocal variables.
-- However, if the array subtype is a constrained first subtype in the -- However, if the array subtype is a constrained first subtype in the
-- parameter case, then we don't have to worry about overlap, since -- parameter case, then we don't have to worry about overlap, since
-- slice assignments aren't possible (other than for a slice denoting -- slice assignments aren't possible (other than for a slice denoting
...@@ -340,8 +327,8 @@ package body Exp_Ch5 is ...@@ -340,8 +327,8 @@ package body Exp_Ch5 is
then then
Loop_Required := True; Loop_Required := True;
-- Arrays with controlled components are expanded into a loop -- Arrays with controlled components are expanded into a loop to force
-- to force calls to adjust at the component level. -- calls to Adjust at the component level.
elsif Has_Controlled_Component (L_Type) then elsif Has_Controlled_Component (L_Type) then
Loop_Required := True; Loop_Required := True;
...@@ -378,8 +365,8 @@ package body Exp_Ch5 is ...@@ -378,8 +365,8 @@ package body Exp_Ch5 is
-- do this, we get the wrong length computed for the array to be -- do this, we get the wrong length computed for the array to be
-- moved. The two cases we need to worry about are: -- moved. The two cases we need to worry about are:
-- Explicit deference of an unconstrained packed array type as -- Explicit deference of an unconstrained packed array type as in the
-- in the following example: -- following example:
-- procedure C52 is -- procedure C52 is
-- type BITS is array(INTEGER range <>) of BOOLEAN; -- type BITS is array(INTEGER range <>) of BOOLEAN;
...@@ -401,7 +388,7 @@ package body Exp_Ch5 is ...@@ -401,7 +388,7 @@ package body Exp_Ch5 is
-- File.Storage := Contents; -- File.Storage := Contents;
-- end Write_All; -- end Write_All;
-- We expand to a loop in either of these two cases -- We expand to a loop in either of these two cases.
-- Question for future thought. Another potentially more efficient -- Question for future thought. Another potentially more efficient
-- approach would be to create the actual subtype, and then do an -- approach would be to create the actual subtype, and then do an
...@@ -411,7 +398,7 @@ package body Exp_Ch5 is ...@@ -411,7 +398,7 @@ package body Exp_Ch5 is
function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; function Is_UBPA_Reference (Opnd : Node_Id) return Boolean;
-- Function to perform required test for the first case, above -- Function to perform required test for the first case, above
-- (dereference of an unconstrained bit packed array) -- (dereference of an unconstrained bit packed array).
----------------------- -----------------------
-- Is_UBPA_Reference -- -- Is_UBPA_Reference --
...@@ -470,14 +457,14 @@ package body Exp_Ch5 is ...@@ -470,14 +457,14 @@ package body Exp_Ch5 is
-- The back end can always handle the assignment if the right side is a -- The back end can always handle the assignment if the right side is a
-- string literal (note that overlap is definitely impossible in this -- string literal (note that overlap is definitely impossible in this
-- case). If the type is packed, a string literal is always converted -- case). If the type is packed, a string literal is always converted
-- into aggregate, except in the case of a null slice, for which no -- into an aggregate, except in the case of a null slice, for which no
-- aggregate can be written. In that case, rewrite the assignment as a -- aggregate can be written. In that case, rewrite the assignment as a
-- null statement, a length check has already been emitted to verify -- null statement, a length check has already been emitted to verify
-- that the range of the left-hand side is empty. -- that the range of the left-hand side is empty.
-- Note that this code is not executed if we had an assignment of a -- Note that this code is not executed if we have an assignment of a
-- string literal to a non-bit aligned component of a record, a case -- string literal to a non-bit aligned component of a record, a case
-- which cannot be handled by the backend -- which cannot be handled by the backend.
elsif Nkind (Rhs) = N_String_Literal then elsif Nkind (Rhs) = N_String_Literal then
if String_Length (Strval (Rhs)) = 0 if String_Length (Strval (Rhs)) = 0
...@@ -600,8 +587,8 @@ package body Exp_Ch5 is ...@@ -600,8 +587,8 @@ package body Exp_Ch5 is
end if; end if;
-- If both sides are slices, we must figure out whether it is safe -- If both sides are slices, we must figure out whether it is safe
-- to do the move in one direction or the other It is always safe if -- to do the move in one direction or the other. It is always safe
-- there is a change of representation since obviously two arrays -- if there is a change of representation since obviously two arrays
-- with different representations cannot possibly overlap. -- with different representations cannot possibly overlap.
if (not Crep) and L_Slice and R_Slice then if (not Crep) and L_Slice and R_Slice then
...@@ -708,6 +695,31 @@ package body Exp_Ch5 is ...@@ -708,6 +695,31 @@ package body Exp_Ch5 is
-- <code for Backwards_OK = True above> -- <code for Backwards_OK = True above>
-- end if; -- end if;
-- In order to detect possible aliasing, we examine the renamed
-- expression when the source or target is a renaming. However,
-- the renaming may be intended to capture an address that may be
-- affected by subsequent code, and therefore we must recover
-- the actual entity for the expansion that follows, not the
-- object it renames. In particular, if source or target designate
-- a portion of a dynamically allocated object, the pointer to it
-- may be reassigned but the renaming preserves the proper location.
if Is_Entity_Name (Rhs)
and then
Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration
and then Nkind (Act_Rhs) = N_Slice
then
Rarray := Rhs;
end if;
if Is_Entity_Name (Lhs)
and then
Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration
and then Nkind (Act_Lhs) = N_Slice
then
Larray := Lhs;
end if;
-- Cases where either Forwards_OK or Backwards_OK is true -- Cases where either Forwards_OK or Backwards_OK is true
if Forwards_OK (N) or else Backwards_OK (N) then if Forwards_OK (N) or else Backwards_OK (N) then
...@@ -1697,7 +1709,7 @@ package body Exp_Ch5 is ...@@ -1697,7 +1709,7 @@ package body Exp_Ch5 is
begin begin
C_Es := C_Es :=
Range_Check Get_Range_Checks
(Lhs, (Lhs,
Target_Typ, Target_Typ,
Etype (Designated_Type (Etype (Lhs)))); Etype (Designated_Type (Etype (Lhs))));
...@@ -2340,9 +2352,8 @@ package body Exp_Ch5 is ...@@ -2340,9 +2352,8 @@ package body Exp_Ch5 is
-- That is, we need to have a reified return object if there are statements -- That is, we need to have a reified return object if there are statements
-- (which might refer to it) or if we're doing build-in-place (so we can -- (which might refer to it) or if we're doing build-in-place (so we can
-- set its address to the final resting place -- but that key part is not -- set its address to the final resting place or if there is no expression
-- yet implemented) or if there is no expression (in which case default -- (in which case default 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
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -2420,21 +2431,25 @@ package body Exp_Ch5 is ...@@ -2420,21 +2431,25 @@ package body Exp_Ch5 is
--------------------- ---------------------
function Move_Final_List return Node_Id is function Move_Final_List return Node_Id is
Flist : constant Entity_Id := Flist : constant Entity_Id :=
Finalization_Chain_Entity Finalization_Chain_Entity (Return_Statement_Entity (N));
(Return_Statement_Entity (N));
From : constant Node_Id := From : constant Node_Id := New_Reference_To (Flist, Loc);
New_Reference_To (Flist, Loc);
Caller_Final_List : constant Entity_Id := Caller_Final_List : constant Entity_Id :=
Build_In_Place_Formal Build_In_Place_Formal
(Parent_Function, BIP_Final_List); (Parent_Function, BIP_Final_List);
To : constant Node_Id := To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc);
New_Reference_To (Caller_Final_List, Loc);
begin begin
-- Catch cases where a finalization chain entity has not been
-- associated with the return statement entity.
pragma Assert (Present (Flist));
-- Build required call
return return
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition =>
...@@ -2526,7 +2541,7 @@ package body Exp_Ch5 is ...@@ -2526,7 +2541,7 @@ package body Exp_Ch5 is
-- Build a simple_return_statement that returns the return object -- Build a simple_return_statement that returns the return object
Return_Stm := Return_Stm :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); Expression => New_Occurrence_Of (Return_Object_Entity, Loc));
Append_To (Statements, Return_Stm); Append_To (Statements, Return_Stm);
...@@ -2926,7 +2941,7 @@ package body Exp_Ch5 is ...@@ -2926,7 +2941,7 @@ package body Exp_Ch5 is
-- Build simple_return_statement that returns the expression directly -- Build simple_return_statement that returns the expression directly
Return_Stm := Make_Return_Statement (Loc, Expression => Exp); Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp);
Result := Return_Stm; Result := Return_Stm;
end if; end if;
...@@ -2991,6 +3006,12 @@ package body Exp_Ch5 is ...@@ -2991,6 +3006,12 @@ package body Exp_Ch5 is
E : Node_Id; E : Node_Id;
New_If : Node_Id; New_If : Node_Id;
Warn_If_Deleted : constant Boolean :=
Warn_On_Deleted_Code and then Comes_From_Source (N);
-- Indicates whether we want warnings when we delete branches of the
-- if statement based on constant condition analysis. We never want
-- these warnings for expander generated code.
begin begin
Adjust_Condition (Condition (N)); Adjust_Condition (Condition (N));
...@@ -3007,8 +3028,8 @@ package body Exp_Ch5 is ...@@ -3007,8 +3028,8 @@ package body Exp_Ch5 is
-- All the else parts can be killed -- All the else parts can be killed
Kill_Dead_Code (Elsif_Parts (N), Warn_On_Deleted_Code); Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted);
Kill_Dead_Code (Else_Statements (N), Warn_On_Deleted_Code); Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted);
Hed := Remove_Head (Then_Statements (N)); Hed := Remove_Head (Then_Statements (N));
Insert_List_After (N, Then_Statements (N)); Insert_List_After (N, Then_Statements (N));
...@@ -3028,7 +3049,7 @@ package body Exp_Ch5 is ...@@ -3028,7 +3049,7 @@ package body Exp_Ch5 is
Kill_Dead_Code (Condition (N)); Kill_Dead_Code (Condition (N));
end if; end if;
Kill_Dead_Code (Then_Statements (N), Warn_On_Deleted_Code); Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted);
-- If there are no elsif statements, then we simply replace the -- If there are no elsif statements, then we simply replace the
-- entire if statement by the sequence of else statements. -- entire if statement by the sequence of else statements.
...@@ -3173,9 +3194,9 @@ package body Exp_Ch5 is ...@@ -3173,9 +3194,9 @@ package body Exp_Ch5 is
Else_Stm : constant Node_Id := First (Else_Statements (N)); Else_Stm : constant Node_Id := First (Else_Statements (N));
begin begin
if Nkind (Then_Stm) = N_Return_Statement if Nkind (Then_Stm) = N_Simple_Return_Statement
and then and then
Nkind (Else_Stm) = N_Return_Statement Nkind (Else_Stm) = N_Simple_Return_Statement
then then
declare declare
Then_Expr : constant Node_Id := Expression (Then_Stm); Then_Expr : constant Node_Id := Expression (Then_Stm);
...@@ -3190,7 +3211,7 @@ package body Exp_Ch5 is ...@@ -3190,7 +3211,7 @@ package body Exp_Ch5 is
and then Entity (Else_Expr) = Standard_False and then Entity (Else_Expr) = Standard_False
then then
Rewrite (N, Rewrite (N,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Relocate_Node (Condition (N)))); Expression => Relocate_Node (Condition (N))));
Analyze (N); Analyze (N);
return; return;
...@@ -3199,7 +3220,7 @@ package body Exp_Ch5 is ...@@ -3199,7 +3220,7 @@ package body Exp_Ch5 is
and then Entity (Else_Expr) = Standard_True and then Entity (Else_Expr) = Standard_True
then then
Rewrite (N, Rewrite (N,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Op_Not (Loc, Make_Op_Not (Loc,
Right_Opnd => Relocate_Node (Condition (N))))); Right_Opnd => Relocate_Node (Condition (N)))));
...@@ -3412,430 +3433,35 @@ package body Exp_Ch5 is ...@@ -3412,430 +3433,35 @@ package body Exp_Ch5 is
end if; end if;
end Expand_N_Loop_Statement; end Expand_N_Loop_Statement;
------------------------------- --------------------------------------
-- Expand_N_Return_Statement -- -- Expand_N_Simple_Return_Statement --
------------------------------- --------------------------------------
procedure Expand_N_Return_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Exp : constant Node_Id := Expression (N);
Exptyp : Entity_Id;
T : Entity_Id;
Utyp : Entity_Id;
Scope_Id : Entity_Id;
Kind : Entity_Kind;
Call : Node_Id;
Acc_Stat : Node_Id;
Goto_Stat : Node_Id;
Lab_Node : Node_Id;
Cur_Idx : Nat;
Return_Type : Entity_Id;
Result_Exp : Node_Id;
Result_Id : Entity_Id;
Result_Obj : Node_Id;
procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
begin begin
if Enable_New_Return_Processing then -- ???Temporary hack -- Distinguish the function and non-function cases:
Expand_Simple_Return (N);
return;
end if;
-- Case where returned expression is present
if Present (Exp) then
-- Always normalize C/Fortran boolean result. This is not always
-- necessary, but it seems a good idea to minimize the passing
-- around of non-normalized values, and in any case this handles
-- the processing of barrier functions for protected types, which
-- turn the condition into a return statement.
Exptyp := Etype (Exp);
if Is_Boolean_Type (Exptyp)
and then Nonzero_Is_True (Exptyp)
then
Adjust_Condition (Exp);
Adjust_Result_Type (Exp, Exptyp);
end if;
-- Do validity check if enabled for returns
if Validity_Checks_On
and then Validity_Check_Returns
then
Ensure_Valid (Exp);
end if;
end if;
-- Find relevant enclosing scope from which return is returning
Cur_Idx := Scope_Stack.Last;
loop
Scope_Id := Scope_Stack.Table (Cur_Idx).Entity;
if Ekind (Scope_Id) /= E_Block
and then Ekind (Scope_Id) /= E_Loop
then
exit;
else
Cur_Idx := Cur_Idx - 1;
pragma Assert (Cur_Idx >= 0);
end if;
end loop;
-- ???I believe the above code is no longer necessary
pragma Assert (Scope_Id =
Return_Applies_To (Return_Statement_Entity (N)));
if No (Exp) then
Kind := Ekind (Scope_Id);
-- If it is a return from procedures do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then
return;
end if;
pragma Assert (Is_Entry (Scope_Id));
-- Look at the enclosing block to see whether the return is from an
-- accept statement or an entry body.
for J in reverse 0 .. Cur_Idx loop
Scope_Id := Scope_Stack.Table (J).Entity;
exit when Is_Concurrent_Type (Scope_Id);
end loop;
-- If it is a return from accept statement it should be expanded
-- as a call to RTS Complete_Rendezvous and a goto to the end of
-- the accept body.
-- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
-- Expand_N_Accept_Alternative in exp_ch9.adb)
if Is_Task_Type (Scope_Id) then
Call := (Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Complete_Rendezvous), Loc)));
Insert_Before (N, Call);
-- why not insert actions here???
Analyze (Call);
Acc_Stat := Parent (N);
while Nkind (Acc_Stat) /= N_Accept_Statement loop
Acc_Stat := Parent (Acc_Stat);
end loop;
Lab_Node := Last (Statements
(Handled_Statement_Sequence (Acc_Stat)));
Goto_Stat := Make_Goto_Statement (Loc,
Name => New_Occurrence_Of
(Entity (Identifier (Lab_Node)), Loc));
Set_Analyzed (Goto_Stat);
Rewrite (N, Goto_Stat);
Analyze (N);
-- If it is a return from an entry body, put a Complete_Entry_Body
-- call in front of the return.
elsif Is_Protected_Type (Scope_Id) then
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Complete_Entry_Body), Loc),
Parameter_Associations => New_List
(Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
(Object_Ref
(Corresponding_Body (Parent (Scope_Id))),
Loc),
Attribute_Name => Name_Unchecked_Access)));
Insert_Before (N, Call);
Analyze (Call);
end if;
return;
end if;
T := Etype (Exp);
Return_Type := Etype (Scope_Id);
Utyp := Underlying_Type (Return_Type);
-- Check the result expression of a scalar function against the subtype
-- of the function by inserting a conversion. This conversion must
-- eventually be performed for other classes of types, but for now it's
-- only done for scalars. ???
if Is_Scalar_Type (T) then
Rewrite (Exp, Convert_To (Return_Type, Exp));
Analyze (Exp);
end if;
-- Deal with returning variable length objects and controlled types
-- Nothing to do if we are returning by reference, or this is not type
-- that requires special processing (indicated by the fact that it
-- requires a cleanup scope for the secondary stack case).
if Is_Inherently_Limited_Type (T) then
null;
elsif not Requires_Transient_Scope (Return_Type) then
-- Mutable records with no variable length components are not
-- returned on the sec-stack, so we need to make sure that the
-- backend will only copy back the size of the actual value, and not
-- the maximum size. We create an actual subtype for this purpose.
declare
Ubt : constant Entity_Id := Underlying_Type (Base_Type (T));
Decl : Node_Id;
Ent : Entity_Id;
begin
if Has_Discriminants (Ubt)
and then not Is_Constrained (Ubt)
and then not Has_Unchecked_Union (Ubt)
then
Decl := Build_Actual_Subtype (Ubt, Exp);
Ent := Defining_Identifier (Decl);
Insert_Action (Exp, Decl);
Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
Analyze_And_Resolve (Exp);
end if;
end;
-- Here if secondary stack is used
else
-- Make sure that no surrounding block will reclaim the secondary
-- stack on which we are going to put the result. Not only may this
-- introduce secondary stack leaks but worse, if the reclamation is
-- done too early, then the result we are returning may get
-- clobbered. See example in 7417-003.
declare
S : Entity_Id := Current_Scope;
begin
while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop
Set_Sec_Stack_Needed_For_Return (S, True);
S := Enclosing_Dynamic_Scope (S);
end loop;
end;
-- Optimize the case where the result is a function call. In this
-- case either the result is already on the secondary stack, or is
-- already being returned with the stack pointer depressed and no
-- further processing is required except to set the By_Ref flag to
-- ensure that gigi does not attempt an extra unnecessary copy
-- (actually not just unnecessary but harmfully wrong in the case of
-- a controlled type, where gigi does not know how to do a copy). 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 Is_Class_Wide_Type (Utyp)
or else Controlled_Type (T))
and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
-- Remove side effects from the expression now so that other parts
-- of the expander do not have to reanalyze the node without this
-- optimization.
Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
-- For controlled types, do the allocation on the secondary stack
-- manually in order to call adjust at the right time:
-- type Anon1 is access Return_Type;
-- for Anon1'Storage_pool use ss_pool;
-- Anon2 : anon1 := new Return_Type'(expr);
-- return Anon2.all;
-- We do the same for classwide types that are not potentially
-- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types.
elsif CW_Or_Controlled_Type (Utyp) then
declare
Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
Acc_Typ : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
Alloc_Node : Node_Id;
begin
Set_Ekind (Acc_Typ, E_Access_Type);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
Alloc_Node :=
Make_Allocator (Loc,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (Etype (Exp), Loc),
Expression => Relocate_Node (Exp)));
Insert_List_Before_And_Analyze (N, New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (Return_Type, Loc))),
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (Acc_Typ, Loc),
Expression => Alloc_Node)));
Rewrite (Exp,
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc)));
Analyze_And_Resolve (Exp, Return_Type);
end;
-- Otherwise use the gigi mechanism to allocate result on the
-- secondary stack.
else
Set_Storage_Pool (N, RTE (RE_SS_Pool));
-- If we are generating code for the VM do not use
-- SS_Allocate since everything is heap-allocated anyway.
if VM_Target = No_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
end if;
end if;
-- Implement the rules of 6.5(8-10), which require a tag check in the
-- case of a limited tagged return type, and tag reassignment for
-- nonlimited tagged results. These actions are needed when the return
-- type is a specific tagged type and the result expression is a
-- conversion or a formal parameter, because in that case the tag of the
-- expression might differ from the tag of the specific result type.
if Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp)
and then (Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind))
then
-- When the return type is limited, perform a check that the tag of
-- the result is the same as the tag of the return type.
if Is_Limited_Type (Return_Type) then
Insert_Action (Exp,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
New_Reference_To (First_Tag_Component (Utyp), Loc)),
Right_Opnd =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Base_Type (Utyp)))),
Loc))),
Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type, then we
-- have to ensure that the tag of the result is that of the result
-- type. This is handled by making a copy of the expression in the
-- case where it might have a different tag, namely when the
-- expression is a conversion or a formal parameter. We create a new
-- object of the result type and initialize it from the expression,
-- which will implicitly force the tag to be set appropriately.
else
Result_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Result_Exp := New_Reference_To (Result_Id, Loc);
Result_Obj :=
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Id,
Object_Definition => New_Reference_To (Return_Type, Loc),
Constant_Present => True,
Expression => Relocate_Node (Exp));
Set_Assignment_OK (Result_Obj);
Insert_Action (Exp, Result_Obj);
Rewrite (Exp, Result_Exp); case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
Analyze_And_Resolve (Exp, Return_Type);
end if;
-- Ada 2005 (AI-344): If the result type is class-wide, then insert when E_Function |
-- a check that the level of the return expression's underlying type E_Generic_Function =>
-- is not deeper than the level of the master enclosing the function. Expand_Simple_Function_Return (N);
-- Always generate the check when the type of the return expression
-- is class-wide, when it's a type conversion, or when it's a formal
-- parameter. Otherwise, suppress the check in the case where the
-- return expression has a specific type whose level is known not to
-- be statically deeper than the function's result type.
-- Note: accessibility check is skipped in the VM case, since there when E_Procedure |
-- does not seem to be any practical way to implement this check. E_Generic_Procedure |
E_Entry |
E_Entry_Family |
E_Return_Statement =>
Expand_Non_Function_Return (N);
elsif Ada_Version >= Ada_05 when others =>
and then VM_Target = No_VM raise Program_Error;
and then Is_Class_Wide_Type (Return_Type) end case;
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind)
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
then
Insert_Action (Exp,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
Build_Get_Access_Level (Loc,
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr (Exp),
Attribute_Name => Name_Tag)),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Reason => PE_Accessibility_Check_Failed));
end if;
exception exception
when RE_Not_Available => when RE_Not_Available =>
return; return;
end Expand_N_Return_Statement; end Expand_N_Simple_Return_Statement;
-------------------------------- --------------------------------
-- Expand_Non_Function_Return -- -- Expand_Non_Function_Return --
...@@ -3854,7 +3480,7 @@ package body Exp_Ch5 is ...@@ -3854,7 +3480,7 @@ package body Exp_Ch5 is
Lab_Node : Node_Id; Lab_Node : Node_Id;
begin begin
-- If it is a return from procedures do no extra steps -- If it is a return from a procedure do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then if Kind = E_Procedure or else Kind = E_Generic_Procedure then
return; return;
...@@ -3864,7 +3490,7 @@ package body Exp_Ch5 is ...@@ -3864,7 +3490,7 @@ package body Exp_Ch5 is
elsif Kind = E_Return_Statement then elsif Kind = E_Return_Statement then
Rewrite (N, Rewrite (N,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Occurrence_Of (First_Entity (Scope_Id), Loc))); New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
Set_Comes_From_Extended_Return_Statement (N); Set_Comes_From_Extended_Return_Statement (N);
...@@ -3938,36 +3564,6 @@ package body Exp_Ch5 is ...@@ -3938,36 +3564,6 @@ package body Exp_Ch5 is
end if; end if;
end Expand_Non_Function_Return; end Expand_Non_Function_Return;
--------------------------
-- Expand_Simple_Return --
--------------------------
procedure Expand_Simple_Return (N : Node_Id) is
begin
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
when E_Function |
E_Generic_Function =>
Expand_Simple_Function_Return (N);
when E_Procedure |
E_Generic_Procedure |
E_Entry |
E_Entry_Family |
E_Return_Statement =>
Expand_Non_Function_Return (N);
when others =>
raise Program_Error;
end case;
exception
when RE_Not_Available =>
return;
end Expand_Simple_Return;
----------------------------------- -----------------------------------
-- Expand_Simple_Function_Return -- -- Expand_Simple_Function_Return --
----------------------------------- -----------------------------------
...@@ -4128,7 +3724,7 @@ package body Exp_Ch5 is ...@@ -4128,7 +3724,7 @@ package body Exp_Ch5 is
-- stack on which we are going to put the result. Not only may this -- stack on which we are going to put the result. Not only may this
-- introduce secondary stack leaks but worse, if the reclamation is -- introduce secondary stack leaks but worse, if the reclamation is
-- done too early, then the result we are returning may get -- done too early, then the result we are returning may get
-- clobbered. See example in 7417-003. -- clobbered.
declare declare
S : Entity_Id; S : Entity_Id;
......
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