home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Geek Gadgets 1
/
ADE-1.bin
/
ade-dist
/
gnat-2.06-src.tgz
/
tar.out
/
fsf
/
gnat
/
ada
/
exp_ch5.adb
< prev
next >
Wrap
Text File
|
1996-09-28
|
44KB
|
1,159 lines
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 5 --
-- --
-- B o d y --
-- --
-- $Revision: 1.77 $ --
-- --
-- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved --
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Exp_Ch7; use Exp_Ch7;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Itypes; use Itypes;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Ch5 is
function Make_Tag_Ctrl_Assignment
(N : Node_Id;
T : Entity_Id;
L, R : Node_Id)
return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
-- that is to say, finalization of the target before, adjustement of
-- the target after and save and restore of the tag and finalization
-- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node, T is the type of
-- the args, L and R are the left and right hand side.
-- XREF says R is unused, is that really true???
-----------------------------------
-- Expand_N_Assignment_Statement --
-----------------------------------
-- For array types, deal with slice assignments and setting the flags
-- to indicate if it can be statically determined which direction the
-- move should go in. Also deal with generating length checks.
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
L : List_Id;
begin
-- First, we do a general transformation of the assignment statement
-- as follows. What we have in general is:
-- [lhs-actions; lhs + lhs-itypes] := [rhs-actions; rhs + rhs-itypes]
-- Of course in a particular case, the actions and/or itypes may not
-- be present. In fact in the great majority of cases, neither side
-- is an expression actions, and neither side has itypes. But if these
-- components are present, we transform this to:
-- lhs-actions
-- N_Implicit_Itypes lhs-itypes
-- rhs-actions
-- N_Implicit_Itypes rhs-itypes
-- The order of evaluation is important because if the right side is
-- an aggregate, we need the left hand side types evaluated first.
if Nkind (Lhs) = N_Expression_Actions
or else (Nkind (Lhs) in N_Has_Itypes
and then Present (First_Itype (Lhs)))
or else Nkind (Rhs) = N_Expression_Actions
or else (Nkind (Rhs) in N_Has_Itypes
and then Present (First_Itype (Rhs)))
then
declare
Inslist : List_Id := New_List;
Itpnod : Node_Id;
begin
if Nkind (Lhs) = N_Expression_Actions then
Append_List (Actions (Lhs), Inslist);
Rewrite_Substitute_Tree (Lhs, Expression (Lhs));
end if;
if Nkind (Lhs) in N_Has_Itypes
and then Present (First_Itype (Lhs))
then
Itpnod := Make_Implicit_Types (Loc);
Transfer_Itypes (From => Lhs, To => Itpnod);
Append (Itpnod, Inslist);
end if;
if Nkind (Rhs) = N_Expression_Actions then
Append_List (Actions (Rhs), Inslist);
Rewrite_Substitute_Tree (Rhs, Expression (Rhs));
end if;
if Nkind (Rhs) in N_Has_Itypes
and then Present (First_Itype (Rhs))
then
Itpnod := Make_Implicit_Types (Loc);
Transfer_Itypes (From => Rhs, To => Itpnod);
Append (Itpnod, Inslist);
end if;
Insert_List_Before (N, Inslist);
end;
end if;
-- First, test case of assignment to packed array element
if Nkind (Lhs) = N_Indexed_Component
and then Is_Packed (Etype (Prefix (Lhs)))
then
Expand_Packed_Element_Set (N);
return;
elsif Is_Tagged_Type (Typ) or else Controlled_Type (Typ) then
-- In the controlled case, we need to make sure that function calls
-- are evaluated before finalizing the target. In all cases, it
-- make the expansion easier if the side-effects are remove first.
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
-- Avoid recursion in the mechanism
Set_Analyzed (N);
-- In the class-wide case, rewrite the assignment in a dispatch
-- call to _assign
if Is_Class_Wide_Type (Typ) then
L := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
Find_Prim_Op (Root_Type (Typ), Name_uAssign), Loc),
Parameter_Associations => New_List (
Duplicate_Subexpr (Lhs),
Make_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Etype (Lhs), Loc),
Expression => Duplicate_Subexpr (Rhs)))));
else
L := Make_Tag_Ctrl_Assignment (N, Typ, Lhs, Rhs);
end if;
-- We can't affort to have destructive Finalization Actions in
-- the Self assignment case, so if the target and the source are
-- not obviously different, code is generated to avoid the self
-- assignment case
if Statically_Different (Lhs, Rhs)
or else Chars (Current_Scope) = Name_uAssign
then
Rewrite_Substitute_Tree (N,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => L)));
-- Otherwise generate:
-- if lhs'address /= rhs'address then
-- <code for controlled and/or tagged assignment>
-- end if;
else
Rewrite_Substitute_Tree (N,
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => Lhs,
Attribute_Name => Name_Address),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => Rhs,
Attribute_Name => Name_Address)),
Then_Statements => L));
end if;
Analyze (N);
-- Array types
elsif Is_Array_Type (Typ) then
Array_Case : declare
Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs);
Act_Rhs : constant Node_Id := Get_Referenced_Object (Rhs);
L_Type : constant Entity_Id := Get_Actual_Subtype (Act_Lhs);
R_Type : constant Entity_Id := Get_Actual_Subtype (Act_Rhs);
begin
Apply_Length_Check (Act_Rhs, L_Type);
-- For multi-dimensional arrays, all we need is the length check
if Number_Dimensions (L_Type) > 1 then
Set_Forwards_OK (N);
Set_Backwards_OK (N);
return;
end if;
-- If left hand side is not an explicit slice, then it is
-- definitely *not* a slice, since any other form (e.g. a
-- function call or the result of indexing into an array
-- or the result of a dereference) cannot possibly denote
-- a slice. This means that it is safe to move in either
-- direction, since either the left and right hand sides
-- are disjoint or they denote exactly the same object.
-- Similarly if the right hand side is not an explicit
-- slice then everything is OK. Both have to be slices
-- for there to be any trouble in doing the assignment
if Nkind (Act_Lhs) /= N_Slice
or else Nkind (Act_Rhs) /= N_Slice
then
Set_Forwards_OK (N);
Set_Backwards_OK (N);
return;
end if;
-- Both left and right hand sides are slices, so we might
-- have overlapping storage areas. First deal with possible
-- renaming of the arrays being sliced.
Slice_Case : declare
Act_L_Array : constant Node_Id :=
Get_Referenced_Object (Prefix (Act_Lhs));
Act_R_Array : constant Node_Id :=
Get_Referenced_Object (Prefix (Act_Rhs));
L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ);
Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ);
Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ);
Cresult : Compare_Result;
begin
-- If both left and right hand arrays are entity names, and
-- refer to different entities, then we know that the move
-- is safe (the two storage areas are completely disjoint).
if Is_Entity_Name (Act_L_Array)
and then Is_Entity_Name (Act_R_Array)
and then Entity (Act_L_Array) /= Entity (Act_R_Array)
then
Set_Forwards_OK (N);
Set_Backwards_OK (N);
-- Otherwise, we assume the worst, which is that the two
-- arrays are the same array. There is no need to check if
-- we know that is the case, because if we don't know it,
-- we still have to assume it!
-- Generally if the same array is involved, then we have
-- an overlapping case. We will have to really assume the
-- worst (i.e. set neither of the OK flags) unless we can
-- determine the lower or upper bounds at compile time and
-- compare them.
else
Cresult := Compile_Time_Compare (Left_Lo, Right_Lo);
if Cresult = Unknown then
Cresult := Compile_Time_Compare (Right_Lo, Right_Hi);
end if;
case Cresult is
when LT | LE | EQ => Set_Forwards_OK (N);
when GT | GE => Set_Backwards_OK (N);
when NE | Unknown => null;
end case;
end if;
-- If we have the overlap case (signalled by one of the two
-- flags Forwards_OK, or Backwards_OK being unset), then we
-- generate the following code to do the slice copy:
-- Forwards_OK = True
-- Rnn : right_index := right_index'First;
-- for Lnn in left-index loop
-- left (Lnn) := right (Rnn);
-- Rnn := right_index'Succ (Rnn);
-- end loop;
-- Forwards_OK = False, Backwards_OK = True
-- Rnn : right_index := right_index'Last;
-- for Lnn in reverse left-index loop
-- left (Lnn) := right (Rnn);
-- Rnn := right_index'Pred (Rnn);
-- end loop;
-- Note: the above code MUST be analyzed with checks off,
-- because otherwise the Succ or Pred could overflow. But
-- in any case this is more efficient!
-- Fowards_OK = Backwards_OK = False
-- if Integer_Address!(left (left-index'First)'Address) <=
-- Integer_Address!(right (right-index'First)'Address)
-- then
-- <code for Forwards_OK = True above>
-- else
-- <code for Backwards_OK = True above>
-- end if;
-- Note: the reason for the unchecked conversion of the
-- address values to Integer_Address for the comparison
-- is that we do not have an easy way of making the <=
-- operation on Address values.
if not Forwards_OK (N)
or else not Backwards_OK (N)
then
Overlap_Case : declare
Lloc : constant Source_Ptr := Sloc (Lhs);
Rloc : constant Source_Ptr := Sloc (Rhs);
E_Larray : Multi_Use.Exp_Id;
E_Rarray : Multi_Use.Exp_Id;
function Gen_Loop (Rev : Boolean) return Node_Id;
-- Generates the declaration and loop for the actual
-- move as described above, with Rev indicating if
-- REVERSE is present (True = REVERSE case). The
-- declaration is inserted (Insert_Before_And_Analyze),
-- and the loop statement itself is returned.
function Gen_Loop (Rev : Boolean) return Node_Id is
Lnn : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Rnn : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
F_Or_L : Name_Id;
S_Or_P : Name_Id;
begin
if Rev then
F_Or_L := Name_Last;
S_Or_P := Name_Pred;
else
F_Or_L := Name_First;
S_Or_P := Name_Succ;
end if;
Insert_Before_And_Analyze (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Rnn,
Object_Definition =>
New_Occurrence_Of (R_Index_Typ, Rloc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (R_Index_Typ, Rloc),
Attribute_Name => F_Or_L)),
Suppress => All_Checks);
return
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Lnn,
Reverse_Present => Rev,
Discrete_Subtype_Definition =>
New_Reference_To (L_Index_Typ, Lloc))),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Lloc,
Prefix => Multi_Use.New_Ref (E_Larray),
Expressions => New_List (
New_Occurrence_Of (Lnn, Lloc))),
Expression =>
Make_Indexed_Component (Lloc,
Prefix => Multi_Use.New_Ref (E_Rarray),
Expressions => New_List (
New_Occurrence_Of (Rnn, Lloc)))),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (R_Index_Typ, Rloc),
Attribute_Name => S_Or_P,
Expressions => New_List (
New_Occurrence_Of (Rnn, Loc))))));
end Gen_Loop;
-- Start of processing for Overlap_Case
begin
-- Even in the case where we generate only one loop,
-- we need to capture the arrays, since we don't want
-- to evaluate them multiple times in the loop.
Multi_Use.New_Exp_Id (Prefix (Act_Lhs), N, E_Larray);
Multi_Use.New_Exp_Id (Prefix (Act_Rhs), N, E_Rarray);
-- Generate right loop or loops depending on case
if Forwards_OK (N) then
Replace_Substitute_Tree (N, Gen_Loop (False));
elsif Backwards_OK (N) then
Replace_Substitute_Tree (N, Gen_Loop (True));
else
Replace_Substitute_Tree (N,
Make_If_Statement (Loc,
Condition =>
Make_Op_Le (Loc,
Left_Opnd =>
Make_Unchecked_Type_Conversion (Lloc,
Subtype_Mark =>
New_Reference_To
(RTE (RE_Integer_Address), Lloc),
Expression =>
Make_Attribute_Reference (Lloc,
Prefix =>
Make_Indexed_Component (Lloc,
Prefix =>
Multi_Use.New_Ref (E_Larray),
Expressions => New_List (
Make_Attribute_Reference (Lloc,
Prefix =>
New_Reference_To
(L_Index_Typ, Lloc),
Attribute_Name =>
Name_First))),
Attribute_Name => Name_Address)),
Right_Opnd =>
Make_Unchecked_Type_Conversion (Rloc,
Subtype_Mark =>
New_Reference_To
(RTE (RE_Integer_Address), Rloc),
Expression =>
Make_Attribute_Reference (Rloc,
Prefix =>
Make_Indexed_Component (Rloc,
Prefix =>
Multi_Use.New_Ref (E_Rarray),
Expressions => New_List (
Make_Attribute_Reference (Rloc,
Prefix =>
New_Reference_To
(R_Index_Typ, Rloc),
Attribute_Name =>
Name_First))),
Attribute_Name => Name_Address))),
Then_Statements => New_List (Gen_Loop (False)),
Else_Statements => New_List (Gen_Loop (True))));
end if;
Analyze (N, Suppress => All_Checks);
end Overlap_Case;
end if;
end Slice_Case;
-- Merge here for all one dimensional array cases, to generate
-- the length check for the one dimensional case. We replace
-- the code for the array assignment by:
-- if left'length /= right'length then
-- raise Constraint_Error;
-- elsif left'length /= 0 then
-- <array assignment code>
-- end if;
-- TBD ???
end Array_Case;
end if;
end Expand_N_Assignment_Statement;
------------------------------
-- Make_Tag_Ctrl_Assignment --
------------------------------
function Make_Tag_Ctrl_Assignment
(N : Node_Id;
T : Entity_Id;
L, R : Node_Id)
return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
In_uAssign : constant Boolean := Chars (Current_Scope) = Name_uAssign;
In_uInit : constant Boolean := Chars (Current_Scope) = Name_uInit_Proc;
Ctrl_Act : constant Boolean := Controlled_Type (T) and then not In_uInit;
Save_Tag : constant Boolean := Is_Tagged_Type (T)
and then not In_uAssign;
Res : List_Id;
Tag_Tmp : Entity_Id;
Prev_Tmp : Entity_Id;
Next_Tmp : Entity_Id;
Ctrl_Ref : Node_Id;
begin
Res := New_List;
-- Finalize the target of the assignment when controlled. (not in
-- the init_proc since it is an initialization more than an
-- assignment)
if Ctrl_Act then
Append_List_To (Res,
Make_Final_Call (
Ref => Duplicate_Subexpr (L),
Typ => T,
Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc),
With_Detach => New_Reference_To (Standard_False, Loc)));
end if;
Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
-- Save the Tag in a local variable 'Tag_Tmp'
if Save_Tag then
Tag_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Tag_Tmp,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc))));
end if;
-- Save the Finalization Pointers in local variables 'Prev_Tmp' and
-- 'Next_Tmp'. For 'Has_Controlled' Objects, these pointers are in
-- the Record_Controller
if Ctrl_Act then
Ctrl_Ref := Duplicate_Subexpr (L);
if Has_Controlled (T) then
Ctrl_Ref :=
Make_Selected_Component (Loc,
Prefix => Ctrl_Ref,
Selector_Name =>
New_Reference_To (Controller_Component (T), Loc));
end if;
Prev_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Prev_Tmp,
Object_Definition =>
New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Finalizable), Loc),
Expression => Ctrl_Ref),
Selector_Name => Make_Identifier (Loc, Name_Prev))));
Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Next_Tmp,
Object_Definition =>
New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Finalizable), Loc),
Expression => New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Next))));
end if;
-- Do the Assignment
Append_To (Res, Relocate_Node (N));
-- Restore the Tag
if Save_Tag then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc)),
Expression => New_Reference_To (Tag_Tmp, Loc)));
end if;
-- Restore the finalization pointers
if Ctrl_Act then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Finalizable), Loc),
Expression => New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Prev)),
Expression => New_Reference_To (Prev_Tmp, Loc)));
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RE_Finalizable), Loc),
Expression => New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Next)),
Expression => New_Reference_To (Next_Tmp, Loc)));
end if;
-- Adjust the target after the assignment when controlled. (not in
-- the init_proc since it is an initialization more than an
-- assignment)
if Ctrl_Act then
Append_List_To (Res,
Make_Adjust_Call (
Ref => Duplicate_Subexpr (L),
Typ => T,
Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc),
With_Attach => New_Reference_To (Standard_False, Loc)));
end if;
return Res;
end Make_Tag_Ctrl_Assignment;
-----------------------------
-- Expand_N_Case_Statement --
-----------------------------
-- If the last alternative is not an Others choice replace it with an
-- N_Others_Choice. Note that we do not bother to call Analyze on the
-- modified case statement, since it's only effect would be to compute
-- the contents of the Others_Discrete_Choices node laboriously, and of
-- course we already know the list of choices that corresponds to the
-- others choice (it's the list we are replacing!)
procedure Expand_N_Case_Statement (N : Node_Id) is
Altnode : constant Node_Id := Last (Alternatives (N));
Others_Node : Node_Id;
begin
if Nkind (First (Discrete_Choices (Altnode))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Altnode));
Set_Others_Discrete_Choices
(Others_Node, Discrete_Choices (Altnode));
Set_Discrete_Choices (Altnode, New_List (Others_Node));
end if;
end Expand_N_Case_Statement;
---------------------------
-- Expand_N_If_Statement --
---------------------------
-- Remove elsif parts which have non-empty Condition_Actions and rewrite
-- as independent if statements. For example:
-- if x then xs
-- elsif y then ys
-- ...
-- end if;
-- becomes
--
-- if x then xs
-- else
-- <<condition actions of y>>
-- if y then ys
-- ...
-- end if;
-- end if;
-- This explosing is only needed if at least one elsif part has a
-- non-empty Condition_Actions
procedure Expand_N_If_Statement (N : Node_Id) is
CA : Boolean := False;
E : Node_Id;
EP : List_Id;
New_If : Node_Id;
begin
if Present (Elsif_Parts (N)) then
E := First (Elsif_Parts (N));
while Present (E) loop
if Present (Condition_Actions (E)) then
CA := True;
exit;
end if;
E := Next (E);
end loop;
end if;
-- Here if at least one ELSIF part has Condition_Actions set
if CA then
EP := Elsif_Parts (N);
Set_Elsif_Parts (N, No_List);
-- Loop to find the ELSIF that has Condition_Actions set
loop
E := Remove_Head (EP);
-- If no condition actions set, leave as elsif
if No (Condition_Actions (E)) then
if No (Elsif_Parts (N)) then
Set_Elsif_Parts (N, New_List (E));
else
Append (E, Elsif_Parts (N));
end if;
-- Here is the one that needs rewriting
else
if Is_Empty_List (EP) then
EP := No_List;
end if;
New_If :=
Make_If_Statement (Sloc (E),
Condition => Condition (E),
Then_Statements => Then_Statements (E),
Elsif_Parts => EP,
Else_Statements => Else_Statements (N));
Set_Else_Statements (N, Condition_Actions (E));
Append (New_If, Else_Statements (N));
-- Analyze this new if, and we are done. Note that this analyze
-- call will recursively deal with any remaining elsif's that
-- need processing.
Analyze (New_If);
return;
end if;
end loop;
end if;
end Expand_N_If_Statement;
-----------------------------
-- Expand_N_Loop_Statement --
-----------------------------
-- 1. Deal with loops with a non-standard enumeration type range
-- 2. Deal with while loops where Condition_Actions is set
procedure Expand_N_Loop_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Isc : constant Node_Id := Iteration_Scheme (N);
begin
if No (Isc) then
return;
end if;
-- Handle the case where we have a for loop with the range type being
-- an enumeration type with non-standard representation. In this case
-- we expand:
-- for x in [reverse] a .. b loop
-- ...
-- end loop;
-- to
-- for xP in [reverse] integer
-- range etype'Pos (a) .. etype'Pos (b) loop
-- declare
-- x : constant etype := Pos_To_Rep (xP);
-- begin
-- ...
-- end;
-- end loop;
if Present (Loop_Parameter_Specification (Isc)) then
declare
LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
Ltype : constant Entity_Id := Etype (Loop_Id);
Btype : constant Entity_Id := Base_Type (Ltype);
New_Id : Entity_Id;
Lo, Hi : Node_Id;
begin
if not Is_Enumeration_Type (Btype)
or else No (Enum_Pos_To_Rep (Btype))
then
return;
end if;
New_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Loop_Id), 'P'));
Lo := Type_Low_Bound (Ltype);
Hi := Type_High_Bound (Ltype);
Rewrite_Substitute_Tree (N,
Make_Loop_Statement (Loc,
Identifier => Identifier (N),
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => New_Id,
Reverse_Present => Reverse_Present (LPS),
Discrete_Subtype_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Reference_To (Standard_Natural, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Btype, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Relocate_Node
(Type_Low_Bound (Ltype)))),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Btype, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Relocate_Node
(Type_High_Bound (Ltype))))))))),
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Loop_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Ltype, Loc),
Expression =>
Make_Indexed_Component (Loc,
Prefix =>
New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
Expressions => New_List (
New_Reference_To (New_Id, Loc))))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements (N))))));
Analyze (N);
end;
-- Second case, if we have a while loop with Condition_Actions set,
-- then we change it into a plain loop:
-- while C loop
-- ...
-- end loop;
-- changed to:
-- loop
-- <<condition actions>>
-- exit when not C;
-- ...
-- end loop
elsif Present (Isc)
and then Present (Condition_Actions (Isc))
then
declare
Cond : constant Node_Id := Condition (Isc);
ES : Node_Id;
begin
ES :=
Make_Exit_Statement (Sloc (Condition (Isc)),
Condition =>
Make_Op_Not (Sloc (Condition (Isc)),
Right_Opnd => Condition (Isc)));
Prepend (ES, Statements (N));
Insert_List_Before (ES, Condition_Actions (Isc));
Replace_Substitute_Tree (N,
Make_Loop_Statement (Sloc (N),
Statements => Statements (N)));
Analyze (N);
end;
end if;
end Expand_N_Loop_Statement;
-------------------------------
-- Expand_N_Return_Statement --
-------------------------------
procedure Expand_N_Return_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Exp : constant Node_Id := Expression (N);
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 : Int;
begin
for J in reverse 0 .. Scope_Stack.Last loop
Scope_Id := Scope_Stack.Table (J).Entity;
Cur_Idx := J;
exit when Ekind (Scope_Id) /= E_Block and then
Ekind (Scope_Id) /= E_Loop;
end loop;
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 (Kind = E_Entry or else Kind = E_Entry_Family);
-- 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);
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_Substitute_Tree (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);
Utyp := Underlying_Type (T);
-- 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_Substitute_Tree (Exp, Convert_To (Etype (Scope_Id), Exp));
Analyze (Exp);
end if;
-- Allocate the result on the secondary stack for controlled types
if Is_Record_Type (Utyp)
and then Controlled_Type (Utyp)
and then not Is_Return_By_Reference_Type (T)
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 (T, 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 (Etype (Scope_Id), Loc))),
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (Acc_Typ, Loc),
Expression => Alloc_Node)));
Rewrite_Substitute_Tree (Exp,
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc)));
Analyze (Exp);
Resolve (Exp, T);
-- Set the Return_By_Ref fag so that gigi will not allocate
-- the result twice
Set_Returns_By_Ref (Scope_Id);
end;
elsif Requires_Transient_Scope (Etype (Scope_Id))
and then not Is_Return_By_Reference_Type (T)
then
Set_Storage_Pool (N, RTE (RE_SS_Pool));
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
end if;
end Expand_N_Return_Statement;
end Exp_Ch5;
