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:
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
-- 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);
-- 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);
return
Make_Call (Loc,
Proc_Id => Adj_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
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);
-
- 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;
+ 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);
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
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,
Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end if;
- -- Generate the block which houses the adjust or finalize call:
-
- -- begin
- -- <adjust or finalize call>
+ if Present (Call) then
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence (E, Get_Current_Excep.all.all);
- -- end if;
- -- end;
+ -- Generate the block which houses the 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;
-
- -- Generate the dimension loops starting from the innermost one
+ -- begin
+ -- <adjust or finalize call>
- -- for Jnn in [reverse] V'Range (Dim) loop
- -- <core loop>
- -- end loop;
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ 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;
- 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))),
+ -- Generate the dimension loops starting from the innermost one
+
+ -- for Jnn in [reverse] V'Range (Dim) loop
+ -- <core loop>
+ -- end loop;
+
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
+
+ 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))),
+
+ Reverse_Present =>
+ Prim = Finalize_Case)),
+
+ Statements => New_List (Core_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- Reverse_Present => Prim = Finalize_Case)),
+ -- Generate the block which contains the core loop, declarations
+ -- of the abort flag, the exception occurrence, the raised flag
+ -- and the conditional raise:
- Statements => New_List (Core_Loop),
- End_Label => Empty);
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Dim := Dim - 1;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- Generate the block which contains the core loop, the declarations
- -- of the abort flag, the exception occurrence, the raised flag and
- -- the conditional raise:
+ -- begin
+ -- <core loop>
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ Stmts := New_List (Core_Loop);
- -- begin
- -- <core loop>
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ end if;
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
- -- end;
+ Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- Stmts := New_List (Core_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_]Adjust or [Deep_]Finalize primitive to call.
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
+ 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;
---------------------------------
---------------------------------
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);
-
- 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;
+ 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);
- 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
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;
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 --
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.
-- 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;
-
- -- This is the core of the loop, the dimension iterators are added
- -- one by one in reverse.
-
- 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)),
-
- 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)))),
-
- Else_Statements => New_List (Fin_Stmt));
-
- -- Generate all finalization loops starting from the innermost
- -- dimension.
+ Fin_Stmt := Build_Finalization_Call;
- -- for Fnn in reverse V'Range (Dim) loop
- -- <final loop>
- -- end loop;
+ 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;
- F := Last (Final_List);
- Dim := Num_Dims;
- while Present (F) and then Dim > 0 loop
- Loop_Id := F;
- Prev (F);
- Remove (Loop_Id);
+ -- This is the core of the loop, the dimension iterators are added
+ -- one by one in reverse.
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))),
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+
+ 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)))),
+
+ Else_Statements => New_List (Fin_Stmt));
+
+ -- Generate all finalization loops starting from the innermost
+ -- dimension.
+
+ -- for Fnn in reverse V'Range (Dim) loop
+ -- <final loop>
+ -- end loop;
+
+ F := Last (Final_List);
+ Dim := Num_Dims;
+ while Present (F) and then Dim > 0 loop
+ Loop_Id := F;
+ Prev (F);
+ Remove (Loop_Id);
+
+ 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))),
+
+ Reverse_Present => True)),
+
+ Statements => New_List (Final_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- Reverse_Present => True)),
+ -- Generate the block which contains the finalization loops, the
+ -- declarations of the abort flag, the exception occurrence, the
+ -- raised flag and the conditional raise.
- Statements => New_List (Final_Loop),
- End_Label => Empty);
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Dim := Dim - 1;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- Generate the block which contains the finalization loops, the
- -- declarations of the abort flag, the exception occurrence, the
- -- raised flag and the conditional raise.
+ -- begin
+ -- Counter :=
+ -- V'Length (1) *
+ -- ...
+ -- V'Length (N) - Counter;
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- <final loop>
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
- -- begin
- -- Counter :=
- -- V'Length (1) *
- -- ...
- -- V'Length (N) - Counter;
+ -- raise;
+ -- end;
- -- <final loop>
+ Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ Append_To (Stmts, Make_Raise_Statement (Loc));
+ end if;
- -- raise;
- -- end;
+ Final_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- Stmts := New_List (Build_Counter_Assignment, Final_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_]Finalize primitive to call.
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
- Append_To (Stmts, Make_Raise_Statement (Loc));
+ 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.
-- <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)))));
-
- 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))));
-
- -- Generate all initialization loops starting from the innermost
- -- dimension.
-
- -- for Jnn in V'Range (Dim) loop
- -- <init loop>
- -- end loop;
-
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ Init_Call := Build_Initialization_Call;
+ if Present (Init_Call) then
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))))),
-
- Statements => New_List (Init_Loop),
- End_Label => Empty);
+ 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)))));
- Dim := Dim - 1;
- end loop;
+ 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))));
+
+ -- Generate all initialization loops starting from the innermost
+ -- dimension.
+
+ -- for Jnn in V'Range (Dim) loop
+ -- <init loop>
+ -- end loop;
+
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
+
+ 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))))),
+
+ Statements => New_List (Init_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- -- Generate the block which contains the counter variable and the
- -- initialization loops.
+ -- Generate the block which contains the counter variable and the
+ -- initialization loops.
- -- declare
- -- Counter : Integer := 0;
- -- begin
- -- <init loop>
- -- end;
+ -- declare
+ -- Counter : Integer := 0;
+ -- begin
+ -- <init loop>
+ -- end;
- return
- New_List (
- Make_Block_Statement (Loc,
+ Init_Block :=
+ Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
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;
-----------------------
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;
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
----------------------------------
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
-- end if;
-- end;
- Adj_Stmt :=
+ Adj_Call :=
Make_Adjust_Call (
Obj_Ref =>
Make_Selected_Component (Loc,
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))));
- end if;
+ -- 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_Stmt);
+ Append_To (Stmts, Adj_Call);
+ end if;
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
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;
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
-- end if;
-- end;
- Fin_Stmt :=
+ Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Make_Selected_Component (Loc,
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))));
- end if;
+ -- 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_Stmt);
+ Append_To (Stmts, Fin_Call);
+ end if;
end Process_Component_For_Finalize;
-- Start of processing for Process_Component_List_For_Finalize
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))
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));
-- 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))
-- 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);
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);
return
Make_Call (Loc,
Proc_Id => Fin_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
---------------------------------
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
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),
-- Generate:
-- Dnn : constant Storage_Offset :=
- -- Desg_Typ'Descriptor_Size / Storage_Unit;
+ -- Desig_Typ'Descriptor_Size / Storage_Unit;
Dope_Id := Make_Temporary (Loc, 'D');
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))));
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;
-------------------------------------
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))
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;
- Set_Assignment_OK (Ref);
-
Utyp := Underlying_Type (Base_Type (Utyp));
+ Set_Assignment_OK (Ref);
-- Deal with untagged derivation of private views
-- 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
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;
projects / platform / upstream / gcc.git / commitdiff