then
pragma Assert (not Is_Thunk (Current_Scope));
Expand_Cleanup_Actions (Parent (N));
-
- else
- Set_First_Real_Statement (N, First (Statements (N)));
end if;
end Expand_N_Handled_Sequence_Of_Statements;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
pragma Assert (Present (Param));
pragma Assert (Present (Conc_Typ));
- -- Historical note: In earlier versions of GNAT, there was code
- -- at this point to generate stuff to service entry queues. It is
- -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
-
Build_Protected_Subprogram_Call_Cleanup
(Specification (N), Conc_Typ, Loc, Stmts);
end;
-- In the case where the last construct to contain a controlled
-- object is either a nested package, an instantiation or a
-- freeze node, the body must be inserted directly after the
- -- construct.
+ -- construct, except if the insertion point is already placed
+ -- after the construct, typically in the statement list.
if Nkind (Last_Top_Level_Ctrl_Construct) in
N_Freeze_Entity | N_Package_Declaration | N_Package_Body
+ and then not
+ (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls
+ and then Present (Stmts)
+ and then List_Containing (Finalizer_Insert_Nod) = Stmts)
then
Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
end if;
-- template and not the actually instantiation
-- (which is generated too late for us to process
-- it), so there is no need to update in particular
- -- to update Last_Top_Level_Ctrl_Construct here.
+ -- Last_Top_Level_Ctrl_Construct here.
if Counter_Val > Old_Counter_Val then
Counter_Val := Old_Counter_Val;
--------------------------
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
- Is_Protected_Subp_Body : constant Boolean :=
- Nkind (N) = N_Subprogram_Body
- and then Is_Protected_Subprogram_Body (N);
- -- Determine whether N denotes the protected version of a subprogram
- -- which belongs to a protected type.
-
- Loc : constant Source_Ptr := Sloc (N);
- HSS : Node_Id := Handled_Statement_Sequence (N);
-
begin
-- Do not perform this expansion in SPARK mode because we do not create
-- finalizers in the first place.
-- end;
-- end Prot_SubpP;
- if Is_Protected_Subp_Body then
- HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
- end if;
-
- pragma Assert (No (At_End_Proc (HSS)));
- Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
-
- -- Attach reference to finalizer to tree, for LLVM use
-
- Set_Parent (At_End_Proc (HSS), HSS);
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
- Analyze (At_End_Proc (HSS));
- Expand_At_End_Handler (HSS, Empty);
+ Is_Protected_Subp_Body : constant Boolean :=
+ Nkind (N) = N_Subprogram_Body
+ and then Is_Protected_Subprogram_Body (N);
+ -- True if N is the protected version of a subprogram that belongs to
+ -- a protected type.
+
+ HSS : constant Node_Id :=
+ (if Is_Protected_Subp_Body
+ then Handled_Statement_Sequence
+ (Last (Statements (Handled_Statement_Sequence (N))))
+ else Handled_Statement_Sequence (N));
+
+ -- We attach the At_End_Proc to the HSS if this is an accept
+ -- statement or extended return statement. Also in the case of
+ -- a protected subprogram, because if Service_Entries raises an
+ -- exception, we do not lock the PO, so we also do not want to
+ -- unlock it.
+
+ Use_HSS : constant Boolean :=
+ Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement
+ or else Is_Protected_Subp_Body;
+
+ At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N);
+ begin
+ pragma Assert (No (At_End_Proc (At_End_Proc_Bearer)));
+ Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc));
+ -- Attach reference to finalizer to tree, for LLVM use
+ Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer);
+ Analyze (At_End_Proc (At_End_Proc_Bearer));
+ Expand_At_End_Handler (At_End_Proc_Bearer, Empty);
+ end;
end Build_Finalizer_Call;
---------------------
Nkind (N) = N_Block_Statement
and then Present (Cleanup_Actions (N));
- Has_Postcondition : constant Boolean :=
- Nkind (N) = N_Subprogram_Body
- and then Present
- (Postconditions_Proc
- (Unique_Defining_Entity (N)));
-
Actions_Required : constant Boolean :=
Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
or else Needs_Sec_Stack_Mark
or else Needs_Custom_Cleanup;
- HSS : Node_Id := Handled_Statement_Sequence (N);
Loc : Source_Ptr;
Cln : List_Id;
- procedure Wrap_HSS_In_Block;
- -- Move HSS inside a new block along with the original exception
- -- handlers. Make the newly generated block the sole statement of HSS.
-
- -----------------------
- -- Wrap_HSS_In_Block --
- -----------------------
-
- procedure Wrap_HSS_In_Block is
- Block : constant Node_Id :=
- Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
- Block_Id : constant Entity_Id :=
- New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
- End_Lab : constant Node_Id := End_Label (HSS);
- -- Preserve end label to provide proper cross-reference information
-
- begin
- Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
- Set_Etype (Block_Id, Standard_Void_Type);
- Set_Block_Node (Block_Id, Identifier (Block));
-
- -- Signal the finalization machinery that this particular block
- -- contains the original context.
-
- Set_Is_Finalization_Wrapper (Block);
-
- HSS := Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Block),
- End_Label => End_Lab);
- Set_First_Real_Statement (HSS, Block);
- Set_Handled_Statement_Sequence (N, HSS);
-
- if Nkind (N) = N_Subprogram_Body then
- Set_Has_Nested_Block_With_Handler (Scop);
- end if;
- end Wrap_HSS_In_Block;
-
-- Start of processing for Expand_Cleanup_Actions
begin
Cln := No_List;
end if;
- declare
- Decls : List_Id := Declarations (N);
- Fin_Id : Entity_Id;
- Mark : Entity_Id := Empty;
- New_Decls : List_Id;
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List);
+ end if;
+ declare
+ Decls : constant List_Id := Declarations (N);
+ Fin_Id : Entity_Id;
+ Mark : Entity_Id := Empty;
begin
-- If we are generating expanded code for debugging purposes, use the
-- Sloc of the point of insertion for the cleanup code. The Sloc will
Establish_Task_Master (N);
end if;
- New_Decls := New_List;
-
-- If secondary stack is in use, generate:
--
-- Mnn : constant Mark_Id := SS_Mark;
if Needs_Sec_Stack_Mark then
+ Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks
Mark := Make_Temporary (Loc, 'M');
- Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
- Set_Uses_Sec_Stack (Scop, False);
- end if;
-
- -- If exception handlers are present in a non-subprogram
- -- construct, wrap the sequence of statements in a block.
- -- Otherwise, code can be moved so that the wrong handlers
- -- apply. It is important not to do this for function bodies,
- -- because otherwise transient finalizable objects created
- -- by a return statement get finalized too late. It is harmless
- -- not to do this for procedures.
-
- if Present (Exception_Handlers (HSS))
- and then Nkind (N) /= N_Subprogram_Body
- then
- Wrap_HSS_In_Block;
-
- -- Ensure that the First_Real_Statement field is set
-
- elsif No (First_Real_Statement (HSS)) then
- Set_First_Real_Statement (HSS, First (Statements (HSS)));
- end if;
-
- -- Do not move the Activation_Chain declaration in the context of
- -- task allocation blocks. Task allocation blocks use _chain in their
- -- cleanup handlers and gigi complains if it is declared in the
- -- sequence of statements of the scope that declares the handler.
-
- if Is_Task_Allocation then
declare
- Chain_Decl : constant N_Object_Declaration_Id :=
- Parent (Activation_Chain_Entity (N));
- pragma Assert (List_Containing (Chain_Decl) = Decls);
+ Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark);
begin
- Remove (Chain_Decl);
- Prepend_To (New_Decls, Chain_Decl);
+ Prepend_To (Decls, Mark_Call);
+ Analyze (Mark_Call);
end;
end if;
- -- Move the _postconditions subprogram declaration and its associated
- -- objects into the declarations section so that it is callable
- -- within _postconditions.
-
- if Has_Postcondition then
- declare
- Decl : Node_Id;
- Prev_Decl : Node_Id;
-
- begin
- Decl :=
- Prev (Subprogram_Body
- (Postconditions_Proc (Current_Subprogram)));
- while Present (Decl) loop
- Prev_Decl := Prev (Decl);
-
- Remove (Decl);
- Prepend_To (New_Decls, Decl);
-
- exit when Nkind (Decl) = N_Subprogram_Declaration
- and then Chars (Corresponding_Body (Decl))
- = Name_uPostconditions;
-
- Decl := Prev_Decl;
- end loop;
- end;
- end if;
-
- -- Ensure the presence of a declaration list in order to successfully
- -- append all original statements to it.
-
- if No (Decls) then
- Set_Declarations (N, New_List);
- Decls := Declarations (N);
- end if;
-
- -- Move the declarations into the sequence of statements in order to
- -- have them protected by the At_End handler. It may seem weird to
- -- put declarations in the sequence of statement but in fact nothing
- -- forbids that at the tree level.
-
- Append_List_To (Decls, Statements (HSS));
- Set_Statements (HSS, Decls);
-
- -- Reset the Sloc of the handled statement sequence to properly
- -- reflect the new initial "statement" in the sequence.
-
- Set_Sloc (HSS, Sloc (First (Decls)));
-
- -- The declarations of finalizer spec and auxiliary variables replace
- -- the old declarations that have been moved inward.
-
- Set_Declarations (N, New_Decls);
- Analyze_Declarations (New_Decls);
-
-- Generate finalization calls for all controlled objects appearing
-- in the statements of N. Add context specific cleanup for various
-- constructs.
(N => N,
Clean_Stmts => Build_Cleanup_Statements (N, Cln),
Mark_Id => Mark,
- Top_Decls => New_Decls,
+ Top_Decls => Decls,
Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
or else Is_Master,
Fin_Id => Fin_Id);
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Loop_Copy)));
- Set_First_Real_Statement
- (Handled_Statement_Sequence (Local_Body), Loop_Copy);
-
Rewrite (Loop_Stmt, Local_Body);
Analyze (Loop_Stmt);
-- Establish link between subprogram body and source entry body
Set_Corresponding_Entry_Body (Proc_Body, N);
+ Set_At_End_Proc (Proc_Body, At_End_Proc (N));
Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
return Proc_Body;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
- Exc_Safe : constant Boolean := not Might_Raise (N);
- -- True if N cannot raise an exception
+ Might_Raise : constant Boolean := Sem_Util.Might_Raise (N);
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : constant Node_Id := Specification (N);
-- for use by the protected version built below.
if Nkind (Op_Spec) = N_Function_Specification then
- if Exc_Safe then
+ if Might_Raise then
+ Unprot_Call :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
+ Parameter_Associations => Uactuals));
+
+ else
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
Return_Stmt :=
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (R, Loc));
-
- else
- Unprot_Call :=
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Identifier (Loc,
- Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
- Parameter_Associations => Uactuals));
end if;
if Has_Aspect (Pid, Aspect_Exclusive_Functions)
-- Wrap call in block that will be covered by an at_end handler
- if not Exc_Safe then
+ if Might_Raise then
Unprot_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Stmts := New_List (Lock_Stmt);
end if;
- if not Exc_Safe then
+ if Might_Raise then
Append (Unprot_Call, Stmts);
else
if Nkind (Op_Spec) = N_Function_Specification then
Append (Unprot_Call, Stmts);
end if;
- -- Historical note: Previously, call to the cleanup was inserted
- -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
- -- which is also shared by the 'not Exc_Safe' path.
-
Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
if Nkind (Op_Spec) = N_Function_Specification then
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-- Mark this subprogram as a protected subprogram body so that the
- -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
- -- path as otherwise the cleanup has already been inserted.
+ -- cleanup will be inserted. This is done only in the Might_Raise
+ -- case because otherwise the cleanup has already been inserted.
- if not Exc_Safe then
+ if Might_Raise then
Set_Is_Protected_Subprogram_Body (Sub_Body);
end if;
Specification =>
Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
Declarations => Decls,
- Handled_Statement_Sequence => Handled_Statement_Sequence (N));
+ Handled_Statement_Sequence => Handled_Statement_Sequence (N),
+ At_End_Proc => At_End_Proc (N));
end Build_Unprotected_Subprogram_Body;
----------------------------
else
Transient_Blk :=
- First_Real_Statement (Handled_Statement_Sequence (Blk));
+ First (Statements (Handled_Statement_Sequence (Blk)));
if Present (Transient_Blk)
and then Nkind (Transient_Blk) = N_Block_Statement
if Abort_Allowed then
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
- Insert_Before
- (First (Statements (Handled_Statement_Sequence (N))), Call);
+ Prepend (Call, Declarations (N));
Analyze (Call);
end if;
- -- The statement part has already been protected with an at_end and
- -- cleanup actions. The call to Complete_Activation must be placed
- -- at the head of the sequence of statements of that block. The
- -- declarations have been merged in this sequence of statements but
- -- the first real statement is accessible from the First_Real_Statement
- -- field (which was set for exactly this purpose).
+ -- Place call to Complete_Activation at the head of the statement list.
if Restricted_Profile then
Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
end if;
Insert_Before
- (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
+ (First (Statements (Handled_Statement_Sequence (N))), Call);
Analyze (Call);
New_N :=
Declarations => Declarations (N),
Handled_Statement_Sequence => Handled_Statement_Sequence (N));
Set_Is_Task_Body_Procedure (New_N);
+ Set_At_End_Proc (New_N, At_End_Proc (N));
-- If the task contains generic instantiations, cleanup actions are
-- delayed until after instantiation. Transfer the activation chain to
static enum gimplify_status gnat_gimplify_stmt (tree *);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
-static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
+static void process_decls (List_Id, List_Id, bool, bool);
static tree emit_check (tree, tree, int, Node_Id);
static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
return build1 (RETURN_EXPR, void_type_node, result_expr);
}
+/* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an
+ N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node.
+
+ To invoked the GCC mechanism, we call add_cleanup and when we leave the
+ group, end_stmt_group will create the TRY_FINALLY_EXPR construct. */
+
+static void
+At_End_Proc_to_gnu (Node_Id gnat_node)
+{
+ tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
+
+ /* When not optimizing, disable inlining of finalizers as this can
+ create a more complex CFG in the parent function. */
+ if (!optimize || optimize_debug)
+ DECL_DECLARED_INLINE_P (proc_decl) = 0;
+
+ /* If there is no end label attached, we use the location of the At_End
+ procedure because Expand_Cleanup_Actions might reset the location of
+ the enclosing construct to that of an inner statement. */
+ add_cleanup (build_call_n_expr (proc_decl, 0),
+ Present (End_Label (gnat_node))
+ ? End_Label (gnat_node) : At_End_Proc (gnat_node));
+}
+
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */
static void
gnat_pushlevel ();
/* First translate the declarations of the subprogram. */
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
/* Then generate the code of the subprogram itself. A return statement will
be present and any Out parameters will be handled there. */
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+ /* Process the At_End_Proc, if any. */
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
+
gnat_poplevel ();
tree gnu_result = end_stmt_group ();
Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
{
/* If just annotating, ignore all EH and cleanups. */
- const bool gcc_eh
+ const bool eh
= !type_annotate_only && Present (Exception_Handlers (gnat_node));
const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
- const bool binding_for_block = (at_end || gcc_eh);
- tree gnu_inner_block; /* The statement(s) for the block itself. */
tree gnu_result;
Node_Id gnat_temp;
- /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes.
- To call the GCC mechanism, we call add_cleanup, and when we leave the
- binding, end_stmt_group will create the TRY_FINALLY_EXPR construct.
+ /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and
+ is exposed through the TRY_CATCH_EXPR construct that we build manually.
??? The region level calls down there have been specifically put in place
for a ZCX context and currently the order in which things are emitted
(region/handlers) is different from the SJLJ case. Instead of putting
other calls with different conditions at other places for the SJLJ case,
it seems cleaner to reorder things for the SJLJ case and generalize the
- condition to make it not ZCX specific.
+ condition to make it not ZCX specific. */
- If there are any exceptions or cleanup processing involved, we need an
- outer statement group and binding level. */
- if (binding_for_block)
- {
- start_stmt_group ();
- gnat_pushlevel ();
- }
-
- /* If we are to call a function when exiting this block, add a cleanup
- to the binding level we made above. Note that add_cleanup is FIFO
- so we must register this cleanup after the EH cleanup just above. */
- if (at_end)
- {
- tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
-
- /* When not optimizing, disable inlining of finalizers as this can
- create a more complex CFG in the parent function. */
- if (!optimize || optimize_debug)
- DECL_DECLARED_INLINE_P (proc_decl) = 0;
-
- /* If there is no end label attached, we use the location of the At_End
- procedure because Expand_Cleanup_Actions might reset the location of
- the enclosing construct to that of an inner statement. */
- add_cleanup (build_call_n_expr (proc_decl, 0),
- Present (End_Label (gnat_node))
- ? End_Label (gnat_node) : At_End_Proc (gnat_node));
- }
-
- /* Now build the tree for the declarations and statements inside this
- block. */
+ /* First build the tree for the statements inside the sequence. */
start_stmt_group ();
- if (Present (First_Real_Statement (gnat_node)))
- process_decls (Statements (gnat_node), Empty,
- First_Real_Statement (gnat_node), true, true);
-
- /* Generate code for each statement in the block. */
- for (gnat_temp = (Present (First_Real_Statement (gnat_node))
- ? First_Real_Statement (gnat_node)
- : First (Statements (gnat_node)));
- Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ for (gnat_temp = First (Statements (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
add_stmt (gnat_to_gnu (gnat_temp));
- gnu_inner_block = end_stmt_group ();
+ gnu_result = end_stmt_group ();
- if (gcc_eh)
+ /* Then process the exception handlers, if any. */
+ if (eh)
{
tree gnu_handlers;
location_t locus;
- /* First make a block containing the handlers. */
+ /* First make a group containing the handlers. */
start_stmt_group ();
for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
Present (gnat_temp);
add_stmt (gnat_to_gnu (gnat_temp));
gnu_handlers = end_stmt_group ();
- /* Now make the TRY_CATCH_EXPR for the block. */
- gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
- gnu_inner_block, gnu_handlers);
+ /* Now make the TRY_CATCH_EXPR for the group. */
+ gnu_result
+ = build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers);
+
/* Set a location. We need to find a unique location for the dispatching
code, otherwise we can get coverage or debugging issues. Try with
the location of the end label. */
coverage analysis tools. */
set_expr_location_from_node (gnu_result, gnat_node, true);
}
- else
- gnu_result = gnu_inner_block;
- /* Now close our outer block, if we had to make one. */
- if (binding_for_block)
+ /* Process the At_End_Proc, if any. */
+ if (at_end)
{
+ start_stmt_group ();
add_stmt (gnu_result);
- gnat_poplevel ();
+ At_End_Proc_to_gnu (gnat_node);
gnu_result = end_stmt_group ();
}
}
start_stmt_group ();
- gnat_pushlevel ();
/* Expand a call to the begin_handler hook at the beginning of the
handler, and arrange for a call to the end_handler hook to occur
else
{
start_stmt_group ();
- gnat_pushlevel ();
+
/* CODE: void *EXPRP = __builtin_eh_handler (0); */
tree prop_ptr
= create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
add_stmt_with_node (ecall, gnat_node);
/* CODE: } */
- gnat_poplevel ();
tree eblk = end_stmt_group ();
tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
add_cleanup (ehls, gnat_node);
}
- gnat_poplevel ();
-
gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
return
gnat_pragma = Next (gnat_pragma))
if (Nkind (gnat_pragma) == N_Pragma)
add_stmt (gnat_to_gnu (gnat_pragma));
- process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
+ process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty,
true, true);
/* Process the unit itself. */
{
start_stmt_group ();
gnat_pushlevel ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
gnat_poplevel ();
gnu_result = end_stmt_group ();
}
break;
case N_Package_Specification:
-
start_stmt_group ();
process_decls (Visible_Declarations (gnat_node),
- Private_Declarations (gnat_node), Empty, true, true);
+ Private_Declarations (gnat_node),
+ true, true);
gnu_result = end_stmt_group ();
break;
case N_Package_Body:
-
/* If this is the body of a generic package - do nothing. */
if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
{
}
start_stmt_group ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
-
+ process_decls (Declarations (gnat_node), Empty, true, true);
if (Present (Handled_Statement_Sequence (gnat_node)))
add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
-
+ if (Present (At_End_Proc (gnat_node)))
+ At_End_Proc_to_gnu (gnat_node);
gnu_result = end_stmt_group ();
break;
case N_Task_Body:
/* These nodes should only be present when annotating types. */
gcc_assert (type_annotate_only);
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ process_decls (Declarations (gnat_node), Empty, true, true);
gnu_result = alloc_stmt_list ();
break;
case N_Freeze_Entity:
start_stmt_group ();
process_freeze_entity (gnat_node);
- process_decls (Actions (gnat_node), Empty, Empty, true, true);
+ process_decls (Actions (gnat_node), Empty, true, true);
gnu_result = end_stmt_group ();
break;
we declare a function if there was no spec). The second pass
elaborates the bodies.
- GNAT_END_LIST gives the element in the list past the end. Normally,
- this is Empty, but can be First_Real_Statement for a
- Handled_Sequence_Of_Statements.
-
We make a complete pass through both lists if PASS1P is true, then make
the second pass over both lists if PASS2P is true. The lists usually
correspond to the public and private parts of a package. */
static void
process_decls (List_Id gnat_decls, List_Id gnat_decls2,
- Node_Id gnat_end_list, bool pass1p, bool pass2p)
+ bool pass1p, bool pass2p)
{
List_Id gnat_decl_array[2];
Node_Id gnat_decl;
for (i = 0; i <= 1; i++)
if (Present (gnat_decl_array[i]))
for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ Present (gnat_decl);
+ gnat_decl = Next (gnat_decl))
{
/* For package specs, we recurse inside the declarations,
thus taking the two pass approach inside the boundary. */
== N_Package_Specification)))
process_decls (Visible_Declarations (Specification (gnat_decl)),
Private_Declarations (Specification (gnat_decl)),
- Empty, true, false);
+ true, false);
/* Similarly for any declarations in the actions of a
freeze node. */
else if (Nkind (gnat_decl) == N_Freeze_Entity)
{
process_freeze_entity (gnat_decl);
- process_decls (Actions (gnat_decl), Empty, Empty, true, false);
+ process_decls (Actions (gnat_decl), Empty, true, false);
}
/* Package bodies with freeze nodes get their elaboration deferred
for (i = 0; i <= 1; i++)
if (Present (gnat_decl_array[i]))
for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+ Present (gnat_decl);
+ gnat_decl = Next (gnat_decl))
{
if (Nkind (gnat_decl) == N_Subprogram_Body
|| Nkind (gnat_decl) == N_Subprogram_Body_Stub
== N_Package_Specification)))
process_decls (Visible_Declarations (Specification (gnat_decl)),
Private_Declarations (Specification (gnat_decl)),
- Empty, false, true);
+ false, true);
else if (Nkind (gnat_decl) == N_Freeze_Entity)
- process_decls (Actions (gnat_decl), Empty, Empty, false, true);
+ process_decls (Actions (gnat_decl), Empty, false, true);
else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
add_stmt (gnat_to_gnu (gnat_decl));
First_Inlined_Subprogram,
First_Name,
First_Named_Actual,
- First_Real_Statement,
First_Subtype_Link,
Float_Truncate,
Formal_Type_Definition,
Cc (N_Package_Body, N_Unit_Body,
(Sy (Defining_Unit_Name, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
- Sy (Handled_Statement_Sequence, Node_Id, Default_Empty)));
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty)));
Cc (N_Subprogram_Body, N_Unit_Body,
(Sy (Specification, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
Sy (Bad_Is_Detected, Flag),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Acts_As_Spec, Flag),
Sm (Corresponding_Entry_Body, Node_Id),
(Sy (Defining_Identifier, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Is_Task_Master, Flag)));
Sy (Has_Created_Identifier, Flag),
Sy (Is_Asynchronous_Call_Block, Flag),
Sy (Is_Task_Allocation_Block, Flag),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id),
Sm (Cleanup_Actions, List_Id),
Sm (Exception_Junk, Flag),
Sy (Entry_Body_Formal_Part, Node_Id),
Sy (Declarations, List_Id, Default_No_List),
Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
Sm (Activation_Chain_Entity, Node_Id)));
Cc (N_Entry_Call_Alternative, Node_Kind,
(Sy (Statements, List_Id, Default_Empty_List),
Sy (End_Label, Node_Id, Default_Empty),
Sy (Exception_Handlers, List_Id, Default_No_List),
- Sy (At_End_Proc, Node_Id, Default_Empty),
- Sm (First_Real_Statement, Node_Id)));
+ Sy (At_End_Proc, Node_Id, Default_Empty)));
Cc (N_Index_Or_Discriminant_Constraint, Node_Kind,
(Sy (Constraints, List_Id)));
Decl : Node_Id;
begin
- if No (E_Body) then -- imported subprogram
+ if No (E_Body) then -- imported subprogram
return False;
else
Decl := First (Declarations (E_Body));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration
+ and then Comes_From_Source (Decl)
and then Present (Init_Proc (Defining_Identifier (Decl)))
then
return True;
-- Lock a protected object for write access. Upon return, the caller owns
-- the lock to this object, and no other call to Lock or Lock_Read_Only
-- with the same argument will return until the corresponding call to
- -- Unlock has been made by the caller. Program_Error is raised in case of
- -- ceiling violation.
+ -- Unlock has been made by the caller. Program_Error is raised in case
+ -- of ceiling violation, or if the protected object has already been
+ -- finalized, or if Detect_Blocking is true and the protected object
+ -- is already locked by the current task. In the Program_Error cases,
+ -- the object is not locked.
procedure Lock_Entries_With_Status
(Object : Protection_Entries_Access;
Ceiling_Violation : out Boolean);
-- Same as above, but return the ceiling violation status instead of
- -- raising Program_Error.
+ -- raising Program_Error. This raises Program_Error in the other
+ -- cases mentioned for Lock_Entries. In the Program_Error cases,
+ -- the object is not locked.
procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access);
-- Lock a protected object for read access. Upon return, the caller owns
-- Analysis implements the bulk of semantic analysis such as
-- name analysis and type resolution for declarations,
--- instructions and expressions. The main routine
+-- statements, and expressions. The main routine
-- driving this process is procedure Analyze given below.
-- This analysis phase is really a bottom up pass that is
-- achieved during the recursive traversal performed by the
-- completed during analysis (because of overloading
-- ambiguities). Specifically, after completing the bottom
-- up pass carried out during analysis for expressions, the
--- Resolve routine (see the spec of sem_res for more info)
+-- Resolve routine (see the spec of Sem_Res for more info)
-- is called to perform a top down resolution with
-- recursive calls to itself to resolve operands.
--- Expansion if we are not generating code this phase is a no-op.
+-- Expansion If we are not generating code this phase is a no-op.
-- Otherwise this phase expands, i.e. transforms, original
--- declaration, expressions or instructions into simpler
--- structures that can be handled by the back-end. This
--- phase is also in charge of generating code which is
--- implicit in the original source (for instance for
--- default initializations, controlled types, etc.)
--- There are two separate instances where expansion is
+-- source constructs into simpler constructs that can be
+-- handled by the back-end. This phase is also in charge of
+-- generating code which is implicit in the original source
+-- (for instance for default initializations, controlled types,
+-- etc.) There are two separate instances where expansion is
-- invoked. For declarations and instructions, expansion is
--- invoked just after analysis since no resolution needs
--- to be performed. For expressions, expansion is done just
--- after resolution. In both cases expansion is done from the
--- bottom up just before the end of Analyze for instructions
--- and declarations or the call to Resolve for expressions.
--- The main routine driving expansion is Expand.
--- See the spec of Expander for more details.
+-- invoked just after analysis since no resolution needs to be
+-- performed. For expressions, expansion is done just after
+-- resolution. In both cases expansion is done from the bottom
+-- up just before the end of Analyze for instructions and
+-- declarations or the call to Resolve for expressions. The
+-- main routine driving expansion is Expand. See the spec of
+-- Expander for more details.
-- To summarize, in normal code generation mode we recursively traverse the
-- abstract syntax tree top-down performing semantic analysis bottom
-- pragmas that appear with subprogram specifications rather than in the body.
-- Collectively we call these Spec_Expressions. The routine that performs the
--- special analysis is called Analyze_Spec_Expression.
+-- special analysis is called Preanalyze_Spec_Expression.
-- Expansion has to be deferred since you can't generate code for expressions
-- that reference types that have not been frozen yet. As an example, consider
-- of the expression cannot be obtained at the point of declaration, only at
-- the point of use.
--- Generally our model is to combine analysis resolution and expansion, but
+-- Generally our model is to combine analysis, resolution, and expansion, but
-- this is the one case where this model falls down. Here is how we patch
-- it up without causing too much distortion to our basic model.
-- children is performed before expansion of the parent does not work if the
-- code generated for the children by the expander needs to be evaluated
-- repeatedly (for instance in the above aggregate "new Thing (Function_Call)"
--- needs to be called 100 times.)
+-- needs to be called 100 times).
-- The reason this mechanism does not work is that the expanded code for the
-- children is typically inserted above the parent and thus when the parent
end loop;
-- Determine whether the null procedure may be a completion of a generic
- -- suprogram, in which case we use the new null body as the completion
+ -- subprogram, in which case we use the new null body as the completion
-- and set minimal semantic information on the original declaration,
-- which is rewritten as a null statement.
-- we have a special test to set X as apparently assigned to suppress
-- the warning.
- -- If X above is controlled, we need to use First_Real_Statement to skip
- -- generated finalization-related code. Otherwise (First_Real_Statement
- -- is Empty), we just get the first statement.
-
declare
- Stm : Node_Id := First_Real_Statement (HSS);
+ Stm : Node_Id := First (Statements (HSS));
begin
- if No (Stm) then
- Stm := First (Statements (HSS));
- end if;
-
-- Skip call markers installed by the ABE mechanism, labels, and
-- Push_xxx_Error_Label to find the first real statement.
-- If the pragma comes from an aspect specification, there
-- must be an Import aspect specified as well. In the rare
- -- case where Import is set to False, the suprogram needs to
- -- have a local completion.
+ -- case where Import is set to False, the subprogram needs
+ -- to have a local completion.
declare
Imp_Aspect : constant Node_Id :=
end loop;
-- If entity in not in current scope it may be the enclosing
- -- suprogram body to which the aspect applies.
+ -- subprogram body to which the aspect applies.
if not Found then
if Entity (Id) = Current_Scope
| N_Function_Call
| N_Raise_Statement
| N_Raise_xxx_Error
+ | N_Raise_Expression
then
Result := True;
return Abandon;
pragma Inline (Update_CFS_Sloc);
-- Update the Comes_From_Source and Sloc attributes of node or entity N
- procedure Update_First_Real_Statement
- (Old_HSS : Node_Id;
- New_HSS : Node_Id);
- pragma Inline (Update_First_Real_Statement);
- -- Update semantic attribute First_Real_Statement of handled sequence of
- -- statements New_HSS based on handled sequence of statements Old_HSS.
-
procedure Update_Named_Associations
(Old_Call : Node_Id;
New_Call : Node_Id);
Set_Renamed_Object_Of_Possibly_Void
(Defining_Entity (Result), Name (Result));
- -- Update the First_Real_Statement attribute of a replicated
- -- handled sequence of statements.
-
- elsif Nkind (N) = N_Handled_Sequence_Of_Statements then
- Update_First_Real_Statement
- (Old_HSS => N,
- New_HSS => Result);
-
-- Update the Chars attribute of identifiers
elsif Nkind (N) = N_Identifier then
end if;
end Update_CFS_Sloc;
- ---------------------------------
- -- Update_First_Real_Statement --
- ---------------------------------
-
- procedure Update_First_Real_Statement
- (Old_HSS : Node_Id;
- New_HSS : Node_Id)
- is
- Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS);
-
- New_Stmt : Node_Id;
- Old_Stmt : Node_Id;
-
- begin
- -- Recreate the First_Real_Statement attribute of a handled sequence
- -- of statements by traversing the statement lists of both sequences
- -- in parallel.
-
- if Present (Old_First_Stmt) then
- New_Stmt := First (Statements (New_HSS));
- Old_Stmt := First (Statements (Old_HSS));
- while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop
- Next (New_Stmt);
- Next (Old_Stmt);
- end loop;
-
- pragma Assert (Present (New_Stmt));
- pragma Assert (Present (Old_Stmt));
-
- Set_First_Real_Statement (New_HSS, New_Stmt);
- end if;
- end Update_First_Real_Statement;
-
-------------------------------
-- Update_Named_Associations --
-------------------------------
-- * Semantic fields of entities such as Etype and Scope must be
-- updated to reference the proper replicated entities.
- -- * Semantic fields of nodes such as First_Real_Statement must be
- -- updated to reference the proper replicated nodes.
+ -- * Some semantic fields of nodes must be updated to reference
+ -- the proper replicated nodes.
-- Finally, quantified expressions contain an implicit declaration for
-- the bound variable. Given that quantified expressions appearing
-- fields are recreated after the replication takes place.
--
-- First_Named_Actual
- -- First_Real_Statement
-- Next_Named_Actual
--
-- If applicable, the Etype field (if any) is updated to refer to a
-- Miscellaneous Tree Access Subprograms --
-------------------------------------------
+ function First_Real_Statement -- ????
+ (Ignored : N_Handled_Sequence_Of_Statements_Id) return Node_Id is (Empty);
+ -- The First_Real_Statement field is going away, but it is referenced in
+ -- codepeer and gnat-llvm. This is a temporary version, always returning
+ -- Empty, to ease the transition.
+
function End_Location (N : Node_Id) return Source_Ptr;
-- N is an N_If_Statement or N_Case_Statement node, and this function
-- returns the location of the IF token in the END IF sequence by
-- required for the corresponding reference or modification.
-- At_End_Proc
- -- This field is present in an N_Handled_Sequence_Of_Statements node.
+ -- This field is present in N_Handled_Sequence_Of_Statements,
+ -- N_Package_Body, N_Subprogram_Body, N_Task_Body, N_Block_Statement,
+ -- and N_Entry_Body.
-- It contains an identifier reference for the cleanup procedure to be
- -- called. See description of this node for further details.
+ -- called. See description of N_Handled_Sequence_Of_Statements node
+ -- for further details.
-- Backwards_OK
-- A flag present in the N_Assignment_Statement node. It is used only
-- named associations). Note: this field points to the explicit actual
-- parameter itself, not the N_Parameter_Association node (its parent).
- -- First_Real_Statement
- -- Present in N_Handled_Sequence_Of_Statements node. Normally set to
- -- Empty. Used only when declarations are moved into the statement part
- -- of a construct as a result of wrapping an AT END handler that is
- -- required to cover the declarations. In this case, this field is used
- -- to remember the location in the statements list of the first real
- -- statement, i.e. the statement that used to be first in the statement
- -- list before the declarations were prepended.
-
-- First_Subtype_Link
-- Present in N_Freeze_Entity node for an anonymous base type that is
-- implicitly created by the declaration of a first subtype. It points
-- Is_Finalization_Wrapper
-- Is_Initialization_Block
-- Is_Task_Master
+ -- At_End_Proc (set to Empty if no clean up procedure)
-------------------------
-- 5.7 Exit Statement --
-- Handled_Statement_Sequence (set to Empty if no HSS present)
-- Corresponding_Spec
-- Was_Originally_Stub
+ -- At_End_Proc (set to Empty if no clean up procedure)
-- Note: if a source level package does not contain a handled sequence
-- of statements, then the parser supplies a dummy one with a null
-- Declarations
-- Handled_Statement_Sequence
-- Activation_Chain_Entity
+ -- At_End_Proc (set to Empty if no clean up procedure)
-----------------------------------
-- 9.5.2 Entry Body Formal Part --
-- Corresponding_Spec_Of_Stub
-- Library_Unit points to the subunit
-- Corresponding_Body
+ -- At_End_Proc (set to Empty if no clean up procedure)
-------------------------------
-- 10.1.3 Package Body Stub --
-- Corresponding_Spec_Of_Stub
-- Library_Unit points to the subunit
-- Corresponding_Body
+ -- At_End_Proc (set to Empty if no clean up procedure)
---------------------------------
-- 10.1.3 Protected Body Stub --
-- declarations. The big difference is that the cleanup actions occur
-- on either a normal or an abnormal exit from the statement sequence.
+ -- At_End_Proc is also a field of various nodes that can contain
+ -- both Declarations and Handled_Statement_Sequence, such as subprogram
+ -- bodies and block statements. In that case, the At_End_Proc
+ -- protects the Declarations as well as the Handled_Statement_Sequence.
+
-- Note: the list of Exception_Handlers can contain pragmas as well
-- as actual handlers. In practice these pragmas can only occur at
-- the start of the list, since any pragmas occurring later on will
-- End_Label (set to Empty if expander generated)
-- Exception_Handlers (set to No_List if none present)
-- At_End_Proc (set to Empty if no clean up procedure)
- -- First_Real_Statement
-- Note: A Handled_Sequence_Of_Statements can contain both
-- Exception_Handlers and an At_End_Proc.
-- For the case of Semicolon False, no semicolon is removed or output, and
-- all the aspects are printed on a single line.
+ procedure Sprint_At_End_Proc (Node : Node_Id);
+ -- Print At_End_Proc attribute if present
+
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
end if;
end Sprint_Aspect_Specifications;
+ ------------------------
+ -- Sprint_At_End_Proc --
+ ------------------------
+
+ procedure Sprint_At_End_Proc (Node : Node_Id) is
+ begin
+ if Present (At_End_Proc (Node)) then
+ Write_Indent_Str ("at end");
+ Indent_Begin;
+ Write_Indent;
+ Sprint_Node (At_End_Proc (Node));
+ Write_Char (';');
+ Indent_End;
+ end if;
+ end Sprint_At_End_Proc;
+
---------------------
-- Sprint_Bar_List --
---------------------
end if;
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Call_Marker =>
null;
Write_Indent_Str ("end ");
Write_Id (Defining_Identifier (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Entry_Body_Formal_Part =>
if Present (Entry_Index_Specification (Node)) then
Indent_End;
end if;
- if Present (At_End_Proc (Node)) then
- Write_Indent_Str ("at end");
- Indent_Begin;
- Write_Indent;
- Sprint_Node (At_End_Proc (Node));
- Write_Char (';');
- Indent_End;
- end if;
+ Sprint_At_End_Proc (Node);
when N_Identifier =>
Set_Debug_Sloc;
Sprint_End_Label
(Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Package_Body_Stub =>
Write_Indent_Str_Sloc ("package body ");
(Handled_Statement_Sequence (Node),
Defining_Unit_Name (Specification (Node)));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
if Is_List_Member (Node)
and then Present (Next (Node))
Sprint_End_Label
(Handled_Statement_Sequence (Node), Defining_Identifier (Node));
Write_Char (';');
+ Sprint_At_End_Proc (Node);
when N_Task_Body_Stub =>
Write_Indent_Str_Sloc ("task body ");
projects / thirdparty / gcc.git / commitdiff
