This patch protects adjustment, finalization, and initialization-related code
from scenarios where a private type may not have been successfully frozen due
to a missing full view.
------------
-- Source --
------------
-- missing_view.ads
with Ada.Finalization; use Ada.Finalization;
package Missing_View is
type Ctrl is new Controlled with private;
type Rec is new Controlled with private;
private
type Rec is new Controlled with record
Comp : Ctrl;
end record;
end Missing_View;
----------------------------
-- Compilation and output --
----------------------------
$ gcc -c missing_view.ads
missing_view.ads:4:09: missing full declaration for private extension
missing_view.ads:8:09: premature usage of incomplete type "Rec" defined at line
8
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-12 Hristian Kirtchev <kirtc...@adacore.com>
* exp_aggr.adb (Build_Record_Aggr_Code): Guard against a missing
adjustment primitive when the ancestor type was not properly frozen.
(Gen_Assign): Guard against a missing initialization
primitive when the component type was not properly frozen.
(Initialize_Array_Component): Guard against a missing adjustment
primitive when the component type was not properly frozen.
(Initialize_Record_Component): Guard against a missing adjustment
primitive when the component type was not properly frozen.
(Process_Transient_Component_Completion): The transient object may
not be finalized when its associated type was not properly frozen.
* exp_ch3.adb (Build_Assignment): Guard against a missing
adjustment primitive when the component type was not properly frozen.
(Build_Initialization_Call): Guard against a missing
initialization primitive when the associated type was not properly
frozen.
(Expand_N_Object_Declaration): Guard against a missing
adjustment primitive when the base type was not properly frozen.
(Predefined_Primitive_Bodies): Create an empty Deep_Adjust
body when there is no adjustment primitive available. Create an
empty Deep_Finalize body when there is no finalization primitive
available.
* exp_ch4.adb (Apply_Accessibility_Check): Guard against a
missing finalization primitive when the designated type was
not properly frozen.
(Expand_N_Allocator): Guard against a missing initialization primitive
when the designated type was not properly frozen.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add the adjustment call
only when the corresponding adjustment primitive is available.
* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Generate the
adjustment/finalization statements only when there is an available
primitive to carry out the action.
(Build_Initialize_Statements): Generate the initialization/finalization
statements only when there is an available primitive to carry out the
action.
(Make_Adjust_Call): Do not generate a call when the underlying
type is not present due to a possible missing full view.
(Make_Final_Call): Do not generate a call when the underlying
type is not present due to a possible missing full view.
(Make_Finalize_Address_Stmts): Generate an empty body when the
designated type lacks a finalization primitive.
(Make_Init_Call): Do not generate a call when the underlying type is
not present due to a possible missing full view.
(Process_Component_For_Adjust): Add the adjustment call only when the
corresponding adjustment primitive is available.
(Process_Component_For_Finalize): Add the finalization call only when
the corresponding finalization primitive is available.
(Process_Object_Declaration): Use a null statement to emulate a
missing call to the finalization primitive of the object type.
* exp_ch7.ads (Make_Adjust_Call): Update the comment on usage.
(Make_Final_Call): Update the comment on usage.
(Make_Init_Call): Update the comment on usage.
* exp_util.adb (Build_Transient_Object_Statements): Code reformatting.
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 244350)
+++ exp_aggr.adb (working copy)
@@ -1128,6 +1128,7 @@
and then Needs_Finalization (Comp_Typ);
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
Blk_Stmts : List_Id;
Init_Stmt : Node_Id;
@@ -1222,10 +1223,17 @@
and then Is_Controlled (Component_Type (Comp_Typ))
and then Nkind (Expr) = N_Aggregate)
then
- Append_To (Blk_Stmts,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Arr_Comp),
- Typ => Comp_Typ));
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component
+ -- type was not frozen properly.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
end if;
-- Complete the protection of the initialization statements
@@ -1390,6 +1398,7 @@
Comp_Typ : Entity_Id := Empty;
Expr_Q : Node_Id;
Indexed_Comp : Node_Id;
+ Init_Call : Node_Id;
New_Indexes : List_Id;
-- Start of processing for Gen_Assign
@@ -1613,10 +1622,17 @@
end if;
if Needs_Finalization (Ctype) then
- Append_To (Stmts,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype));
+ Typ => Ctype);
+
+ -- Guard against a missing [Deep_]Initialize when the component
+ -- type was not properly frozen.
+
+ if Present (Init_Call) then
+ Append_To (Stmts, Init_Call);
+ end if;
end if;
end if;
@@ -2847,6 +2863,7 @@
Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
Blk_Stmts : List_Id;
Init_Stmt : Node_Id;
@@ -2912,10 +2929,17 @@
-- [Deep_]Adjust (Rec_Comp);
if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
- Append_To (Blk_Stmts,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Rec_Comp),
- Typ => Comp_Typ));
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
end if;
-- Complete the protection of the initialization statements
@@ -3062,6 +3086,7 @@
if Nkind (N) = N_Extension_Aggregate then
declare
Ancestor : constant Node_Id := Ancestor_Part (N);
+ Adj_Call : Node_Id;
Assign : List_Id;
begin
@@ -3274,10 +3299,17 @@
if Needs_Finalization (Etype (Ancestor))
and then not Is_Limited_Type (Etype (Ancestor))
then
- Append_To (Assign,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Ref),
- Typ => Etype (Ancestor)));
+ Typ => Etype (Ancestor));
+
+ -- Guard against a missing [Deep_]Adjust when the ancestor
+ -- type was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Assign, Adj_Call);
+ end if;
end if;
Append_To (L,
@@ -7832,7 +7864,6 @@
not Restriction_Active (No_Exception_Propagation);
begin
- pragma Assert (Present (Fin_Call));
pragma Assert (Present (Hook_Clear));
-- Generate the following code if exception propagation is allowed:
@@ -7872,6 +7903,7 @@
Abort_And_Exception : declare
Blk_Decls : constant List_Id := New_List;
Blk_Stmts : constant List_Id := New_List;
+ Fin_Stmts : constant List_Id := New_List;
Fin_Data : Finalization_Exception_Data;
@@ -7892,13 +7924,17 @@
-- Wrap the hook clear and the finalization call in order to trap
-- a potential exception.
+ Append_To (Fin_Stmts, Hook_Clear);
+
+ if Present (Fin_Call) then
+ Append_To (Fin_Stmts, Fin_Call);
+ end if;
+
Append_To (Blk_Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Hook_Clear,
- Fin_Call),
+ Statements => Fin_Stmts,
Exception_Handlers => New_List (
Build_Exception_Handler (Fin_Data)))));
@@ -7943,8 +7979,11 @@
begin
Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Blk_Stmts, Hook_Clear);
- Append_To (Blk_Stmts, Fin_Call);
+ if Present (Fin_Call) then
+ Append_To (Blk_Stmts, Fin_Call);
+ end if;
+
Append_To (Stmts,
Build_Abort_Undefer_Block (Loc,
Stmts => Blk_Stmts,
@@ -7958,7 +7997,10 @@
else
Append_To (Stmts, Hook_Clear);
- Append_To (Stmts, Fin_Call);
+
+ if Present (Fin_Call) then
+ Append_To (Stmts, Fin_Call);
+ end if;
end if;
end Process_Transient_Component_Completion;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 244360)
+++ exp_ch3.adb (working copy)
@@ -1295,6 +1295,7 @@
First_Arg : Node_Id;
Full_Init_Type : Entity_Id;
Full_Type : Entity_Id;
+ Init_Call : Node_Id;
Init_Type : Entity_Id;
Proc : Entity_Id;
@@ -1515,7 +1516,7 @@
then
Append_To (Args,
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Prefix (Id_Ref)),
+ Prefix => New_Copy_Tree (Prefix (Id_Ref)),
Selector_Name => Arg));
else
Append_To (Args, Arg);
@@ -1542,17 +1543,24 @@
Append_To (Res,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc, Loc),
+ Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
if Needs_Finalization (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
- Append_To (Res,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (First_Arg),
- Typ => Typ));
+ Typ => Typ);
+
+ -- Guard against a missing [Deep_]Initialize when the type was not
+ -- properly frozen.
+
+ if Present (Init_Call) then
+ Append_To (Res, Init_Call);
+ end if;
end if;
end if;
@@ -1651,11 +1659,13 @@
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
N_Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
- Exp : Node_Id := N;
- Kind : Node_Kind := Nkind (N);
- Lhs : Node_Id;
- Res : List_Id;
+ Adj_Call : Node_Id;
+ Exp : Node_Id := N;
+ Kind : Node_Kind := Nkind (N);
+ Lhs : Node_Id;
+ Res : List_Id;
+
begin
Lhs :=
Make_Selected_Component (N_Loc,
@@ -1734,10 +1744,17 @@
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
and then not Is_Limited_View (Typ)
then
- Append_To (Res,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id)));
+ Typ => Etype (Id));
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Res, Adj_Call);
+ end if;
end if;
-- If a component type has a predicate, add check to the component
@@ -5830,7 +5847,9 @@
-- Local variables
- Next_N : constant Node_Id := Next (N);
+ Next_N : constant Node_Id := Next (N);
+
+ Adj_Call : Node_Id;
Id_Ref : Node_Id;
Tag_Assign : Node_Id;
@@ -6332,10 +6351,17 @@
and then not Is_Limited_View (Typ)
and then not Rewrite_As_Renaming
then
- Insert_Action_After (Init_After,
+ Adj_Call :=
Make_Adjust_Call (
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Typ));
+ Typ => Base_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the base type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Insert_Action_After (Init_After, Adj_Call);
+ end if;
end if;
-- For tagged types, when an init value is given, the tag has to
@@ -9530,7 +9556,9 @@
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
+ Adj_Call : Node_Id;
Decl : Node_Id;
+ Fin_Call : Node_Id;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Name : Name_Id;
@@ -9756,42 +9784,45 @@
elsif not Has_Controlled_Component (Tag_Typ) then
if not Is_Limited_Type (Tag_Typ) then
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
+ Adj_Call := Empty;
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
if Is_Controlled (Tag_Typ) then
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Adjust_Call (
- Obj_Ref => Make_Identifier (Loc, Name_V),
- Typ => Tag_Typ))));
+ Adj_Call :=
+ Make_Adjust_Call (
+ Obj_Ref => Make_Identifier (Loc, Name_V),
+ Typ => Tag_Typ);
+ end if;
- else
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Null_Statement (Loc))));
+ if No (Adj_Call) then
+ Adj_Call := Make_Null_Statement (Loc);
end if;
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Adj_Call)));
+
Append_To (Res, Decl);
end if;
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
+ Fin_Call := Empty;
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
if Is_Controlled (Tag_Typ) then
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call
- (Obj_Ref => Make_Identifier (Loc, Name_V),
- Typ => Tag_Typ))));
+ Fin_Call :=
+ Make_Final_Call
+ (Obj_Ref => Make_Identifier (Loc, Name_V),
+ Typ => Tag_Typ);
+ end if;
- else
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Make_Null_Statement (Loc))));
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
end if;
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call)));
+
Append_To (Res, Decl);
end if;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 244350)
+++ exp_ch4.adb (working copy)
@@ -632,6 +632,13 @@
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT);
+ -- Guard against a missing [Deep_]Finalize when the designated
+ -- type was not properly frozen.
+
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
+ end if;
+
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation
-- even if finalization fails. Generate:
@@ -722,6 +729,7 @@
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
+ Adj_Call : Node_Id;
Node : Node_Id;
Tag_Assign : Node_Id;
Temp : Entity_Id;
@@ -1060,13 +1068,17 @@
-- the designated type can be an ancestor of the subtype mark of
-- the allocator.
- Insert_Action (N,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref =>
Unchecked_Convert_To (T,
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc))),
- Typ => T));
+ Typ => T);
+
+ if Present (Adj_Call) then
+ Insert_Action (N, Adj_Call);
+ end if;
end if;
-- Note: the accessibility check must be inserted after the call to
@@ -4315,6 +4327,7 @@
Discr : Elmt_Id;
Init : Entity_Id;
Init_Arg1 : Node_Id;
+ Init_Call : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
@@ -4635,10 +4648,17 @@
-- Generate:
-- [Deep_]Initialize (Init_Arg1);
- Insert_Action (N,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
- Typ => T));
+ Typ => T);
+
+ -- Guard against a missing [Deep_]Initialize when the
+ -- designated type was not properly frozen.
+
+ if Present (Init_Call) then
+ Insert_Action (N, Init_Call);
+ end if;
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 244356)
+++ exp_ch5.adb (working copy)
@@ -4676,7 +4676,9 @@
and then not Comp_Asn
and then not No_Ctrl_Actions (N)
and then Tagged_Type_Expansion;
- Tag_Id : Entity_Id;
+ Adj_Call : Node_Id;
+ Fin_Call : Node_Id;
+ Tag_Id : Entity_Id;
begin
-- Finalize the target of the assignment when controlled
@@ -4709,10 +4711,14 @@
null;
else
- Append_To (Res,
+ Fin_Call :=
Make_Final_Call
(Obj_Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L)));
+ Typ => Etype (L));
+
+ if Present (Fin_Call) then
+ Append_To (Res, Fin_Call);
+ end if;
end if;
-- Save the Tag in a local variable Tag_Id
@@ -4765,10 +4771,14 @@
-- init proc since it is an initialization more than an assignment).
if Ctrl_Act then
- Append_To (Res,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
- Typ => Etype (L)));
+ Typ => Etype (L));
+
+ if Present (Adj_Call) then
+ Append_To (Res, Adj_Call);
+ end if;
end if;
return Res;
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 244352)
+++ exp_ch7.adb (working copy)
@@ -3062,6 +3062,13 @@
Obj_Ref => Obj_Ref,
Typ => Obj_Typ);
+ -- Guard against a missing [Deep_]Finalize when the object type
+ -- was not properly frozen.
+
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
+ end if;
+
-- For CodePeer, the exception handlers normally generated here
-- generate complex flowgraphs which result in capacity problems.
-- Omitting these handlers for CodePeer is justified as follows:
@@ -6905,10 +6912,12 @@
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
Adj_Id : Entity_Id := Empty;
- Ref : Node_Id := Obj_Ref;
+ Ref : Node_Id;
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Recover the proper type which contains Deep_Adjust
if Is_Class_Wide_Type (Typ) then
@@ -6922,7 +6931,7 @@
-- Deal with untagged derivation of private views
- if Is_Untagged_Derivation (Typ) then
+ if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref);
Set_Assignment_OK (Ref);
@@ -6931,14 +6940,21 @@
-- When dealing with the completion of a private type, use the base
-- type instead.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
Ref := Unchecked_Convert_To (Utyp, Ref);
end if;
- if Skip_Self then
+ -- The underlying type may not be present due to a missing full view. In
+ -- this case freezing did not take place and there is no [Deep_]Adjust
+ -- primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+
+ elsif Skip_Self then
if Has_Controlled_Component (Utyp) then
if Is_Tagged_Type (Utyp) then
Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
@@ -6998,7 +7014,7 @@
return
Make_Call (Loc,
Proc_Id => Adj_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
@@ -7171,23 +7187,13 @@
function Build_Adjust_Or_Finalize_Statements
(Typ : Entity_Id) return List_Id
is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
- Finalizer_Decls : List_Id := No_List;
- Finalizer_Data : Finalization_Exception_Data;
- Call : Node_Id;
- Comp_Ref : Node_Id;
- Core_Loop : Node_Id;
- Dim : Int;
- J : Entity_Id;
- Loop_Id : Entity_Id;
- Stmts : List_Id;
-
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
@@ -7206,13 +7212,26 @@
end loop;
end Build_Indexes;
+ -- Local variables
+
+ Final_Decls : List_Id := No_List;
+ Final_Data : Finalization_Exception_Data;
+ Block : Node_Id;
+ Call : Node_Id;
+ Comp_Ref : Node_Id;
+ Core_Loop : Node_Id;
+ Dim : Int;
+ J : Entity_Id;
+ Loop_Id : Entity_Id;
+ Stmts : List_Id;
+
-- Start of processing for Build_Adjust_Or_Finalize_Statements
begin
- Finalizer_Decls := New_List;
+ Final_Decls := New_List;
Build_Indexes;
- Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
+ Build_Object_Declarations (Final_Data, Final_Decls, Loc);
Comp_Ref :=
Make_Indexed_Component (Loc,
@@ -7233,99 +7252,111 @@
Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end if;
- -- Generate the block which houses the adjust or finalize call:
+ if Present (Call) then
- -- begin
- -- <adjust or finalize call>
+ -- Generate the block which houses the adjust or finalize call:
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence (E, Get_Current_Excep.all.all);
- -- end if;
- -- end;
+ -- begin
+ -- <adjust or finalize call>
- if Exceptions_OK then
- Core_Loop :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- else
- Core_Loop := Call;
- end if;
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
- -- Generate the dimension loops starting from the innermost one
+ if Exceptions_OK then
+ Core_Loop :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Final_Data))));
+ else
+ Core_Loop := Call;
+ end if;
- -- for Jnn in [reverse] V'Range (Dim) loop
- -- <core loop>
- -- end loop;
+ -- Generate the dimension loops starting from the innermost one
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ -- for Jnn in [reverse] V'Range (Dim) loop
+ -- <core loop>
+ -- end loop;
- Core_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))),
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
- Reverse_Present => Prim = Finalize_Case)),
+ Core_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
- Statements => New_List (Core_Loop),
- End_Label => Empty);
+ Reverse_Present =>
+ Prim = Finalize_Case)),
- Dim := Dim - 1;
- end loop;
+ Statements => New_List (Core_Loop),
+ End_Label => Empty);
- -- Generate the block which contains the core loop, the declarations
- -- of the abort flag, the exception occurrence, the raised flag and
- -- the conditional raise:
+ Dim := Dim - 1;
+ end loop;
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- Generate the block which contains the core loop, declarations
+ -- of the abort flag, the exception occurrence, the raised flag
+ -- and the conditional raise:
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- -- begin
- -- <core loop>
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
- -- end;
+ -- begin
+ -- <core loop>
- Stmts := New_List (Core_Loop);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
+ Stmts := New_List (Core_Loop);
+
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ end if;
+
+ Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
+
+ else
+ Block := Make_Null_Statement (Loc);
end if;
- return
- New_List (
- Make_Block_Statement (Loc,
- Declarations =>
- Finalizer_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+ return New_List (Block);
end Build_Adjust_Or_Finalize_Statements;
---------------------------------
@@ -7333,32 +7364,21 @@
---------------------------------
function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Final_List : constant List_Id := New_List;
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Final_List : constant List_Id := New_List;
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
- Counter_Id : Entity_Id;
- Dim : Int;
- F : Node_Id;
- Fin_Stmt : Node_Id;
- Final_Block : Node_Id;
- Final_Loop : Node_Id;
- Finalizer_Data : Finalization_Exception_Data;
- Finalizer_Decls : List_Id := No_List;
- Init_Loop : Node_Id;
- J : Node_Id;
- Loop_Id : Node_Id;
- Stmts : List_Id;
-
- function Build_Counter_Assignment return Node_Id;
+ function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
-- Generate the following assignment:
-- Counter := V'Length (1) *
-- ...
-- V'Length (N) - Counter;
+ --
+ -- Counter_Id denotes the entity of the counter.
function Build_Finalization_Call return Node_Id;
-- Generate a deep finalization call for an array element
@@ -7370,11 +7390,11 @@
function Build_Initialization_Call return Node_Id;
-- Generate a deep initialization call for an array element
- ------------------------------
- -- Build_Counter_Assignment --
- ------------------------------
+ ----------------------
+ -- Build_Assignment --
+ ----------------------
- function Build_Counter_Assignment return Node_Id is
+ function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
Dim : Int;
Expr : Node_Id;
@@ -7417,7 +7437,7 @@
Make_Op_Subtract (Loc,
Left_Opnd => Expr,
Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
- end Build_Counter_Assignment;
+ end Build_Assignment;
-----------------------------
-- Build_Finalization_Call --
@@ -7476,14 +7496,31 @@
return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end Build_Initialization_Call;
+ -- Local variables
+
+ Counter_Id : Entity_Id;
+ Dim : Int;
+ F : Node_Id;
+ Fin_Stmt : Node_Id;
+ Final_Block : Node_Id;
+ Final_Data : Finalization_Exception_Data;
+ Final_Decls : List_Id := No_List;
+ Final_Loop : Node_Id;
+ Init_Block : Node_Id;
+ Init_Call : Node_Id;
+ Init_Loop : Node_Id;
+ J : Node_Id;
+ Loop_Id : Node_Id;
+ Stmts : List_Id;
+
-- Start of processing for Build_Initialize_Statements
begin
- Counter_Id := Make_Temporary (Loc, 'C');
- Finalizer_Decls := New_List;
+ Counter_Id := Make_Temporary (Loc, 'C');
+ Final_Decls := New_List;
Build_Indexes;
- Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
+ Build_Object_Declarations (Final_Data, Final_Decls, Loc);
-- Generate the block which houses the finalization call, the index
-- guard and the handler which triggers Program_Error later on.
@@ -7502,115 +7539,124 @@
-- end;
-- end if;
- if Exceptions_OK then
- Fin_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Build_Finalization_Call),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- else
- Fin_Stmt := Build_Finalization_Call;
- end if;
+ Fin_Stmt := Build_Finalization_Call;
- -- This is the core of the loop, the dimension iterators are added
- -- one by one in reverse.
+ if Present (Fin_Stmt) then
+ if Exceptions_OK then
+ Fin_Stmt :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Stmt),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Final_Data))));
+ end if;
- Final_Loop :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ -- This is the core of the loop, the dimension iterators are added
+ -- one by one in reverse.
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Counter_Id, Loc),
- Expression =>
- Make_Op_Subtract (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)))),
+ Final_Loop :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
- Else_Statements => New_List (Fin_Stmt));
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Counter_Id, Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)))),
- -- Generate all finalization loops starting from the innermost
- -- dimension.
+ Else_Statements => New_List (Fin_Stmt));
- -- for Fnn in reverse V'Range (Dim) loop
- -- <final loop>
- -- end loop;
+ -- Generate all finalization loops starting from the innermost
+ -- dimension.
- F := Last (Final_List);
- Dim := Num_Dims;
- while Present (F) and then Dim > 0 loop
- Loop_Id := F;
- Prev (F);
- Remove (Loop_Id);
+ -- for Fnn in reverse V'Range (Dim) loop
+ -- <final loop>
+ -- end loop;
- Final_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))),
+ F := Last (Final_List);
+ Dim := Num_Dims;
+ while Present (F) and then Dim > 0 loop
+ Loop_Id := F;
+ Prev (F);
+ Remove (Loop_Id);
- Reverse_Present => True)),
+ Final_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
- Statements => New_List (Final_Loop),
- End_Label => Empty);
+ Reverse_Present => True)),
- Dim := Dim - 1;
- end loop;
+ Statements => New_List (Final_Loop),
+ End_Label => Empty);
- -- Generate the block which contains the finalization loops, the
- -- declarations of the abort flag, the exception occurrence, the
- -- raised flag and the conditional raise.
+ Dim := Dim - 1;
+ end loop;
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- Generate the block which contains the finalization loops, the
+ -- declarations of the abort flag, the exception occurrence, the
+ -- raised flag and the conditional raise.
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- -- begin
- -- Counter :=
- -- V'Length (1) *
- -- ...
- -- V'Length (N) - Counter;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- <final loop>
+ -- begin
+ -- Counter :=
+ -- V'Length (1) *
+ -- ...
+ -- V'Length (N) - Counter;
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
+ -- <final loop>
- -- raise;
- -- end;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
- Stmts := New_List (Build_Counter_Assignment, Final_Loop);
+ -- raise;
+ -- end;
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
- Append_To (Stmts, Make_Raise_Statement (Loc));
+ Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
+
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ Append_To (Stmts, Make_Raise_Statement (Loc));
+ end if;
+
+ Final_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Finalize primitive to call.
+
+ else
+ Final_Block := Make_Null_Statement (Loc);
end if;
- Final_Block :=
- Make_Block_Statement (Loc,
- Declarations =>
- Finalizer_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-
-- Generate the block which contains the initialization call and
-- the partial finalization code.
@@ -7624,70 +7670,73 @@
-- <finalization code>
-- end;
- Init_Loop :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Build_Initialization_Call),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (Final_Block)))));
+ Init_Call := Build_Initialization_Call;
- Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Counter_Id, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1))));
+ if Present (Init_Call) then
+ Init_Loop :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Init_Call),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (Final_Block)))));
- -- Generate all initialization loops starting from the innermost
- -- dimension.
+ Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Counter_Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
- -- for Jnn in V'Range (Dim) loop
- -- <init loop>
- -- end loop;
+ -- Generate all initialization loops starting from the innermost
+ -- dimension.
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ -- for Jnn in V'Range (Dim) loop
+ -- <init loop>
+ -- end loop;
- Init_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))))),
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
- Statements => New_List (Init_Loop),
- End_Label => Empty);
+ Init_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))))),
- Dim := Dim - 1;
- end loop;
+ Statements => New_List (Init_Loop),
+ End_Label => Empty);
- -- Generate the block which contains the counter variable and the
- -- initialization loops.
+ Dim := Dim - 1;
+ end loop;
- -- declare
- -- Counter : Integer := 0;
- -- begin
- -- <init loop>
- -- end;
+ -- Generate the block which contains the counter variable and the
+ -- initialization loops.
- return
- New_List (
- Make_Block_Statement (Loc,
+ -- declare
+ -- Counter : Integer := 0;
+ -- begin
+ -- <init loop>
+ -- end;
+
+ Init_Block :=
+ Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
@@ -7697,7 +7746,17 @@
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Init_Loop))));
+ Statements => New_List (Init_Loop)));
+
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Initialize primitive to call.
+
+ else
+ Init_Block := Make_Null_Statement (Loc);
+ end if;
+
+ return New_List (Init_Block);
end Build_Initialize_Statements;
-----------------------
@@ -7983,7 +8042,8 @@
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Typ_Def : constant Node_Id :=
+ Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Finalizer_Data : Finalization_Exception_Data;
@@ -8002,12 +8062,7 @@
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id
is
- Stmts : constant List_Id := New_List;
- Decl : Node_Id;
- Decl_Id : Entity_Id;
- Decl_Typ : Entity_Id;
- Has_POC : Boolean;
- Num_Comps : Nat;
+ Stmts : constant List_Id := New_List;
procedure Process_Component_For_Adjust (Decl : Node_Id);
-- Process the declaration of a single controlled component
@@ -8017,10 +8072,11 @@
----------------------------------
procedure Process_Component_For_Adjust (Decl : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (Decl);
- Typ : constant Entity_Id := Etype (Id);
- Adj_Stmt : Node_Id;
+ Id : constant Entity_Id := Defining_Identifier (Decl);
+ Typ : constant Entity_Id := Etype (Id);
+ Adj_Call : Node_Id;
+
begin
-- begin
-- [Deep_]Adjust (V.Id);
@@ -8033,7 +8089,7 @@
-- end if;
-- end;
- Adj_Stmt :=
+ Adj_Call :=
Make_Adjust_Call (
Obj_Ref =>
Make_Selected_Component (Loc,
@@ -8041,19 +8097,32 @@
Selector_Name => Make_Identifier (Loc, Chars (Id))),
Typ => Typ);
- if Exceptions_OK then
- Adj_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Adj_Stmt),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
+ -- Guard against a missing [Deep_]Adjust when the component
+ -- type was not properly frozen.
+
+ if Present (Adj_Call) then
+ if Exceptions_OK then
+ Adj_Call :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Adj_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Finalizer_Data))));
+ end if;
+
+ Append_To (Stmts, Adj_Call);
end if;
-
- Append_To (Stmts, Adj_Stmt);
end Process_Component_For_Adjust;
+ -- Local variables
+
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+ Decl_Typ : Entity_Id;
+ Has_POC : Boolean;
+ Num_Comps : Nat;
+
-- Start of processing for Process_Component_List_For_Adjust
begin
@@ -8389,7 +8458,8 @@
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Typ_Def : constant Node_Id :=
+ Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Counter : Int := 0;
@@ -8447,7 +8517,7 @@
is
Id : constant Entity_Id := Defining_Identifier (Decl);
Typ : constant Entity_Id := Etype (Id);
- Fin_Stmt : Node_Id;
+ Fin_Call : Node_Id;
begin
if Is_Local then
@@ -8511,7 +8581,7 @@
-- end if;
-- end;
- Fin_Stmt :=
+ Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Make_Selected_Component (Loc,
@@ -8519,17 +8589,22 @@
Selector_Name => Make_Identifier (Loc, Chars (Id))),
Typ => Typ);
- if not Restriction_Active (No_Exception_Propagation) then
- Fin_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Stmt),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
+ -- Guard against a missing [Deep_]Finalize when the component
+ -- type was not properly frozen.
+
+ if Present (Fin_Call) then
+ if Exceptions_OK then
+ Fin_Call :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Finalizer_Data))));
+ end if;
+
+ Append_To (Stmts, Fin_Call);
end if;
-
- Append_To (Stmts, Fin_Stmt);
end Process_Component_For_Finalize;
-- Start of processing for Process_Component_List_For_Finalize
@@ -9061,17 +9136,18 @@
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Recover the proper type which contains [Deep_]Finalize
if Is_Class_Wide_Type (Typ) then
Utyp := Root_Type (Typ);
Atyp := Utyp;
- Ref := Obj_Ref;
elsif Is_Concurrent_Type (Typ) then
Utyp := Corresponding_Record_Type (Typ);
Atyp := Empty;
- Ref := Convert_Concurrent (Obj_Ref, Typ);
+ Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
@@ -9079,12 +9155,11 @@
then
Utyp := Corresponding_Record_Type (Full_View (Typ));
Atyp := Typ;
- Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
+ Ref := Convert_Concurrent (Ref, Full_View (Typ));
else
Utyp := Typ;
Atyp := Typ;
- Ref := Obj_Ref;
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
@@ -9113,7 +9188,8 @@
-- their parents. In this case, [Deep_]Finalize can be found in the full
-- view of the parent type.
- if Is_Tagged_Type (Utyp)
+ if Present (Utyp)
+ and then Is_Tagged_Type (Utyp)
and then Is_Derived_Type (Utyp)
and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
and then Is_Private_Type (Etype (Utyp))
@@ -9127,7 +9203,7 @@
-- When dealing with the completion of a private type, use the base type
-- instead.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
Utyp := Base_Type (Utyp);
@@ -9135,7 +9211,14 @@
Set_Assignment_OK (Ref);
end if;
- if Skip_Self then
+ -- The underlying type may not be present due to a missing full view. In
+ -- this case freezing did not take place and there is no [Deep_]Finalize
+ -- primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+
+ elsif Skip_Self then
if Has_Controlled_Component (Utyp) then
if Is_Tagged_Type (Utyp) then
Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
@@ -9215,7 +9298,7 @@
return
Make_Call (Loc,
Proc_Id => Fin_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
@@ -9310,18 +9393,21 @@
---------------------------------
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
- Decls : List_Id;
- Desg_Typ : Entity_Id;
- Obj_Expr : Node_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Decls : List_Id;
+ Desig_Typ : Entity_Id;
+ Fin_Block : Node_Id;
+ Fin_Call : Node_Id;
+ Obj_Expr : Node_Id;
+ Ptr_Typ : Entity_Id;
+
begin
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
- Desg_Typ := First_Subtype (Typ);
+ Desig_Typ := First_Subtype (Typ);
else
- Desg_Typ := Base_Type (Typ);
+ Desig_Typ := Base_Type (Typ);
end if;
-- Class-wide types of constrained root types
@@ -9353,26 +9439,28 @@
Parent_Typ := Underlying_Record_View (Parent_Typ);
end if;
- Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
+ Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
end;
-- General case
else
- Desg_Typ := Typ;
+ Desig_Typ := Typ;
end if;
-- Generate:
-- type Ptr_Typ is access all Typ;
-- for Ptr_Typ'Storage_Size use 0;
+ Ptr_Typ := Make_Temporary (Loc, 'P');
+
Decls := New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
- Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))),
+ Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (Ptr_Typ, Loc),
@@ -9405,7 +9493,7 @@
-- Generate:
-- Dnn : constant Storage_Offset :=
- -- Desg_Typ'Descriptor_Size / Storage_Unit;
+ -- Desig_Typ'Descriptor_Size / Storage_Unit;
Dope_Id := Make_Temporary (Loc, 'D');
@@ -9419,7 +9507,7 @@
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desg_Typ, Loc),
+ Prefix => New_Occurrence_Of (Desig_Typ, Loc),
Attribute_Name => Name_Descriptor_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit))));
@@ -9442,20 +9530,30 @@
end;
end if;
- -- Create the block and the finalization call
+ Fin_Call :=
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
+ Typ => Desig_Typ);
- return New_List (
- Make_Block_Statement (Loc,
- Declarations => Decls,
+ if Present (Fin_Call) then
+ Fin_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call)));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
- Typ => Desg_Typ)))));
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the designated type. If this is the case, there
+ -- is no [Deep_]Finalize primitive to call.
+
+ else
+ Fin_Block := Make_Null_Statement (Loc);
+ end if;
+
+ return New_List (Fin_Block);
end Make_Finalize_Address_Stmts;
-------------------------------------
@@ -9530,13 +9628,15 @@
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Deal with the type and object reference. Depending on the context, an
-- object reference may need several conversions.
if Is_Concurrent_Type (Typ) then
Is_Conc := True;
Utyp := Corresponding_Record_Type (Typ);
- Ref := Convert_Concurrent (Obj_Ref, Typ);
+ Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
@@ -9544,18 +9644,16 @@
then
Is_Conc := True;
Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
- Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
+ Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
else
Is_Conc := False;
Utyp := Typ;
- Ref := Obj_Ref;
end if;
+ Utyp := Underlying_Type (Base_Type (Utyp));
Set_Assignment_OK (Ref);
- Utyp := Underlying_Type (Base_Type (Utyp));
-
-- Deal with untagged derivation of private views
if Is_Untagged_Derivation (Typ) and then not Is_Conc then
@@ -9571,12 +9669,20 @@
-- completion of a private type. We need to access the base type and
-- generate a conversion to it.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
Ref := Unchecked_Convert_To (Utyp, Ref);
end if;
+ -- The underlying type may not be present due to a missing full view.
+ -- In this case freezing did not take place and there is no suitable
+ -- [Deep_]Initialize primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+ end if;
+
-- Select the appropriate version of initialize
if Has_Controlled_Component (Utyp) then
@@ -9596,8 +9702,7 @@
return
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Proc, Loc),
+ Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => New_List (Ref));
end Make_Init_Call;
Index: exp_ch7.ads
===================================================================
--- exp_ch7.ads (revision 244350)
+++ exp_ch7.ads (working copy)
@@ -184,10 +184,11 @@
Typ : Entity_Id;
Skip_Self : Boolean := False) return Node_Id;
-- Create a call to either Adjust or Deep_Adjust depending on the structure
- -- of type Typ. Obj_Ref is an expression with no-side effect (not required
+ -- of type Typ. Obj_Ref is an expression with no side effects (not required
-- to have been previously analyzed) that references the object to be
-- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set,
- -- only the components (if any) are adjusted.
+ -- only the components (if any) are adjusted. Return Empty if Adjust or
+ -- Deep_Adjust is not available, possibly due to previous errors.
function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
-- Create a call to unhook an object from an arbitrary list. Obj_Ref is the
@@ -200,11 +201,13 @@
(Obj_Ref : Node_Id;
Typ : Entity_Id;
Skip_Self : Boolean := False) return Node_Id;
- -- Create a call to either Finalize or Deep_Finalize depending on the
- -- structure of type Typ. Obj_Ref is an expression (with no-side effect
+ -- Create a call to either Finalize or Deep_Finalize, depending on the
+ -- structure of type Typ. Obj_Ref is an expression (with no side effects
-- and is not required to have been previously analyzed) that references
-- the object to be finalized. Typ is the expected type of Obj_Ref. When
- -- Skip_Self is set, only the components (if any) are finalized.
+ -- Skip_Self is set, only the components (if any) are finalized. Return
+ -- Empty if Finalize or Deep_Finalize is not available, possibly due to
+ -- previous errors.
procedure Make_Finalize_Address_Body (Typ : Entity_Id);
-- Create the body of TSS routine Finalize_Address if Typ is controlled and
@@ -215,11 +218,12 @@
function Make_Init_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id) return Node_Id;
- -- Obj_Ref is an expression with no-side effect (not required to have been
- -- previously analyzed) that references the object to be initialized. Typ
- -- is the expected type of Obj_Ref, which is either a controlled type
- -- (Is_Controlled) or a type with controlled components (Has_Controlled_
- -- Components).
+ -- Create a call to either Initialize or Deep_Initialize, depending on the
+ -- structure of type Typ. Obj_Ref is an expression with no side effects
+ -- (not required to have been previously analyzed) that references the
+ -- object to be initialized. Typ is the expected type of Obj_Ref. Return
+ -- Empty if Initialize or Deep_Initialize is not available, possibly due to
+ -- previous errors.
function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id;
-- Generate an implicit exception handler with an 'others' choice,
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 244356)
+++ exp_util.adb (working copy)
@@ -2943,7 +2943,10 @@
Set_Etype (Obj_Ref, Desig_Typ);
end if;
- Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ);
+ Fin_Call :=
+ Make_Final_Call
+ (Obj_Ref => Obj_Ref,
+ Typ => Desig_Typ);
-- Otherwise finalize the hook. Generate:
