aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/exp_ch7.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/exp_ch7.adb')
-rw-r--r--gcc/ada/exp_ch7.adb168
1 files changed, 134 insertions, 34 deletions
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 009bee4..dd864b7 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -59,6 +59,7 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
@@ -2331,6 +2332,8 @@ package body Exp_Ch7 is
Ensure_Freeze_Node (Fin_Id);
Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
+ Mutate_Ekind (Fin_Id, E_Procedure);
+ Freeze_Extra_Formals (Fin_Id);
Set_Is_Frozen (Fin_Id);
Append_To (Stmts, Fin_Body);
@@ -3586,18 +3589,22 @@ package body Exp_Ch7 is
procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
begin
- Set_TSS (Typ,
- Make_Deep_Proc
- (Prim => Initialize_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
-
- if not Is_Inherently_Limited_Type (Typ) then
- Set_TSS (Typ,
- Make_Deep_Proc
- (Prim => Adjust_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
+ if Has_Controlled_Component (Typ) then
+ Set_TSS
+ (Typ,
+ Make_Deep_Proc
+ (Prim => Initialize_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
+
+ if not Is_Inherently_Limited_Type (Typ) then
+ Set_TSS
+ (Typ,
+ Make_Deep_Proc
+ (Prim => Adjust_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
+ end if;
end if;
-- Do not generate Deep_Finalize and Finalize_Address if finalization is
@@ -5598,7 +5605,10 @@ package body Exp_Ch7 is
-- Deal with untagged derivation of private views
- if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
+ if Present (Utyp)
+ and then Is_Untagged_Derivation (Typ)
+ and then Is_Implicit_Full_View (Utyp)
+ then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref);
Set_Assignment_OK (Ref);
@@ -6635,6 +6645,16 @@ package body Exp_Ch7 is
-- Raised : Boolean := False;
--
-- begin
+ -- begin
+ -- <Destructor_Proc> (V); -- If applicable
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
+ --
-- if F then
-- begin
-- Finalize (V); -- If applicable
@@ -6690,6 +6710,8 @@ package body Exp_Ch7 is
--
-- begin
-- Deep_Finalize (V._parent, False); -- If applicable
+ -- or
+ -- Deep_Finalize (Parent_Type (V), False); -- Untagged case
-- exception
-- when Id : others =>
-- if not Raised then
@@ -7094,7 +7116,7 @@ package body Exp_Ch7 is
-- or the type is not controlled.
if Is_Empty_List (Bod_Stmts) then
- Append_To (Bod_Stmts, Make_Null_Statement (Loc));
+ Append_New_To (Bod_Stmts, Make_Null_Statement (Loc));
return Bod_Stmts;
@@ -7581,9 +7603,13 @@ package body Exp_Ch7 is
-- Deep_Finalize (Obj._parent, False);
- if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
+ if Is_Derived_Type (Typ) then
declare
- Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
+ Tagd : constant Boolean := Is_Tagged_Type (Typ);
+ Par_Typ : constant Entity_Id :=
+ (if Tagd
+ then Parent_Field_Type (Typ)
+ else Etype (Base_Type (Typ)));
Call : Node_Id;
Fin_Stmt : Node_Id;
@@ -7592,10 +7618,16 @@ package body Exp_Ch7 is
Call :=
Make_Final_Call
(Obj_Ref =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Selector_Name =>
- Make_Identifier (Loc, Name_uParent)),
+ (if Tagd
+ then
+ Make_Selected_Component
+ (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uParent))
+ else
+ Convert_To
+ (Par_Typ, Make_Identifier (Loc, Name_V))),
Typ => Par_Typ,
Skip_Self => True);
@@ -7611,6 +7643,21 @@ package body Exp_Ch7 is
-- Get_Current_Excep.all.all);
-- end if;
-- end;
+ --
+ -- in the tagged case. In the untagged case, which arises
+ -- with the Destructor aspect, generate:
+ --
+ -- begin
+ -- Deep_Finalize (Parent_Type (V), False);
+
+ -- exception
+ -- when Id : others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
if Present (Call) then
Fin_Stmt := Call;
@@ -7656,7 +7703,7 @@ package body Exp_Ch7 is
-- than before, the extension components. That might
-- be more intuitive (as discussed in preceding
-- comment), but it is not required.
- Prepend_To (Bod_Stmts, Fin_Stmt);
+ Prepend_New_To (Bod_Stmts, Fin_Stmt);
end if;
end if;
end if;
@@ -7707,12 +7754,58 @@ package body Exp_Ch7 is
(Finalizer_Data))));
end if;
- Prepend_To (Bod_Stmts,
+ Prepend_New_To (Bod_Stmts,
Make_If_Statement (Loc,
Condition => Make_Identifier (Loc, Name_F),
Then_Statements => New_List (Fin_Stmt)));
end if;
end;
+
+ declare
+ ASN : constant Opt_N_Aspect_Specification_Id :=
+ Get_Rep_Item (Typ, Name_Destructor, False);
+
+ Stmt : Node_Id;
+ Proc : Entity_Id;
+ begin
+ if Present (ASN) then
+ -- Generate:
+ -- begin
+ -- <Destructor_Proc> (V);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
+
+ Proc := Entity (Expression (ASN));
+ Stmt :=
+ Make_Procedure_Call_Statement
+ (Loc,
+ Name => New_Occurrence_Of (Proc, Loc),
+ Parameter_Associations =>
+ New_List (Make_Identifier (Loc, Name_V)));
+ if Exceptions_OK then
+ Stmt :=
+ Make_Block_Statement
+ (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements
+ (Loc,
+ Statements => New_List (Stmt),
+ Exception_Handlers =>
+ New_List
+ (Build_Exception_Handler
+ (Finalizer_Data))));
+ end if;
+
+ Prepend_New_To (Bod_Stmts, Stmt);
+ end if;
+ end;
end if;
-- At this point either all finalization statements have been
@@ -7906,16 +7999,12 @@ package body Exp_Ch7 is
if Is_Untagged_Derivation (Typ) then
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+ elsif Is_Implicit_Full_View (Utyp) then
+ Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
- else
- declare
- Root : constant Entity_Id :=
- Underlying_Type (Root_Type (Base_Type (Typ)));
- begin
- if Is_Protected_Type (Root) then
- Utyp := Corresponding_Record_Type (Root);
- end if;
- end;
+ if Is_Protected_Type (Utyp) then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
end if;
Ref := Unchecked_Convert_To (Utyp, Ref);
@@ -7970,7 +8059,7 @@ package body Exp_Ch7 is
return Empty;
elsif Skip_Self then
- if Has_Controlled_Component (Utyp) then
+ if Has_Controlled_Component (Utyp) or else Has_Destructor (Utyp) then
if Is_Tagged_Type (Utyp) then
Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
else
@@ -7983,6 +8072,7 @@ package body Exp_Ch7 is
elsif Is_Class_Wide_Type (Typ)
or else Is_Interface (Typ)
or else Has_Controlled_Component (Utyp)
+ or else Has_Destructor (Utyp)
then
if Is_Tagged_Type (Utyp) then
Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
@@ -8480,7 +8570,10 @@ package body Exp_Ch7 is
-- Deal with untagged derivation of private views
- if Is_Untagged_Derivation (Typ) and then not Is_Conc then
+ if Is_Untagged_Derivation (Typ)
+ and then not Is_Conc
+ and then Is_Implicit_Full_View (Utyp)
+ then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref);
@@ -9448,9 +9541,16 @@ package body Exp_Ch7 is
procedure Wrap_Transient_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id := Relocate_Node (N);
- Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
Typ : constant Entity_Id := Etype (N);
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'E',
+ Related_Node => Expr);
+ -- We link the temporary with its relocated expression to facilitate
+ -- locating the expression in the expanded code; this simplifies the
+ -- implementation of the function that searchs in the expanded code
+ -- for a function call that has been wrapped in a transient block
+ -- (see Get_Relocated_Function_Call).
+
begin
-- Generate: