1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Prag
; use Exp_Prag
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
49 with Output
; use Output
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
53 with Sinfo
; use Sinfo
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch3
; use Sem_Ch3
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Util
; use Sem_Util
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Ttypes
; use Ttypes
;
66 with Uintp
; use Uintp
;
68 package body Exp_Ch7
is
70 --------------------------------
71 -- Transient Scope Management --
72 --------------------------------
74 -- A transient scope is created when temporary objects are created by the
75 -- compiler. These temporary objects are allocated on the secondary stack
76 -- and the transient scope is responsible for finalizing the object when
77 -- appropriate and reclaiming the memory at the right time. The temporary
78 -- objects are generally the objects allocated to store the result of a
79 -- function returning an unconstrained or a tagged value. Expressions
80 -- needing to be wrapped in a transient scope (functions calls returning
81 -- unconstrained or tagged values) may appear in 3 different contexts which
82 -- lead to 3 different kinds of transient scope expansion:
84 -- 1. In a simple statement (procedure call, assignment, ...). In this
85 -- case the instruction is wrapped into a transient block. See
86 -- Wrap_Transient_Statement for details.
88 -- 2. In an expression of a control structure (test in a IF statement,
89 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
92 -- 3. In a expression of an object_declaration. No wrapping is possible
93 -- here, so the finalization actions, if any, are done right after the
94 -- declaration and the secondary stack deallocation is done in the
95 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
97 -- Note about functions returning tagged types: it has been decided to
98 -- always allocate their result in the secondary stack, even though is not
99 -- absolutely mandatory when the tagged type is constrained because the
100 -- caller knows the size of the returned object and thus could allocate the
101 -- result in the primary stack. An exception to this is when the function
102 -- builds its result in place, as is done for functions with inherently
103 -- limited result types for Ada 2005. In that case, certain callers may
104 -- pass the address of a constrained object as the target object for the
107 -- By allocating tagged results in the secondary stack a number of
108 -- implementation difficulties are avoided:
110 -- - If it is a dispatching function call, the computation of the size of
111 -- the result is possible but complex from the outside.
113 -- - If the returned type is controlled, the assignment of the returned
114 -- value to the anonymous object involves an Adjust, and we have no
115 -- easy way to access the anonymous object created by the back end.
117 -- - If the returned type is class-wide, this is an unconstrained type
120 -- Furthermore, the small loss in efficiency which is the result of this
121 -- decision is not such a big deal because functions returning tagged types
122 -- are not as common in practice compared to functions returning access to
125 --------------------------------------------------
126 -- Transient Blocks and Finalization Management --
127 --------------------------------------------------
129 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
130 -- N is a node which may generate a transient scope. Loop over the parent
131 -- pointers of N until it find the appropriate node to wrap. If it returns
132 -- Empty, it means that no transient scope is needed in this context.
134 procedure Insert_Actions_In_Scope_Around
137 Manage_SS
: Boolean);
138 -- Insert the before-actions kept in the scope stack before N, and the
139 -- after-actions after N, which must be a member of a list. If flag Clean
140 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
141 -- calls to mark and release the secondary stack.
143 function Make_Transient_Block
146 Par
: Node_Id
) return Node_Id
;
147 -- Action is a single statement or object declaration. Par is the proper
148 -- parent of the generated block. Create a transient block whose name is
149 -- the current scope and the only handled statement is Action. If Action
150 -- involves controlled objects or secondary stack usage, the corresponding
151 -- cleanup actions are performed at the end of the block.
153 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
154 -- Set the field Node_To_Be_Wrapped of the current scope
156 -- ??? The entire comment needs to be rewritten
157 -- ??? which entire comment?
159 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
160 -- Shared processing for Store_xxx_Actions_In_Scope
162 -----------------------------
163 -- Finalization Management --
164 -----------------------------
166 -- This part describe how Initialization/Adjustment/Finalization procedures
167 -- are generated and called. Two cases must be considered, types that are
168 -- Controlled (Is_Controlled flag set) and composite types that contain
169 -- controlled components (Has_Controlled_Component flag set). In the first
170 -- case the procedures to call are the user-defined primitive operations
171 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
172 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
173 -- of calling the former procedures on the controlled components.
175 -- For records with Has_Controlled_Component set, a hidden "controller"
176 -- component is inserted. This controller component contains its own
177 -- finalization list on which all controlled components are attached
178 -- creating an indirection on the upper-level Finalization list. This
179 -- technique facilitates the management of objects whose number of
180 -- controlled components changes during execution. This controller
181 -- component is itself controlled and is attached to the upper-level
182 -- finalization chain. Its adjust primitive is in charge of calling adjust
183 -- on the components and adjusting the finalization pointer to match their
184 -- new location (see a-finali.adb).
186 -- It is not possible to use a similar technique for arrays that have
187 -- Has_Controlled_Component set. In this case, deep procedures are
188 -- generated that call initialize/adjust/finalize + attachment or
189 -- detachment on the finalization list for all component.
191 -- Initialize calls: they are generated for declarations or dynamic
192 -- allocations of Controlled objects with no initial value. They are always
193 -- followed by an attachment to the current Finalization Chain. For the
194 -- dynamic allocation case this the chain attached to the scope of the
195 -- access type definition otherwise, this is the chain of the current
198 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
199 -- or dynamic allocations of Controlled objects with an initial value.
200 -- (2) after an assignment. In the first case they are followed by an
201 -- attachment to the final chain, in the second case they are not.
203 -- Finalization Calls: They are generated on (1) scope exit, (2)
204 -- assignments, (3) unchecked deallocations. In case (3) they have to
205 -- be detached from the final chain, in case (2) they must not and in
206 -- case (1) this is not important since we are exiting the scope anyway.
210 -- Type extensions will have a new record controller at each derivation
211 -- level containing controlled components. The record controller for
212 -- the parent/ancestor is attached to the finalization list of the
213 -- extension's record controller (i.e. the parent is like a component
214 -- of the extension).
216 -- For types that are both Is_Controlled and Has_Controlled_Components,
217 -- the record controller and the object itself are handled separately.
218 -- It could seem simpler to attach the object at the end of its record
219 -- controller but this would not tackle view conversions properly.
221 -- A classwide type can always potentially have controlled components
222 -- but the record controller of the corresponding actual type may not
223 -- be known at compile time so the dispatch table contains a special
224 -- field that allows computation of the offset of the record controller
225 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
227 -- Here is a simple example of the expansion of a controlled block :
231 -- Y : Controlled := Init;
237 -- Z : R := (C => X);
247 -- _L : System.FI.Finalizable_Ptr;
249 -- procedure _Clean is
252 -- System.FI.Finalize_List (_L);
260 -- Attach_To_Final_List (_L, Finalizable (X), 1);
261 -- at end: Abort_Undefer;
262 -- Y : Controlled := Init;
264 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
272 -- Deep_Initialize (W, _L, 1);
273 -- at end: Abort_Under;
274 -- Z : R := (C => X);
275 -- Deep_Adjust (Z, _L, 1);
279 -- Deep_Finalize (W, False);
280 -- <save W's final pointers>
282 -- <restore W's final pointers>
283 -- Deep_Adjust (W, _L, 0);
288 type Final_Primitives
is
289 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
290 -- This enumeration type is defined in order to ease sharing code for
291 -- building finalization procedures for composite types.
293 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
294 (Initialize_Case
=> Name_Initialize
,
295 Adjust_Case
=> Name_Adjust
,
296 Finalize_Case
=> Name_Finalize
,
297 Address_Case
=> Name_Finalize_Address
);
298 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
299 (Initialize_Case
=> TSS_Deep_Initialize
,
300 Adjust_Case
=> TSS_Deep_Adjust
,
301 Finalize_Case
=> TSS_Deep_Finalize
,
302 Address_Case
=> TSS_Finalize_Address
);
304 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
305 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
306 -- Has_Controlled_Component set and store them using the TSS mechanism.
308 function Build_Cleanup_Statements
310 Additional_Cleanup
: List_Id
) return List_Id
;
311 -- Create the clean up calls for an asynchronous call block, task master,
312 -- protected subprogram body, task allocation block or task body, or
313 -- additional cleanup actions parked on a transient block. If the context
314 -- does not contain the above constructs, the routine returns an empty
317 procedure Build_Finalizer
319 Clean_Stmts
: List_Id
;
322 Defer_Abort
: Boolean;
323 Fin_Id
: out Entity_Id
);
324 -- N may denote an accept statement, block, entry body, package body,
325 -- package spec, protected body, subprogram body, or a task body. Create
326 -- a procedure which contains finalization calls for all controlled objects
327 -- declared in the declarative or statement region of N. The calls are
328 -- built in reverse order relative to the original declarations. In the
329 -- case of a task body, the routine delays the creation of the finalizer
330 -- until all statements have been moved to the task body procedure.
331 -- Clean_Stmts may contain additional context-dependent code used to abort
332 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
333 -- Mark_Id is the secondary stack used in the current context or Empty if
334 -- missing. Top_Decls is the list on which the declaration of the finalizer
335 -- is attached in the non-package case. Defer_Abort indicates that the
336 -- statements passed in perform actions that require abort to be deferred,
337 -- such as for task termination. Fin_Id is the finalizer declaration
340 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
341 -- N is a construct which contains a handled sequence of statements, Fin_Id
342 -- is the entity of a finalizer. Create an At_End handler which covers the
343 -- statements of N and calls Fin_Id. If the handled statement sequence has
344 -- an exception handler, the statements will be wrapped in a block to avoid
345 -- unwanted interaction with the new At_End handler.
347 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
348 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
349 -- Has_Component_Component set and store them using the TSS mechanism.
351 procedure Check_Visibly_Controlled
352 (Prim
: Final_Primitives
;
354 E
: in out Entity_Id
;
355 Cref
: in out Node_Id
);
356 -- The controlled operation declared for a derived type may not be
357 -- overriding, if the controlled operations of the parent type are hidden,
358 -- for example when the parent is a private type whose full view is
359 -- controlled. For other primitive operations we modify the name of the
360 -- operation to indicate that it is not overriding, but this is not
361 -- possible for Initialize, etc. because they have to be retrievable by
362 -- name. Before generating the proper call to one of these operations we
363 -- check whether Typ is known to be controlled at the point of definition.
364 -- If it is not then we must retrieve the hidden operation of the parent
365 -- and use it instead. This is one case that might be solved more cleanly
366 -- once Overriding pragmas or declarations are in place.
368 function Convert_View
371 Ind
: Pos
:= 1) return Node_Id
;
372 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
373 -- argument being passed to it. Ind indicates which formal of procedure
374 -- Proc we are trying to match. This function will, if necessary, generate
375 -- a conversion between the partial and full view of Arg to match the type
376 -- of the formal of Proc, or force a conversion to the class-wide type in
377 -- the case where the operation is abstract.
379 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
380 -- Given an arbitrary entity, traverse the scope chain looking for the
381 -- first enclosing function. Return Empty if no function was found.
387 Skip_Self
: Boolean := False) return Node_Id
;
388 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
389 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
390 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
391 -- action has an effect on the components only (if any).
393 function Make_Deep_Proc
394 (Prim
: Final_Primitives
;
396 Stmts
: List_Id
) return Node_Id
;
397 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
398 -- Deep_Finalize procedures according to the first parameter, these
399 -- procedures operate on the type Typ. The Stmts parameter gives the body
402 function Make_Deep_Array_Body
403 (Prim
: Final_Primitives
;
404 Typ
: Entity_Id
) return List_Id
;
405 -- This function generates the list of statements for implementing
406 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
407 -- the first parameter, these procedures operate on the array type Typ.
409 function Make_Deep_Record_Body
410 (Prim
: Final_Primitives
;
412 Is_Local
: Boolean := False) return List_Id
;
413 -- This function generates the list of statements for implementing
414 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
415 -- the first parameter, these procedures operate on the record type Typ.
416 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
417 -- whether the inner logic should be dictated by state counters.
419 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
420 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
421 -- Make_Deep_Record_Body. Generate the following statements:
424 -- type Acc_Typ is access all Typ;
425 -- for Acc_Typ'Storage_Size use 0;
427 -- [Deep_]Finalize (Acc_Typ (V).all);
430 ----------------------------
431 -- Build_Array_Deep_Procs --
432 ----------------------------
434 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
438 (Prim
=> Initialize_Case
,
440 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
442 if not Is_Limited_View
(Typ
) then
445 (Prim
=> Adjust_Case
,
447 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
450 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
451 -- suppressed since these routine will not be used.
453 if not Restriction_Active
(No_Finalization
) then
456 (Prim
=> Finalize_Case
,
458 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
460 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
461 -- .NET do not support address arithmetic and unchecked conversions.
463 if VM_Target
= No_VM
then
466 (Prim
=> Address_Case
,
468 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
471 end Build_Array_Deep_Procs
;
473 ------------------------------
474 -- Build_Cleanup_Statements --
475 ------------------------------
477 function Build_Cleanup_Statements
479 Additional_Cleanup
: List_Id
) return List_Id
481 Is_Asynchronous_Call
: constant Boolean :=
482 Nkind
(N
) = N_Block_Statement
483 and then Is_Asynchronous_Call_Block
(N
);
484 Is_Master
: constant Boolean :=
485 Nkind
(N
) /= N_Entry_Body
486 and then Is_Task_Master
(N
);
487 Is_Protected_Body
: constant Boolean :=
488 Nkind
(N
) = N_Subprogram_Body
489 and then Is_Protected_Subprogram_Body
(N
);
490 Is_Task_Allocation
: constant Boolean :=
491 Nkind
(N
) = N_Block_Statement
492 and then Is_Task_Allocation_Block
(N
);
493 Is_Task_Body
: constant Boolean :=
494 Nkind
(Original_Node
(N
)) = N_Task_Body
;
496 Loc
: constant Source_Ptr
:= Sloc
(N
);
497 Stmts
: constant List_Id
:= New_List
;
501 if Restricted_Profile
then
503 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
505 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
509 if Restriction_Active
(No_Task_Hierarchy
) = False then
510 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
513 -- Add statements to unlock the protected object parameter and to
514 -- undefer abort. If the context is a protected procedure and the object
515 -- has entries, call the entry service routine.
517 -- NOTE: The generated code references _object, a parameter to the
520 elsif Is_Protected_Body
then
522 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
523 Conc_Typ
: Entity_Id
;
525 Param_Typ
: Entity_Id
;
528 -- Find the _object parameter representing the protected object
530 Param
:= First
(Parameter_Specifications
(Spec
));
532 Param_Typ
:= Etype
(Parameter_Type
(Param
));
534 if Ekind
(Param_Typ
) = E_Record_Type
then
535 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
538 exit when No
(Param
) or else Present
(Conc_Typ
);
542 pragma Assert
(Present
(Param
));
544 -- Historical note: In earlier versions of GNAT, there was code
545 -- at this point to generate stuff to service entry queues. It is
546 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
548 Build_Protected_Subprogram_Call_Cleanup
549 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
552 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
553 -- tasks. Other unactivated tasks are completed by Complete_Task or
556 -- NOTE: The generated code references _chain, a local object
558 elsif Is_Task_Allocation
then
561 -- Expunge_Unactivated_Tasks (_chain);
563 -- where _chain is the list of tasks created by the allocator but not
564 -- yet activated. This list will be empty unless the block completes
568 Make_Procedure_Call_Statement
(Loc
,
571 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
572 Parameter_Associations
=> New_List
(
573 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
575 -- Attempt to cancel an asynchronous entry call whenever the block which
576 -- contains the abortable part is exited.
578 -- NOTE: The generated code references Cnn, a local object
580 elsif Is_Asynchronous_Call
then
582 Cancel_Param
: constant Entity_Id
:=
583 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
586 -- If it is of type Communication_Block, this must be a protected
587 -- entry call. Generate:
589 -- if Enqueued (Cancel_Param) then
590 -- Cancel_Protected_Entry_Call (Cancel_Param);
593 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
595 Make_If_Statement
(Loc
,
597 Make_Function_Call
(Loc
,
599 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
600 Parameter_Associations
=> New_List
(
601 New_Occurrence_Of
(Cancel_Param
, Loc
))),
603 Then_Statements
=> New_List
(
604 Make_Procedure_Call_Statement
(Loc
,
607 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
608 Parameter_Associations
=> New_List
(
609 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
611 -- Asynchronous delay, generate:
612 -- Cancel_Async_Delay (Cancel_Param);
614 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
616 Make_Procedure_Call_Statement
(Loc
,
618 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
619 Parameter_Associations
=> New_List
(
620 Make_Attribute_Reference
(Loc
,
622 New_Occurrence_Of
(Cancel_Param
, Loc
),
623 Attribute_Name
=> Name_Unchecked_Access
))));
625 -- Task entry call, generate:
626 -- Cancel_Task_Entry_Call (Cancel_Param);
630 Make_Procedure_Call_Statement
(Loc
,
632 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
633 Parameter_Associations
=> New_List
(
634 New_Occurrence_Of
(Cancel_Param
, Loc
))));
639 Append_List_To
(Stmts
, Additional_Cleanup
);
641 end Build_Cleanup_Statements
;
643 -----------------------------
644 -- Build_Controlling_Procs --
645 -----------------------------
647 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
649 if Is_Array_Type
(Typ
) then
650 Build_Array_Deep_Procs
(Typ
);
651 else pragma Assert
(Is_Record_Type
(Typ
));
652 Build_Record_Deep_Procs
(Typ
);
654 end Build_Controlling_Procs
;
656 -----------------------------
657 -- Build_Exception_Handler --
658 -----------------------------
660 function Build_Exception_Handler
661 (Data
: Finalization_Exception_Data
;
662 For_Library
: Boolean := False) return Node_Id
665 Proc_To_Call
: Entity_Id
;
670 pragma Assert
(Present
(Data
.Raised_Id
));
672 if Exception_Extra_Info
673 or else (For_Library
and not Restricted_Profile
)
675 if Exception_Extra_Info
then
679 -- Get_Current_Excep.all
682 Make_Function_Call
(Data
.Loc
,
684 Make_Explicit_Dereference
(Data
.Loc
,
687 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
694 Except
:= Make_Null
(Data
.Loc
);
697 if For_Library
and then not Restricted_Profile
then
698 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
699 Actuals
:= New_List
(Except
);
702 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
704 -- The dereference occurs only when Exception_Extra_Info is true,
705 -- and therefore Except is not null.
709 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
710 Make_Explicit_Dereference
(Data
.Loc
, Except
));
716 -- if not Raised_Id then
717 -- Raised_Id := True;
719 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
721 -- Save_Library_Occurrence (Get_Current_Excep.all);
726 Make_If_Statement
(Data
.Loc
,
728 Make_Op_Not
(Data
.Loc
,
729 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
731 Then_Statements
=> New_List
(
732 Make_Assignment_Statement
(Data
.Loc
,
733 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
734 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
736 Make_Procedure_Call_Statement
(Data
.Loc
,
738 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
739 Parameter_Associations
=> Actuals
))));
744 -- Raised_Id := True;
747 Make_Assignment_Statement
(Data
.Loc
,
748 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
749 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
757 Make_Exception_Handler
(Data
.Loc
,
758 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
759 Statements
=> Stmts
);
760 end Build_Exception_Handler
;
762 -------------------------------
763 -- Build_Finalization_Master --
764 -------------------------------
766 procedure Build_Finalization_Master
768 Ins_Node
: Node_Id
:= Empty
;
769 Encl_Scope
: Entity_Id
:= Empty
)
771 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
772 -- Determine whether entity E is inside a wrapper package created for
773 -- an instance of Ada.Unchecked_Deallocation.
775 ------------------------------
776 -- In_Deallocation_Instance --
777 ------------------------------
779 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
780 Pkg
: constant Entity_Id
:= Scope
(E
);
781 Par
: Node_Id
:= Empty
;
784 if Ekind
(Pkg
) = E_Package
785 and then Present
(Related_Instance
(Pkg
))
786 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
788 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
792 and then Chars
(Par
) = Name_Unchecked_Deallocation
793 and then Chars
(Scope
(Par
)) = Name_Ada
794 and then Scope
(Scope
(Par
)) = Standard_Standard
;
798 end In_Deallocation_Instance
;
802 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
804 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
805 -- A finalization master created for a named access type is associated
806 -- with the full view (if applicable) as a consequence of freezing. The
807 -- full view criteria does not apply to anonymous access types because
808 -- those cannot have a private and a full view.
810 -- Start of processing for Build_Finalization_Master
813 -- Certain run-time configurations and targets do not provide support
814 -- for controlled types.
816 if Restriction_Active
(No_Finalization
) then
819 -- Do not process C, C++, CIL and Java types since it is assumend that
820 -- the non-Ada side will handle their clean up.
822 elsif Convention
(Desig_Typ
) = Convention_C
823 or else Convention
(Desig_Typ
) = Convention_CIL
824 or else Convention
(Desig_Typ
) = Convention_CPP
825 or else Convention
(Desig_Typ
) = Convention_Java
829 -- Various machinery such as freezing may have already created a
830 -- finalization master.
832 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
835 -- Do not process types that return on the secondary stack
837 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
838 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
842 -- Do not process types which may never allocate an object
844 elsif No_Pool_Assigned
(Ptr_Typ
) then
847 -- Do not process access types coming from Ada.Unchecked_Deallocation
848 -- instances. Even though the designated type may be controlled, the
849 -- access type will never participate in allocation.
851 elsif In_Deallocation_Instance
(Ptr_Typ
) then
854 -- Ignore the general use of anonymous access types unless the context
855 -- requires a finalization master.
857 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
858 and then No
(Ins_Node
)
862 -- Do not process non-library access types when restriction No_Nested_
863 -- Finalization is in effect since masters are controlled objects.
865 elsif Restriction_Active
(No_Nested_Finalization
)
866 and then not Is_Library_Level_Entity
(Ptr_Typ
)
870 -- For .NET/JVM targets, allow the processing of access-to-controlled
871 -- types where the designated type is explicitly derived from [Limited_]
874 elsif VM_Target
/= No_VM
and then not Is_Controlled
(Desig_Typ
) then
877 -- Do not create finalization masters in SPARK mode because they result
878 -- in unwanted expansion.
880 -- More detail would be useful here ???
882 elsif GNATprove_Mode
then
887 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
888 Actions
: constant List_Id
:= New_List
;
889 Fin_Mas_Id
: Entity_Id
;
894 -- Fnn : aliased Finalization_Master;
896 -- Source access types use fixed master names since the master is
897 -- inserted in the same source unit only once. The only exception to
898 -- this are instances using the same access type as generic actual.
900 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
902 Make_Defining_Identifier
(Loc
,
903 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
905 -- Internally generated access types use temporaries as their names
906 -- due to possible collision with identical names coming from other
910 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
914 Make_Object_Declaration
(Loc
,
915 Defining_Identifier
=> Fin_Mas_Id
,
916 Aliased_Present
=> True,
918 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
920 -- Storage pool selection and attribute decoration of the generated
921 -- master. Since .NET/JVM compilers do not support pools, this step
924 if VM_Target
= No_VM
then
926 -- If the access type has a user-defined pool, use it as the base
927 -- storage medium for the finalization pool.
929 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
930 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
932 -- The default choice is the global pool
935 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
936 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
940 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
943 Make_Procedure_Call_Statement
(Loc
,
945 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
946 Parameter_Associations
=> New_List
(
947 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
948 Make_Attribute_Reference
(Loc
,
949 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
950 Attribute_Name
=> Name_Unrestricted_Access
))));
953 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
955 -- A finalization master created for an anonymous access type must be
956 -- inserted before a context-dependent node.
958 if Present
(Ins_Node
) then
959 Push_Scope
(Encl_Scope
);
961 -- Treat use clauses as declarations and insert directly in front
964 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
967 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
969 Insert_Actions
(Ins_Node
, Actions
);
974 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
975 and then Has_Completion_In_Body
(Desig_Typ
)
977 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
979 -- If the designated type is not yet frozen, then append the actions
980 -- to that type's freeze actions. The actions need to be appended to
981 -- whichever type is frozen later, similarly to what Freeze_Type does
982 -- for appending the storage pool declaration for an access type.
983 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
984 -- pool object before it's declared. However, it's not clear that
985 -- this is exactly the right test to accomplish that here. ???
987 elsif Present
(Freeze_Node
(Desig_Typ
))
988 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
990 Append_Freeze_Actions
(Desig_Typ
, Actions
);
992 elsif Present
(Freeze_Node
(Ptr_Typ
))
993 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
995 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
997 -- If there's a pool created locally for the access type, then we
998 -- need to ensure that the master gets created after the pool object,
999 -- because otherwise we can have a forward reference, so we force the
1000 -- master actions to be inserted and analyzed after the pool entity.
1001 -- Note that both the access type and its designated type may have
1002 -- already been frozen and had their freezing actions analyzed at
1003 -- this point. (This seems a little unclean.???)
1005 elsif VM_Target
= No_VM
1006 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1008 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1011 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1014 end Build_Finalization_Master
;
1016 ---------------------
1017 -- Build_Finalizer --
1018 ---------------------
1020 procedure Build_Finalizer
1022 Clean_Stmts
: List_Id
;
1023 Mark_Id
: Entity_Id
;
1024 Top_Decls
: List_Id
;
1025 Defer_Abort
: Boolean;
1026 Fin_Id
: out Entity_Id
)
1028 Acts_As_Clean
: constant Boolean :=
1031 (Present
(Clean_Stmts
)
1032 and then Is_Non_Empty_List
(Clean_Stmts
));
1033 Exceptions_OK
: constant Boolean :=
1034 not Restriction_Active
(No_Exception_Propagation
);
1035 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1036 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1037 For_Package
: constant Boolean :=
1038 For_Package_Body
or else For_Package_Spec
;
1039 Loc
: constant Source_Ptr
:= Sloc
(N
);
1041 -- NOTE: Local variable declarations are conservative and do not create
1042 -- structures right from the start. Entities and lists are created once
1043 -- it has been established that N has at least one controlled object.
1045 Components_Built
: Boolean := False;
1046 -- A flag used to avoid double initialization of entities and lists. If
1047 -- the flag is set then the following variables have been initialized:
1053 Counter_Id
: Entity_Id
:= Empty
;
1054 Counter_Val
: Int
:= 0;
1055 -- Name and value of the state counter
1057 Decls
: List_Id
:= No_List
;
1058 -- Declarative region of N (if available). If N is a package declaration
1059 -- Decls denotes the visible declarations.
1061 Finalizer_Data
: Finalization_Exception_Data
;
1062 -- Data for the exception
1064 Finalizer_Decls
: List_Id
:= No_List
;
1065 -- Local variable declarations. This list holds the label declarations
1066 -- of all jump block alternatives as well as the declaration of the
1067 -- local exception occurence and the raised flag:
1068 -- E : Exception_Occurrence;
1069 -- Raised : Boolean := False;
1070 -- L<counter value> : label;
1072 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1073 -- Insertion point for the finalizer body. Depending on the context
1074 -- (Nkind of N) and the individual grouping of controlled objects, this
1075 -- node may denote a package declaration or body, package instantiation,
1076 -- block statement or a counter update statement.
1078 Finalizer_Stmts
: List_Id
:= No_List
;
1079 -- The statement list of the finalizer body. It contains the following:
1081 -- Abort_Defer; -- Added if abort is allowed
1082 -- <call to Prev_At_End> -- Added if exists
1083 -- <cleanup statements> -- Added if Acts_As_Clean
1084 -- <jump block> -- Added if Has_Ctrl_Objs
1085 -- <finalization statements> -- Added if Has_Ctrl_Objs
1086 -- <stack release> -- Added if Mark_Id exists
1087 -- Abort_Undefer; -- Added if abort is allowed
1089 Has_Ctrl_Objs
: Boolean := False;
1090 -- A general flag which denotes whether N has at least one controlled
1093 Has_Tagged_Types
: Boolean := False;
1094 -- A general flag which indicates whether N has at least one library-
1095 -- level tagged type declaration.
1097 HSS
: Node_Id
:= Empty
;
1098 -- The sequence of statements of N (if available)
1100 Jump_Alts
: List_Id
:= No_List
;
1101 -- Jump block alternatives. Depending on the value of the state counter,
1102 -- the control flow jumps to a sequence of finalization statements. This
1103 -- list contains the following:
1105 -- when <counter value> =>
1106 -- goto L<counter value>;
1108 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1109 -- Specific point in the finalizer statements where the jump block is
1112 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1113 -- The last controlled construct encountered when processing the top
1114 -- level lists of N. This can be a nested package, an instantiation or
1115 -- an object declaration.
1117 Prev_At_End
: Entity_Id
:= Empty
;
1118 -- The previous at end procedure of the handled statements block of N
1120 Priv_Decls
: List_Id
:= No_List
;
1121 -- The private declarations of N if N is a package declaration
1123 Spec_Id
: Entity_Id
:= Empty
;
1124 Spec_Decls
: List_Id
:= Top_Decls
;
1125 Stmts
: List_Id
:= No_List
;
1127 Tagged_Type_Stmts
: List_Id
:= No_List
;
1128 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1129 -- tagged types found in N.
1131 -----------------------
1132 -- Local subprograms --
1133 -----------------------
1135 procedure Build_Components
;
1136 -- Create all entites and initialize all lists used in the creation of
1139 procedure Create_Finalizer
;
1140 -- Create the spec and body of the finalizer and insert them in the
1141 -- proper place in the tree depending on the context.
1143 procedure Process_Declarations
1145 Preprocess
: Boolean := False;
1146 Top_Level
: Boolean := False);
1147 -- Inspect a list of declarations or statements which may contain
1148 -- objects that need finalization. When flag Preprocess is set, the
1149 -- routine will simply count the total number of controlled objects in
1150 -- Decls. Flag Top_Level denotes whether the processing is done for
1151 -- objects in nested package declarations or instances.
1153 procedure Process_Object_Declaration
1155 Has_No_Init
: Boolean := False;
1156 Is_Protected
: Boolean := False);
1157 -- Generate all the machinery associated with the finalization of a
1158 -- single object. Flag Has_No_Init is used to denote certain contexts
1159 -- where Decl does not have initialization call(s). Flag Is_Protected
1160 -- is set when Decl denotes a simple protected object.
1162 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1163 -- Generate all the code necessary to unregister the external tag of a
1166 ----------------------
1167 -- Build_Components --
1168 ----------------------
1170 procedure Build_Components
is
1171 Counter_Decl
: Node_Id
;
1172 Counter_Typ
: Entity_Id
;
1173 Counter_Typ_Decl
: Node_Id
;
1176 pragma Assert
(Present
(Decls
));
1178 -- This routine might be invoked several times when dealing with
1179 -- constructs that have two lists (either two declarative regions
1180 -- or declarations and statements). Avoid double initialization.
1182 if Components_Built
then
1186 Components_Built
:= True;
1188 if Has_Ctrl_Objs
then
1190 -- Create entities for the counter, its type, the local exception
1191 -- and the raised flag.
1193 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1194 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1196 Finalizer_Decls
:= New_List
;
1198 Build_Object_Declarations
1199 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1201 -- Since the total number of controlled objects is always known,
1202 -- build a subtype of Natural with precise bounds. This allows
1203 -- the backend to optimize the case statement. Generate:
1205 -- subtype Tnn is Natural range 0 .. Counter_Val;
1208 Make_Subtype_Declaration
(Loc
,
1209 Defining_Identifier
=> Counter_Typ
,
1210 Subtype_Indication
=>
1211 Make_Subtype_Indication
(Loc
,
1212 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1214 Make_Range_Constraint
(Loc
,
1218 Make_Integer_Literal
(Loc
, Uint_0
),
1220 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1222 -- Generate the declaration of the counter itself:
1224 -- Counter : Integer := 0;
1227 Make_Object_Declaration
(Loc
,
1228 Defining_Identifier
=> Counter_Id
,
1229 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1230 Expression
=> Make_Integer_Literal
(Loc
, 0));
1232 -- Set the type of the counter explicitly to prevent errors when
1233 -- examining object declarations later on.
1235 Set_Etype
(Counter_Id
, Counter_Typ
);
1237 -- The counter and its type are inserted before the source
1238 -- declarations of N.
1240 Prepend_To
(Decls
, Counter_Decl
);
1241 Prepend_To
(Decls
, Counter_Typ_Decl
);
1243 -- The counter and its associated type must be manually analized
1244 -- since N has already been analyzed. Use the scope of the spec
1245 -- when inserting in a package.
1248 Push_Scope
(Spec_Id
);
1249 Analyze
(Counter_Typ_Decl
);
1250 Analyze
(Counter_Decl
);
1254 Analyze
(Counter_Typ_Decl
);
1255 Analyze
(Counter_Decl
);
1258 Jump_Alts
:= New_List
;
1261 -- If the context requires additional clean up, the finalization
1262 -- machinery is added after the clean up code.
1264 if Acts_As_Clean
then
1265 Finalizer_Stmts
:= Clean_Stmts
;
1266 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1268 Finalizer_Stmts
:= New_List
;
1271 if Has_Tagged_Types
then
1272 Tagged_Type_Stmts
:= New_List
;
1274 end Build_Components
;
1276 ----------------------
1277 -- Create_Finalizer --
1278 ----------------------
1280 procedure Create_Finalizer
is
1281 Body_Id
: Entity_Id
;
1284 Jump_Block
: Node_Id
;
1286 Label_Id
: Entity_Id
;
1288 function New_Finalizer_Name
return Name_Id
;
1289 -- Create a fully qualified name of a package spec or body finalizer.
1290 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1292 ------------------------
1293 -- New_Finalizer_Name --
1294 ------------------------
1296 function New_Finalizer_Name
return Name_Id
is
1297 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1298 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1299 -- has a non-standard scope, process the scope first.
1301 ------------------------
1302 -- New_Finalizer_Name --
1303 ------------------------
1305 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1307 if Scope
(Id
) = Standard_Standard
then
1308 Get_Name_String
(Chars
(Id
));
1311 New_Finalizer_Name
(Scope
(Id
));
1312 Add_Str_To_Name_Buffer
("__");
1313 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1315 end New_Finalizer_Name
;
1317 -- Start of processing for New_Finalizer_Name
1320 -- Create the fully qualified name of the enclosing scope
1322 New_Finalizer_Name
(Spec_Id
);
1325 -- __finalize_[spec|body]
1327 Add_Str_To_Name_Buffer
("__finalize_");
1329 if For_Package_Spec
then
1330 Add_Str_To_Name_Buffer
("spec");
1332 Add_Str_To_Name_Buffer
("body");
1336 end New_Finalizer_Name
;
1338 -- Start of processing for Create_Finalizer
1341 -- Step 1: Creation of the finalizer name
1343 -- Packages must use a distinct name for their finalizers since the
1344 -- binder will have to generate calls to them by name. The name is
1345 -- of the following form:
1347 -- xx__yy__finalize_[spec|body]
1350 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1351 Set_Has_Qualified_Name
(Fin_Id
);
1352 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1354 -- The default name is _finalizer
1358 Make_Defining_Identifier
(Loc
,
1359 Chars
=> New_External_Name
(Name_uFinalizer
));
1361 -- The visibility semantics of AT_END handlers force a strange
1362 -- separation of spec and body for stack-related finalizers:
1364 -- declare : Enclosing_Scope
1365 -- procedure _finalizer;
1367 -- <controlled objects>
1368 -- procedure _finalizer is
1374 -- Both spec and body are within the same construct and scope, but
1375 -- the body is part of the handled sequence of statements. This
1376 -- placement confuses the elaboration mechanism on targets where
1377 -- AT_END handlers are expanded into "when all others" handlers:
1380 -- when all others =>
1381 -- _finalizer; -- appears to require elab checks
1386 -- Since the compiler guarantees that the body of a _finalizer is
1387 -- always inserted in the same construct where the AT_END handler
1388 -- resides, there is no need for elaboration checks.
1390 Set_Kill_Elaboration_Checks
(Fin_Id
);
1393 -- Step 2: Creation of the finalizer specification
1396 -- procedure Fin_Id;
1399 Make_Subprogram_Declaration
(Loc
,
1401 Make_Procedure_Specification
(Loc
,
1402 Defining_Unit_Name
=> Fin_Id
));
1404 -- Step 3: Creation of the finalizer body
1406 if Has_Ctrl_Objs
then
1408 -- Add L0, the default destination to the jump block
1410 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1411 Set_Entity
(Label_Id
,
1412 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1413 Label
:= Make_Label
(Loc
, Label_Id
);
1418 Prepend_To
(Finalizer_Decls
,
1419 Make_Implicit_Label_Declaration
(Loc
,
1420 Defining_Identifier
=> Entity
(Label_Id
),
1421 Label_Construct
=> Label
));
1427 Append_To
(Jump_Alts
,
1428 Make_Case_Statement_Alternative
(Loc
,
1429 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1430 Statements
=> New_List
(
1431 Make_Goto_Statement
(Loc
,
1432 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1437 Append_To
(Finalizer_Stmts
, Label
);
1439 -- Create the jump block which controls the finalization flow
1440 -- depending on the value of the state counter.
1443 Make_Case_Statement
(Loc
,
1444 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1445 Alternatives
=> Jump_Alts
);
1447 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1448 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1450 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1454 -- Add the library-level tagged type unregistration machinery before
1455 -- the jump block circuitry. This ensures that external tags will be
1456 -- removed even if a finalization exception occurs at some point.
1458 if Has_Tagged_Types
then
1459 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1462 -- Add a call to the previous At_End handler if it exists. The call
1463 -- must always precede the jump block.
1465 if Present
(Prev_At_End
) then
1466 Prepend_To
(Finalizer_Stmts
,
1467 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1469 -- Clear the At_End handler since we have already generated the
1470 -- proper replacement call for it.
1472 Set_At_End_Proc
(HSS
, Empty
);
1475 -- Release the secondary stack mark
1477 if Present
(Mark_Id
) then
1478 Append_To
(Finalizer_Stmts
, Build_SS_Release_Call
(Loc
, Mark_Id
));
1481 -- Protect the statements with abort defer/undefer. This is only when
1482 -- aborts are allowed and the clean up statements require deferral or
1483 -- there are controlled objects to be finalized.
1485 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1486 Prepend_To
(Finalizer_Stmts
,
1487 Make_Procedure_Call_Statement
(Loc
,
1488 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Defer
), Loc
)));
1490 Append_To
(Finalizer_Stmts
,
1491 Make_Procedure_Call_Statement
(Loc
,
1492 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Undefer
), Loc
)));
1495 -- The local exception does not need to be reraised for library-level
1496 -- finalizers. Note that this action must be carried out after object
1497 -- clean up, secondary stack release and abort undeferral. Generate:
1499 -- if Raised and then not Abort then
1500 -- Raise_From_Controlled_Operation (E);
1503 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1504 Append_To
(Finalizer_Stmts
,
1505 Build_Raise_Statement
(Finalizer_Data
));
1509 -- procedure Fin_Id is
1510 -- Abort : constant Boolean := Triggered_By_Abort;
1512 -- Abort : constant Boolean := False; -- no abort
1514 -- E : Exception_Occurrence; -- All added if flag
1515 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1521 -- Abort_Defer; -- Added if abort is allowed
1522 -- <call to Prev_At_End> -- Added if exists
1523 -- <cleanup statements> -- Added if Acts_As_Clean
1524 -- <jump block> -- Added if Has_Ctrl_Objs
1525 -- <finalization statements> -- Added if Has_Ctrl_Objs
1526 -- <stack release> -- Added if Mark_Id exists
1527 -- Abort_Undefer; -- Added if abort is allowed
1528 -- <exception propagation> -- Added if Has_Ctrl_Objs
1531 -- Create the body of the finalizer
1533 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1536 Set_Has_Qualified_Name
(Body_Id
);
1537 Set_Has_Fully_Qualified_Name
(Body_Id
);
1541 Make_Subprogram_Body
(Loc
,
1543 Make_Procedure_Specification
(Loc
,
1544 Defining_Unit_Name
=> Body_Id
),
1545 Declarations
=> Finalizer_Decls
,
1546 Handled_Statement_Sequence
=>
1547 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1549 -- Step 4: Spec and body insertion, analysis
1553 -- If the package spec has private declarations, the finalizer
1554 -- body must be added to the end of the list in order to have
1555 -- visibility of all private controlled objects.
1557 if For_Package_Spec
then
1558 if Present
(Priv_Decls
) then
1559 Append_To
(Priv_Decls
, Fin_Spec
);
1560 Append_To
(Priv_Decls
, Fin_Body
);
1562 Append_To
(Decls
, Fin_Spec
);
1563 Append_To
(Decls
, Fin_Body
);
1566 -- For package bodies, both the finalizer spec and body are
1567 -- inserted at the end of the package declarations.
1570 Append_To
(Decls
, Fin_Spec
);
1571 Append_To
(Decls
, Fin_Body
);
1574 -- Push the name of the package
1576 Push_Scope
(Spec_Id
);
1584 -- Create the spec for the finalizer. The At_End handler must be
1585 -- able to call the body which resides in a nested structure.
1589 -- procedure Fin_Id; -- Spec
1591 -- <objects and possibly statements>
1592 -- procedure Fin_Id is ... -- Body
1595 -- Fin_Id; -- At_End handler
1598 pragma Assert
(Present
(Spec_Decls
));
1600 Append_To
(Spec_Decls
, Fin_Spec
);
1603 -- When the finalizer acts solely as a clean up routine, the body
1604 -- is inserted right after the spec.
1606 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1607 Insert_After
(Fin_Spec
, Fin_Body
);
1609 -- In all other cases the body is inserted after either:
1611 -- 1) The counter update statement of the last controlled object
1612 -- 2) The last top level nested controlled package
1613 -- 3) The last top level controlled instantiation
1616 -- Manually freeze the spec. This is somewhat of a hack because
1617 -- a subprogram is frozen when its body is seen and the freeze
1618 -- node appears right before the body. However, in this case,
1619 -- the spec must be frozen earlier since the At_End handler
1620 -- must be able to call it.
1623 -- procedure Fin_Id; -- Spec
1624 -- [Fin_Id] -- Freeze node
1628 -- Fin_Id; -- At_End handler
1631 Ensure_Freeze_Node
(Fin_Id
);
1632 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1633 Set_Is_Frozen
(Fin_Id
);
1635 -- In the case where the last construct to contain a controlled
1636 -- object is either a nested package, an instantiation or a
1637 -- freeze node, the body must be inserted directly after the
1640 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1642 N_Package_Declaration
,
1645 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1648 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1653 end Create_Finalizer
;
1655 --------------------------
1656 -- Process_Declarations --
1657 --------------------------
1659 procedure Process_Declarations
1661 Preprocess
: Boolean := False;
1662 Top_Level
: Boolean := False)
1667 Obj_Typ
: Entity_Id
;
1668 Pack_Id
: Entity_Id
;
1672 Old_Counter_Val
: Int
;
1673 -- This variable is used to determine whether a nested package or
1674 -- instance contains at least one controlled object.
1676 procedure Processing_Actions
1677 (Has_No_Init
: Boolean := False;
1678 Is_Protected
: Boolean := False);
1679 -- Depending on the mode of operation of Process_Declarations, either
1680 -- increment the controlled object counter, set the controlled object
1681 -- flag and store the last top level construct or process the current
1682 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1683 -- the current declaration may not have initialization proc(s). Flag
1684 -- Is_Protected should be set when the current declaration denotes a
1685 -- simple protected object.
1687 ------------------------
1688 -- Processing_Actions --
1689 ------------------------
1691 procedure Processing_Actions
1692 (Has_No_Init
: Boolean := False;
1693 Is_Protected
: Boolean := False)
1696 -- Library-level tagged type
1698 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1700 Has_Tagged_Types
:= True;
1702 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1703 Last_Top_Level_Ctrl_Construct
:= Decl
;
1707 Process_Tagged_Type_Declaration
(Decl
);
1710 -- Controlled object declaration
1714 Counter_Val
:= Counter_Val
+ 1;
1715 Has_Ctrl_Objs
:= True;
1717 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1718 Last_Top_Level_Ctrl_Construct
:= Decl
;
1722 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1725 end Processing_Actions
;
1727 -- Start of processing for Process_Declarations
1730 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1734 -- Process all declarations in reverse order
1736 Decl
:= Last_Non_Pragma
(Decls
);
1737 while Present
(Decl
) loop
1739 -- Library-level tagged types
1741 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1742 Typ
:= Defining_Identifier
(Decl
);
1744 if Is_Tagged_Type
(Typ
)
1745 and then Is_Library_Level_Entity
(Typ
)
1746 and then Convention
(Typ
) = Convention_Ada
1747 and then Present
(Access_Disp_Table
(Typ
))
1748 and then RTE_Available
(RE_Register_Tag
)
1749 and then not No_Run_Time_Mode
1750 and then not Is_Abstract_Type
(Typ
)
1755 -- Regular object declarations
1757 elsif Nkind
(Decl
) = N_Object_Declaration
then
1758 Obj_Id
:= Defining_Identifier
(Decl
);
1759 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1760 Expr
:= Expression
(Decl
);
1762 -- Bypass any form of processing for objects which have their
1763 -- finalization disabled. This applies only to objects at the
1766 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1769 -- Transient variables are treated separately in order to
1770 -- minimize the size of the generated code. For details, see
1771 -- Process_Transient_Objects.
1773 elsif Is_Processed_Transient
(Obj_Id
) then
1776 -- The object is of the form:
1777 -- Obj : Typ [:= Expr];
1779 -- Do not process the incomplete view of a deferred constant.
1780 -- Do not consider tag-to-class-wide conversions.
1782 elsif not Is_Imported
(Obj_Id
)
1783 and then Needs_Finalization
(Obj_Typ
)
1784 and then not (Ekind
(Obj_Id
) = E_Constant
1785 and then not Has_Completion
(Obj_Id
))
1786 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1790 -- The object is of the form:
1791 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1793 -- Obj : Access_Typ :=
1794 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1796 elsif Is_Access_Type
(Obj_Typ
)
1797 and then Needs_Finalization
1798 (Available_View
(Designated_Type
(Obj_Typ
)))
1799 and then Present
(Expr
)
1801 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1803 (Is_Non_BIP_Func_Call
(Expr
)
1804 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1806 Processing_Actions
(Has_No_Init
=> True);
1808 -- Processing for "hook" objects generated for controlled
1809 -- transients declared inside an Expression_With_Actions.
1811 elsif Is_Access_Type
(Obj_Typ
)
1812 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1813 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1814 N_Object_Declaration
1816 Processing_Actions
(Has_No_Init
=> True);
1818 -- Process intermediate results of an if expression with one
1819 -- of the alternatives using a controlled function call.
1821 elsif Is_Access_Type
(Obj_Typ
)
1822 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1823 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1824 N_Defining_Identifier
1825 and then Present
(Expr
)
1826 and then Nkind
(Expr
) = N_Null
1828 Processing_Actions
(Has_No_Init
=> True);
1830 -- Simple protected objects which use type System.Tasking.
1831 -- Protected_Objects.Protection to manage their locks should
1832 -- be treated as controlled since they require manual cleanup.
1833 -- The only exception is illustrated in the following example:
1836 -- type Ctrl is new Controlled ...
1837 -- procedure Finalize (Obj : in out Ctrl);
1841 -- package body Pkg is
1842 -- protected Prot is
1843 -- procedure Do_Something (Obj : in out Ctrl);
1846 -- protected body Prot is
1847 -- procedure Do_Something (Obj : in out Ctrl) is ...
1850 -- procedure Finalize (Obj : in out Ctrl) is
1852 -- Prot.Do_Something (Obj);
1856 -- Since for the most part entities in package bodies depend on
1857 -- those in package specs, Prot's lock should be cleaned up
1858 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1859 -- This act however attempts to invoke Do_Something and fails
1860 -- because the lock has disappeared.
1862 elsif Ekind
(Obj_Id
) = E_Variable
1863 and then not In_Library_Level_Package_Body
(Obj_Id
)
1864 and then (Is_Simple_Protected_Type
(Obj_Typ
)
1865 or else Has_Simple_Protected_Object
(Obj_Typ
))
1867 Processing_Actions
(Is_Protected
=> True);
1870 -- Specific cases of object renamings
1872 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1873 Obj_Id
:= Defining_Identifier
(Decl
);
1874 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1876 -- Bypass any form of processing for objects which have their
1877 -- finalization disabled. This applies only to objects at the
1880 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1883 -- Return object of a build-in-place function. This case is
1884 -- recognized and marked by the expansion of an extended return
1885 -- statement (see Expand_N_Extended_Return_Statement).
1887 elsif Needs_Finalization
(Obj_Typ
)
1888 and then Is_Return_Object
(Obj_Id
)
1889 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1891 Processing_Actions
(Has_No_Init
=> True);
1893 -- Detect a case where a source object has been initialized by
1894 -- a controlled function call or another object which was later
1895 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1897 -- Obj1 : CW_Type := Src_Obj;
1898 -- Obj2 : CW_Type := Function_Call (...);
1900 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1901 -- Tmp : ... := Function_Call (...)'reference;
1902 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1904 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1905 Processing_Actions
(Has_No_Init
=> True);
1908 -- Inspect the freeze node of an access-to-controlled type and
1909 -- look for a delayed finalization master. This case arises when
1910 -- the freeze actions are inserted at a later time than the
1911 -- expansion of the context. Since Build_Finalizer is never called
1912 -- on a single construct twice, the master will be ultimately
1913 -- left out and never finalized. This is also needed for freeze
1914 -- actions of designated types themselves, since in some cases the
1915 -- finalization master is associated with a designated type's
1916 -- freeze node rather than that of the access type (see handling
1917 -- for freeze actions in Build_Finalization_Master).
1919 elsif Nkind
(Decl
) = N_Freeze_Entity
1920 and then Present
(Actions
(Decl
))
1922 Typ
:= Entity
(Decl
);
1924 if (Is_Access_Type
(Typ
)
1925 and then not Is_Access_Subprogram_Type
(Typ
)
1926 and then Needs_Finalization
1927 (Available_View
(Designated_Type
(Typ
))))
1928 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
1930 Old_Counter_Val
:= Counter_Val
;
1932 -- Freeze nodes are considered to be identical to packages
1933 -- and blocks in terms of nesting. The difference is that
1934 -- a finalization master created inside the freeze node is
1935 -- at the same nesting level as the node itself.
1937 Process_Declarations
(Actions
(Decl
), Preprocess
);
1939 -- The freeze node contains a finalization master
1943 and then No
(Last_Top_Level_Ctrl_Construct
)
1944 and then Counter_Val
> Old_Counter_Val
1946 Last_Top_Level_Ctrl_Construct
:= Decl
;
1950 -- Nested package declarations, avoid generics
1952 elsif Nkind
(Decl
) = N_Package_Declaration
then
1953 Spec
:= Specification
(Decl
);
1954 Pack_Id
:= Defining_Unit_Name
(Spec
);
1956 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
1957 Pack_Id
:= Defining_Identifier
(Pack_Id
);
1960 if Ekind
(Pack_Id
) /= E_Generic_Package
then
1961 Old_Counter_Val
:= Counter_Val
;
1962 Process_Declarations
1963 (Private_Declarations
(Spec
), Preprocess
);
1964 Process_Declarations
1965 (Visible_Declarations
(Spec
), Preprocess
);
1967 -- Either the visible or the private declarations contain a
1968 -- controlled object. The nested package declaration is the
1969 -- last such construct.
1973 and then No
(Last_Top_Level_Ctrl_Construct
)
1974 and then Counter_Val
> Old_Counter_Val
1976 Last_Top_Level_Ctrl_Construct
:= Decl
;
1980 -- Nested package bodies, avoid generics
1982 elsif Nkind
(Decl
) = N_Package_Body
then
1983 Spec
:= Corresponding_Spec
(Decl
);
1985 if Ekind
(Spec
) /= E_Generic_Package
then
1986 Old_Counter_Val
:= Counter_Val
;
1987 Process_Declarations
(Declarations
(Decl
), Preprocess
);
1989 -- The nested package body is the last construct to contain
1990 -- a controlled object.
1994 and then No
(Last_Top_Level_Ctrl_Construct
)
1995 and then Counter_Val
> Old_Counter_Val
1997 Last_Top_Level_Ctrl_Construct
:= Decl
;
2001 -- Handle a rare case caused by a controlled transient variable
2002 -- created as part of a record init proc. The variable is wrapped
2003 -- in a block, but the block is not associated with a transient
2006 elsif Nkind
(Decl
) = N_Block_Statement
2007 and then Inside_Init_Proc
2009 Old_Counter_Val
:= Counter_Val
;
2011 if Present
(Handled_Statement_Sequence
(Decl
)) then
2012 Process_Declarations
2013 (Statements
(Handled_Statement_Sequence
(Decl
)),
2017 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2019 -- Either the declaration or statement list of the block has a
2020 -- controlled object.
2024 and then No
(Last_Top_Level_Ctrl_Construct
)
2025 and then Counter_Val
> Old_Counter_Val
2027 Last_Top_Level_Ctrl_Construct
:= Decl
;
2030 -- Handle the case where the original context has been wrapped in
2031 -- a block to avoid interference between exception handlers and
2032 -- At_End handlers. Treat the block as transparent and process its
2035 elsif Nkind
(Decl
) = N_Block_Statement
2036 and then Is_Finalization_Wrapper
(Decl
)
2038 if Present
(Handled_Statement_Sequence
(Decl
)) then
2039 Process_Declarations
2040 (Statements
(Handled_Statement_Sequence
(Decl
)),
2044 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2047 Prev_Non_Pragma
(Decl
);
2049 end Process_Declarations
;
2051 --------------------------------
2052 -- Process_Object_Declaration --
2053 --------------------------------
2055 procedure Process_Object_Declaration
2057 Has_No_Init
: Boolean := False;
2058 Is_Protected
: Boolean := False)
2060 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2061 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2063 Init_Typ
: Entity_Id
;
2064 -- The initialization type of the related object declaration. Note
2065 -- that this is not necessarely the same type as Obj_Typ because of
2066 -- possible type derivations.
2068 Obj_Typ
: Entity_Id
;
2069 -- The type of the related object declaration
2071 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2072 -- Func_Id denotes a build-in-place function. Generate the following
2075 -- if BIPallocfrom > Secondary_Stack'Pos
2076 -- and then BIPfinalizationmaster /= null
2079 -- type Ptr_Typ is access Obj_Typ;
2080 -- for Ptr_Typ'Storage_Pool
2081 -- use Base_Pool (BIPfinalizationmaster);
2083 -- Free (Ptr_Typ (Temp));
2087 -- Obj_Typ is the type of the current object, Temp is the original
2088 -- allocation which Obj_Id renames.
2090 procedure Find_Last_Init
2091 (Last_Init
: out Node_Id
;
2092 Body_Insert
: out Node_Id
);
2093 -- Find the last initialization call related to object declaration
2094 -- Decl. Last_Init denotes the last initialization call which follows
2095 -- Decl. Body_Insert denotes a node where the finalizer body could be
2096 -- potentially inserted after (if blocks are involved).
2098 -----------------------------
2099 -- Build_BIP_Cleanup_Stmts --
2100 -----------------------------
2102 function Build_BIP_Cleanup_Stmts
2103 (Func_Id
: Entity_Id
) return Node_Id
2105 Decls
: constant List_Id
:= New_List
;
2106 Fin_Mas_Id
: constant Entity_Id
:=
2107 Build_In_Place_Formal
2108 (Func_Id
, BIP_Finalization_Master
);
2109 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2110 Temp_Id
: constant Entity_Id
:=
2111 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2115 Free_Stmt
: Node_Id
;
2116 Pool_Id
: Entity_Id
;
2117 Ptr_Typ
: Entity_Id
;
2121 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2123 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2126 Make_Object_Renaming_Declaration
(Loc
,
2127 Defining_Identifier
=> Pool_Id
,
2129 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2131 Make_Explicit_Dereference
(Loc
,
2133 Make_Function_Call
(Loc
,
2135 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2136 Parameter_Associations
=> New_List
(
2137 Make_Explicit_Dereference
(Loc
,
2139 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2141 -- Create an access type which uses the storage pool of the
2142 -- caller's finalization master.
2145 -- type Ptr_Typ is access Func_Typ;
2147 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2150 Make_Full_Type_Declaration
(Loc
,
2151 Defining_Identifier
=> Ptr_Typ
,
2153 Make_Access_To_Object_Definition
(Loc
,
2154 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2156 -- Perform minor decoration in order to set the master and the
2157 -- storage pool attributes.
2159 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2160 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2161 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2163 -- Create an explicit free statement. Note that the free uses the
2164 -- caller's pool expressed as a renaming.
2167 Make_Free_Statement
(Loc
,
2169 Unchecked_Convert_To
(Ptr_Typ
,
2170 New_Occurrence_Of
(Temp_Id
, Loc
)));
2172 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2174 -- Create a block to house the dummy type and the instantiation as
2175 -- well as to perform the cleanup the temporary.
2181 -- Free (Ptr_Typ (Temp_Id));
2185 Make_Block_Statement
(Loc
,
2186 Declarations
=> Decls
,
2187 Handled_Statement_Sequence
=>
2188 Make_Handled_Sequence_Of_Statements
(Loc
,
2189 Statements
=> New_List
(Free_Stmt
)));
2192 -- if BIPfinalizationmaster /= null then
2196 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2197 Right_Opnd
=> Make_Null
(Loc
));
2199 -- For constrained or tagged results escalate the condition to
2200 -- include the allocation format. Generate:
2202 -- if BIPallocform > Secondary_Stack'Pos
2203 -- and then BIPfinalizationmaster /= null
2206 if not Is_Constrained
(Func_Typ
)
2207 or else Is_Tagged_Type
(Func_Typ
)
2210 Alloc
: constant Entity_Id
:=
2211 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2217 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2219 Make_Integer_Literal
(Loc
,
2221 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2223 Right_Opnd
=> Cond
);
2233 Make_If_Statement
(Loc
,
2235 Then_Statements
=> New_List
(Free_Blk
));
2236 end Build_BIP_Cleanup_Stmts
;
2238 --------------------
2239 -- Find_Last_Init --
2240 --------------------
2242 procedure Find_Last_Init
2243 (Last_Init
: out Node_Id
;
2244 Body_Insert
: out Node_Id
)
2246 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2247 -- Find the last initialization call within the statements of
2250 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2251 -- Determine whether node N denotes one of the initialization
2252 -- procedures of types Init_Typ or Obj_Typ.
2254 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2255 -- Given a statement which is part of a list, return the next
2256 -- statement while skipping over dynamic elab checks.
2258 -----------------------------
2259 -- Find_Last_Init_In_Block --
2260 -----------------------------
2262 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2263 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2267 -- Examine the individual statements of the block in reverse to
2268 -- locate the last initialization call.
2270 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2271 Stmt
:= Last
(Statements
(HSS
));
2272 while Present
(Stmt
) loop
2274 -- Peek inside nested blocks in case aborts are allowed
2276 if Nkind
(Stmt
) = N_Block_Statement
then
2277 return Find_Last_Init_In_Block
(Stmt
);
2279 elsif Is_Init_Call
(Stmt
) then
2288 end Find_Last_Init_In_Block
;
2294 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2295 function Is_Init_Proc_Of
2296 (Subp_Id
: Entity_Id
;
2297 Typ
: Entity_Id
) return Boolean;
2298 -- Determine whether subprogram Subp_Id is a valid init proc of
2301 ---------------------
2302 -- Is_Init_Proc_Of --
2303 ---------------------
2305 function Is_Init_Proc_Of
2306 (Subp_Id
: Entity_Id
;
2307 Typ
: Entity_Id
) return Boolean
2309 Deep_Init
: Entity_Id
:= Empty
;
2310 Prim_Init
: Entity_Id
:= Empty
;
2311 Type_Init
: Entity_Id
:= Empty
;
2314 -- Obtain all possible initialization routines of the
2315 -- related type and try to match the subprogram entity
2316 -- against one of them.
2320 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2322 -- Primitive Initialize
2324 if Is_Controlled
(Typ
) then
2325 Prim_Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2327 if Present
(Prim_Init
) then
2328 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2332 -- Type initialization routine
2334 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2335 Type_Init
:= Base_Init_Proc
(Typ
);
2339 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2341 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2343 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2344 end Is_Init_Proc_Of
;
2348 Call_Id
: Entity_Id
;
2350 -- Start of processing for Is_Init_Call
2353 if Nkind
(N
) = N_Procedure_Call_Statement
2354 and then Nkind
(Name
(N
)) = N_Identifier
2356 Call_Id
:= Entity
(Name
(N
));
2358 -- Consider both the type of the object declaration and its
2359 -- related initialization type.
2362 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2364 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2370 -----------------------------
2371 -- Next_Suitable_Statement --
2372 -----------------------------
2374 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2375 Result
: Node_Id
:= Next
(Stmt
);
2378 -- Skip over access-before-elaboration checks
2380 if Dynamic_Elaboration_Checks
2381 and then Nkind
(Result
) = N_Raise_Program_Error
2383 Result
:= Next
(Result
);
2387 end Next_Suitable_Statement
;
2395 Deep_Init_Found
: Boolean := False;
2396 -- A flag set when a call to [Deep_]Initialize has been found
2398 -- Start of processing for Find_Last_Init
2402 Body_Insert
:= Empty
;
2404 -- Object renamings and objects associated with controlled
2405 -- function results do not require initialization.
2411 Stmt
:= Next_Suitable_Statement
(Decl
);
2413 -- A limited controlled object initialized by a function call uses
2414 -- the build-in-place machinery to obtain its value.
2416 -- Obj : Lim_Controlled_Type := Func_Call;
2420 -- Obj : Lim_Controlled_Type;
2421 -- type Ptr_Typ is access Lim_Controlled_Type;
2422 -- Temp : constant Ptr_Typ :=
2425 -- BIPaccess => Obj'Unrestricted_Access)'reference;
2427 -- In this scenario the declaration of the temporary acts as the
2428 -- last initialization statement.
2430 if Is_Limited_Type
(Obj_Typ
)
2431 and then Has_Init_Expression
(Decl
)
2432 and then No
(Expression
(Decl
))
2434 while Present
(Stmt
) loop
2435 if Nkind
(Stmt
) = N_Object_Declaration
2436 and then Present
(Expression
(Stmt
))
2437 and then Is_Object_Access_BIP_Func_Call
2438 (Expr
=> Expression
(Stmt
),
2448 -- Nothing to do for an object with supporessed initialization.
2449 -- Note that this check is not performed at the beginning of the
2450 -- routine because a declaration marked with No_Initialization
2451 -- may still be initialized by a build-in-place call (the case
2454 elsif No_Initialization
(Decl
) then
2457 -- In all other cases the initialization calls follow the related
2458 -- object. The general structure of object initialization built by
2459 -- routine Default_Initialize_Object is as follows:
2461 -- [begin -- aborts allowed
2463 -- Type_Init_Proc (Obj);
2464 -- [begin] -- exceptions allowed
2465 -- Deep_Initialize (Obj);
2466 -- [exception -- exceptions allowed
2468 -- Deep_Finalize (Obj, Self => False);
2471 -- [at end -- aborts allowed
2475 -- When aborts are allowed, the initialization calls are housed
2478 elsif Nkind
(Stmt
) = N_Block_Statement
then
2479 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2480 Body_Insert
:= Stmt
;
2482 -- Otherwise the initialization calls follow the related object
2485 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2487 -- Check for an optional call to Deep_Initialize which may
2488 -- appear within a block depending on whether the object has
2489 -- controlled components.
2491 if Present
(Stmt_2
) then
2492 if Nkind
(Stmt_2
) = N_Block_Statement
then
2493 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2495 if Present
(Call
) then
2496 Deep_Init_Found
:= True;
2498 Body_Insert
:= Stmt_2
;
2501 elsif Is_Init_Call
(Stmt_2
) then
2502 Deep_Init_Found
:= True;
2503 Last_Init
:= Stmt_2
;
2504 Body_Insert
:= Last_Init
;
2508 -- If the object lacks a call to Deep_Initialize, then it must
2509 -- have a call to its related type init proc.
2511 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2513 Body_Insert
:= Last_Init
;
2521 Count_Ins
: Node_Id
;
2523 Fin_Stmts
: List_Id
;
2526 Label_Id
: Entity_Id
;
2529 -- Start of processing for Process_Object_Declaration
2532 -- Handle the object type and the reference to the object
2534 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2535 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2538 if Is_Access_Type
(Obj_Typ
) then
2539 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2540 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2542 elsif Is_Concurrent_Type
(Obj_Typ
)
2543 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2545 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2546 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2548 elsif Is_Private_Type
(Obj_Typ
)
2549 and then Present
(Full_View
(Obj_Typ
))
2551 Obj_Typ
:= Full_View
(Obj_Typ
);
2552 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2554 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2555 Obj_Typ
:= Base_Type
(Obj_Typ
);
2556 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2563 Set_Etype
(Obj_Ref
, Obj_Typ
);
2565 -- Handle the initialization type of the object declaration
2567 Init_Typ
:= Obj_Typ
;
2569 if Is_Private_Type
(Init_Typ
)
2570 and then Present
(Full_View
(Init_Typ
))
2572 Init_Typ
:= Full_View
(Init_Typ
);
2574 elsif Is_Untagged_Derivation
(Init_Typ
) then
2575 Init_Typ
:= Root_Type
(Init_Typ
);
2582 -- Set a new value for the state counter and insert the statement
2583 -- after the object declaration. Generate:
2585 -- Counter := <value>;
2588 Make_Assignment_Statement
(Loc
,
2589 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2590 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2592 -- Insert the counter after all initialization has been done. The
2593 -- place of insertion depends on the context. If an object is being
2594 -- initialized via an aggregate, then the counter must be inserted
2595 -- after the last aggregate assignment.
2597 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2598 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
2600 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2603 -- In all other cases the counter is inserted after the last call to
2604 -- either [Deep_]Initialize or the type specific init proc.
2607 Find_Last_Init
(Count_Ins
, Body_Ins
);
2610 Insert_After
(Count_Ins
, Inc_Decl
);
2613 -- If the current declaration is the last in the list, the finalizer
2614 -- body needs to be inserted after the set counter statement for the
2615 -- current object declaration. This is complicated by the fact that
2616 -- the set counter statement may appear in abort deferred block. In
2617 -- that case, the proper insertion place is after the block.
2619 if No
(Finalizer_Insert_Nod
) then
2621 -- Insertion after an abort deffered block
2623 if Present
(Body_Ins
) then
2624 Finalizer_Insert_Nod
:= Body_Ins
;
2626 Finalizer_Insert_Nod
:= Inc_Decl
;
2630 -- Create the associated label with this object, generate:
2632 -- L<counter> : label;
2635 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2637 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2638 Label
:= Make_Label
(Loc
, Label_Id
);
2640 Prepend_To
(Finalizer_Decls
,
2641 Make_Implicit_Label_Declaration
(Loc
,
2642 Defining_Identifier
=> Entity
(Label_Id
),
2643 Label_Construct
=> Label
));
2645 -- Create the associated jump with this object, generate:
2647 -- when <counter> =>
2650 Prepend_To
(Jump_Alts
,
2651 Make_Case_Statement_Alternative
(Loc
,
2652 Discrete_Choices
=> New_List
(
2653 Make_Integer_Literal
(Loc
, Counter_Val
)),
2654 Statements
=> New_List
(
2655 Make_Goto_Statement
(Loc
,
2656 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
2658 -- Insert the jump destination, generate:
2662 Append_To
(Finalizer_Stmts
, Label
);
2664 -- Processing for simple protected objects. Such objects require
2665 -- manual finalization of their lock managers.
2667 if Is_Protected
then
2668 Fin_Stmts
:= No_List
;
2670 if Is_Simple_Protected_Type
(Obj_Typ
) then
2671 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2673 if Present
(Fin_Call
) then
2674 Fin_Stmts
:= New_List
(Fin_Call
);
2677 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2678 if Is_Record_Type
(Obj_Typ
) then
2679 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2680 elsif Is_Array_Type
(Obj_Typ
) then
2681 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2687 -- System.Tasking.Protected_Objects.Finalize_Protection
2695 if Present
(Fin_Stmts
) then
2696 Append_To
(Finalizer_Stmts
,
2697 Make_Block_Statement
(Loc
,
2698 Handled_Statement_Sequence
=>
2699 Make_Handled_Sequence_Of_Statements
(Loc
,
2700 Statements
=> Fin_Stmts
,
2702 Exception_Handlers
=> New_List
(
2703 Make_Exception_Handler
(Loc
,
2704 Exception_Choices
=> New_List
(
2705 Make_Others_Choice
(Loc
)),
2707 Statements
=> New_List
(
2708 Make_Null_Statement
(Loc
)))))));
2711 -- Processing for regular controlled objects
2715 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2717 -- begin -- Exception handlers allowed
2718 -- [Deep_]Finalize (Obj);
2721 -- when Id : others =>
2722 -- if not Raised then
2724 -- Save_Occurrence (E, Id);
2733 -- For CodePeer, the exception handlers normally generated here
2734 -- generate complex flowgraphs which result in capacity problems.
2735 -- Omitting these handlers for CodePeer is justified as follows:
2737 -- If a handler is dead, then omitting it is surely ok
2739 -- If a handler is live, then CodePeer should flag the
2740 -- potentially-exception-raising construct that causes it
2741 -- to be live. That is what we are interested in, not what
2742 -- happens after the exception is raised.
2744 if Exceptions_OK
and not CodePeer_Mode
then
2745 Fin_Stmts
:= New_List
(
2746 Make_Block_Statement
(Loc
,
2747 Handled_Statement_Sequence
=>
2748 Make_Handled_Sequence_Of_Statements
(Loc
,
2749 Statements
=> New_List
(Fin_Call
),
2751 Exception_Handlers
=> New_List
(
2752 Build_Exception_Handler
2753 (Finalizer_Data
, For_Package
)))));
2755 -- When exception handlers are prohibited, the finalization call
2756 -- appears unprotected. Any exception raised during finalization
2757 -- will bypass the circuitry which ensures the cleanup of all
2758 -- remaining objects.
2761 Fin_Stmts
:= New_List
(Fin_Call
);
2764 -- If we are dealing with a return object of a build-in-place
2765 -- function, generate the following cleanup statements:
2767 -- if BIPallocfrom > Secondary_Stack'Pos
2768 -- and then BIPfinalizationmaster /= null
2771 -- type Ptr_Typ is access Obj_Typ;
2772 -- for Ptr_Typ'Storage_Pool use
2773 -- Base_Pool (BIPfinalizationmaster.all).all;
2775 -- Free (Ptr_Typ (Temp));
2779 -- The generated code effectively detaches the temporary from the
2780 -- caller finalization master and deallocates the object. This is
2781 -- disabled on .NET/JVM because pools are not supported.
2783 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2785 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2787 if Is_Build_In_Place_Function
(Func_Id
)
2788 and then Needs_BIP_Finalization_Master
(Func_Id
)
2790 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2795 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2796 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2798 -- Temporaries created for the purpose of "exporting" a
2799 -- controlled transient out of an Expression_With_Actions (EWA)
2800 -- need guards. The following illustrates the usage of such
2803 -- Access_Typ : access [all] Obj_Typ;
2804 -- Temp : Access_Typ := null;
2805 -- <Counter> := ...;
2808 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2809 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2811 -- Temp := Ctrl_Trans'Unchecked_Access;
2814 -- The finalization machinery does not process EWA nodes as
2815 -- this may lead to premature finalization of expressions. Note
2816 -- that Temp is marked as being properly initialized regardless
2817 -- of whether the initialization of Ctrl_Trans succeeded. Since
2818 -- a failed initialization may leave Temp with a value of null,
2819 -- add a guard to handle this case:
2821 -- if Obj /= null then
2822 -- <object finalization statements>
2825 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2826 N_Object_Declaration
2828 Fin_Stmts
:= New_List
(
2829 Make_If_Statement
(Loc
,
2832 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
2833 Right_Opnd
=> Make_Null
(Loc
)),
2834 Then_Statements
=> Fin_Stmts
));
2836 -- Return objects use a flag to aid in processing their
2837 -- potential finalization when the enclosing function fails
2838 -- to return properly. Generate:
2841 -- <object finalization statements>
2845 Fin_Stmts
:= New_List
(
2846 Make_If_Statement
(Loc
,
2851 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2853 Then_Statements
=> Fin_Stmts
));
2858 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2860 -- Since the declarations are examined in reverse, the state counter
2861 -- must be decremented in order to keep with the true position of
2864 Counter_Val
:= Counter_Val
- 1;
2865 end Process_Object_Declaration
;
2867 -------------------------------------
2868 -- Process_Tagged_Type_Declaration --
2869 -------------------------------------
2871 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2872 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2873 DT_Ptr
: constant Entity_Id
:=
2874 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2877 -- Ada.Tags.Unregister_Tag (<Typ>P);
2879 Append_To
(Tagged_Type_Stmts
,
2880 Make_Procedure_Call_Statement
(Loc
,
2882 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
2883 Parameter_Associations
=> New_List
(
2884 New_Occurrence_Of
(DT_Ptr
, Loc
))));
2885 end Process_Tagged_Type_Declaration
;
2887 -- Start of processing for Build_Finalizer
2892 -- Do not perform this expansion in SPARK mode because it is not
2895 if GNATprove_Mode
then
2899 -- Step 1: Extract all lists which may contain controlled objects or
2900 -- library-level tagged types.
2902 if For_Package_Spec
then
2903 Decls
:= Visible_Declarations
(Specification
(N
));
2904 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2906 -- Retrieve the package spec id
2908 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2910 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2911 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2914 -- Accept statement, block, entry body, package body, protected body,
2915 -- subprogram body or task body.
2918 Decls
:= Declarations
(N
);
2919 HSS
:= Handled_Statement_Sequence
(N
);
2921 if Present
(HSS
) then
2922 if Present
(Statements
(HSS
)) then
2923 Stmts
:= Statements
(HSS
);
2926 if Present
(At_End_Proc
(HSS
)) then
2927 Prev_At_End
:= At_End_Proc
(HSS
);
2931 -- Retrieve the package spec id for package bodies
2933 if For_Package_Body
then
2934 Spec_Id
:= Corresponding_Spec
(N
);
2938 -- Do not process nested packages since those are handled by the
2939 -- enclosing scope's finalizer. Do not process non-expanded package
2940 -- instantiations since those will be re-analyzed and re-expanded.
2944 (not Is_Library_Level_Entity
(Spec_Id
)
2946 -- Nested packages are considered to be library level entities,
2947 -- but do not need to be processed separately. True library level
2948 -- packages have a scope value of 1.
2950 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2951 or else (Is_Generic_Instance
(Spec_Id
)
2952 and then Package_Instantiation
(Spec_Id
) /= N
))
2957 -- Step 2: Object [pre]processing
2961 -- Preprocess the visible declarations now in order to obtain the
2962 -- correct number of controlled object by the time the private
2963 -- declarations are processed.
2965 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2967 -- From all the possible contexts, only package specifications may
2968 -- have private declarations.
2970 if For_Package_Spec
then
2971 Process_Declarations
2972 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2975 -- The current context may lack controlled objects, but require some
2976 -- other form of completion (task termination for instance). In such
2977 -- cases, the finalizer must be created and carry the additional
2980 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2984 -- The preprocessing has determined that the context has controlled
2985 -- objects or library-level tagged types.
2987 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2989 -- Private declarations are processed first in order to preserve
2990 -- possible dependencies between public and private objects.
2992 if For_Package_Spec
then
2993 Process_Declarations
(Priv_Decls
);
2996 Process_Declarations
(Decls
);
3002 -- Preprocess both declarations and statements
3004 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3005 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3007 -- At this point it is known that N has controlled objects. Ensure
3008 -- that N has a declarative list since the finalizer spec will be
3011 if Has_Ctrl_Objs
and then No
(Decls
) then
3012 Set_Declarations
(N
, New_List
);
3013 Decls
:= Declarations
(N
);
3014 Spec_Decls
:= Decls
;
3017 -- The current context may lack controlled objects, but require some
3018 -- other form of completion (task termination for instance). In such
3019 -- cases, the finalizer must be created and carry the additional
3022 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3026 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3027 Process_Declarations
(Stmts
);
3028 Process_Declarations
(Decls
);
3032 -- Step 3: Finalizer creation
3034 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3037 end Build_Finalizer
;
3039 --------------------------
3040 -- Build_Finalizer_Call --
3041 --------------------------
3043 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3044 Is_Prot_Body
: constant Boolean :=
3045 Nkind
(N
) = N_Subprogram_Body
3046 and then Is_Protected_Subprogram_Body
(N
);
3047 -- Determine whether N denotes the protected version of a subprogram
3048 -- which belongs to a protected type.
3050 Loc
: constant Source_Ptr
:= Sloc
(N
);
3054 -- Do not perform this expansion in SPARK mode because we do not create
3055 -- finalizers in the first place.
3057 if GNATprove_Mode
then
3061 -- The At_End handler should have been assimilated by the finalizer
3063 HSS
:= Handled_Statement_Sequence
(N
);
3064 pragma Assert
(No
(At_End_Proc
(HSS
)));
3066 -- If the construct to be cleaned up is a protected subprogram body, the
3067 -- finalizer call needs to be associated with the block which wraps the
3068 -- unprotected version of the subprogram. The following illustrates this
3071 -- procedure Prot_SubpP is
3072 -- procedure finalizer is
3074 -- Service_Entries (Prot_Obj);
3081 -- Prot_SubpN (Prot_Obj);
3087 if Is_Prot_Body
then
3088 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3090 -- An At_End handler and regular exception handlers cannot coexist in
3091 -- the same statement sequence. Wrap the original statements in a block.
3093 elsif Present
(Exception_Handlers
(HSS
)) then
3095 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3100 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3102 Set_Handled_Statement_Sequence
(N
,
3103 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3105 HSS
:= Handled_Statement_Sequence
(N
);
3106 Set_End_Label
(HSS
, End_Lab
);
3110 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3112 Analyze
(At_End_Proc
(HSS
));
3113 Expand_At_End_Handler
(HSS
, Empty
);
3114 end Build_Finalizer_Call
;
3116 ---------------------
3117 -- Build_Late_Proc --
3118 ---------------------
3120 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3122 for Final_Prim
in Name_Of
'Range loop
3123 if Name_Of
(Final_Prim
) = Nam
then
3126 (Prim
=> Final_Prim
,
3128 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3131 end Build_Late_Proc
;
3133 -------------------------------
3134 -- Build_Object_Declarations --
3135 -------------------------------
3137 procedure Build_Object_Declarations
3138 (Data
: out Finalization_Exception_Data
;
3141 For_Package
: Boolean := False)
3146 -- This variable captures an unused dummy internal entity, see the
3147 -- comment associated with its use.
3150 pragma Assert
(Decls
/= No_List
);
3152 -- Always set the proper location as it may be needed even when
3153 -- exception propagation is forbidden.
3157 if Restriction_Active
(No_Exception_Propagation
) then
3158 Data
.Abort_Id
:= Empty
;
3160 Data
.Raised_Id
:= Empty
;
3164 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3166 -- In certain scenarios, finalization can be triggered by an abort. If
3167 -- the finalization itself fails and raises an exception, the resulting
3168 -- Program_Error must be supressed and replaced by an abort signal. In
3169 -- order to detect this scenario, save the state of entry into the
3170 -- finalization code.
3172 -- No need to do this for VM case, since VM version of Ada.Exceptions
3173 -- does not include routine Raise_From_Controlled_Operation which is the
3174 -- the sole user of flag Abort.
3176 -- This is not needed for library-level finalizers as they are called by
3177 -- the environment task and cannot be aborted.
3179 if VM_Target
= No_VM
and then not For_Package
then
3180 if Abort_Allowed
then
3181 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3184 -- Abort_Id : constant Boolean := <A_Expr>;
3187 Make_Object_Declaration
(Loc
,
3188 Defining_Identifier
=> Data
.Abort_Id
,
3189 Constant_Present
=> True,
3190 Object_Definition
=>
3191 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3193 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3195 -- Abort is not required
3198 -- Generate a dummy entity to ensure that the internal symbols are
3199 -- in sync when a unit is compiled with and without aborts.
3201 Dummy
:= Make_Temporary
(Loc
, 'A');
3202 Data
.Abort_Id
:= Empty
;
3205 -- .NET/JVM or library-level finalizers
3208 Data
.Abort_Id
:= Empty
;
3211 if Exception_Extra_Info
then
3212 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3215 -- E_Id : Exception_Occurrence;
3218 Make_Object_Declaration
(Loc
,
3219 Defining_Identifier
=> Data
.E_Id
,
3220 Object_Definition
=>
3221 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3222 Set_No_Initialization
(Decl
);
3224 Append_To
(Decls
, Decl
);
3231 -- Raised_Id : Boolean := False;
3234 Make_Object_Declaration
(Loc
,
3235 Defining_Identifier
=> Data
.Raised_Id
,
3236 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3237 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3238 end Build_Object_Declarations
;
3240 ---------------------------
3241 -- Build_Raise_Statement --
3242 ---------------------------
3244 function Build_Raise_Statement
3245 (Data
: Finalization_Exception_Data
) return Node_Id
3251 -- Standard run-time and .NET/JVM targets use the specialized routine
3252 -- Raise_From_Controlled_Operation.
3254 if Exception_Extra_Info
3255 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3258 Make_Procedure_Call_Statement
(Data
.Loc
,
3261 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3262 Parameter_Associations
=>
3263 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3265 -- Restricted run-time: exception messages are not supported and hence
3266 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3271 Make_Raise_Program_Error
(Data
.Loc
,
3272 Reason
=> PE_Finalize_Raised_Exception
);
3277 -- Raised_Id and then not Abort_Id
3281 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3283 if Present
(Data
.Abort_Id
) then
3284 Expr
:= Make_And_Then
(Data
.Loc
,
3287 Make_Op_Not
(Data
.Loc
,
3288 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3293 -- if Raised_Id and then not Abort_Id then
3294 -- Raise_From_Controlled_Operation (E_Id);
3296 -- raise Program_Error; -- restricted runtime
3300 Make_If_Statement
(Data
.Loc
,
3302 Then_Statements
=> New_List
(Stmt
));
3303 end Build_Raise_Statement
;
3305 -----------------------------
3306 -- Build_Record_Deep_Procs --
3307 -----------------------------
3309 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3313 (Prim
=> Initialize_Case
,
3315 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3317 if not Is_Limited_View
(Typ
) then
3320 (Prim
=> Adjust_Case
,
3322 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3325 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3326 -- suppressed since these routine will not be used.
3328 if not Restriction_Active
(No_Finalization
) then
3331 (Prim
=> Finalize_Case
,
3333 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3335 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3336 -- .NET do not support address arithmetic and unchecked conversions.
3338 if VM_Target
= No_VM
then
3341 (Prim
=> Address_Case
,
3343 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3346 end Build_Record_Deep_Procs
;
3352 function Cleanup_Array
3355 Typ
: Entity_Id
) return List_Id
3357 Loc
: constant Source_Ptr
:= Sloc
(N
);
3358 Index_List
: constant List_Id
:= New_List
;
3360 function Free_Component
return List_Id
;
3361 -- Generate the code to finalize the task or protected subcomponents
3362 -- of a single component of the array.
3364 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3365 -- Generate a loop over one dimension of the array
3367 --------------------
3368 -- Free_Component --
3369 --------------------
3371 function Free_Component
return List_Id
is
3372 Stmts
: List_Id
:= New_List
;
3374 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3377 -- Component type is known to contain tasks or protected objects
3380 Make_Indexed_Component
(Loc
,
3381 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3382 Expressions
=> Index_List
);
3384 Set_Etype
(Tsk
, C_Typ
);
3386 if Is_Task_Type
(C_Typ
) then
3387 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3389 elsif Is_Simple_Protected_Type
(C_Typ
) then
3390 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3392 elsif Is_Record_Type
(C_Typ
) then
3393 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3395 elsif Is_Array_Type
(C_Typ
) then
3396 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3402 ------------------------
3403 -- Free_One_Dimension --
3404 ------------------------
3406 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3410 if Dim
> Number_Dimensions
(Typ
) then
3411 return Free_Component
;
3413 -- Here we generate the required loop
3416 Index
:= Make_Temporary
(Loc
, 'J');
3417 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3420 Make_Implicit_Loop_Statement
(N
,
3421 Identifier
=> Empty
,
3423 Make_Iteration_Scheme
(Loc
,
3424 Loop_Parameter_Specification
=>
3425 Make_Loop_Parameter_Specification
(Loc
,
3426 Defining_Identifier
=> Index
,
3427 Discrete_Subtype_Definition
=>
3428 Make_Attribute_Reference
(Loc
,
3429 Prefix
=> Duplicate_Subexpr
(Obj
),
3430 Attribute_Name
=> Name_Range
,
3431 Expressions
=> New_List
(
3432 Make_Integer_Literal
(Loc
, Dim
))))),
3433 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3435 end Free_One_Dimension
;
3437 -- Start of processing for Cleanup_Array
3440 return Free_One_Dimension
(1);
3443 --------------------
3444 -- Cleanup_Record --
3445 --------------------
3447 function Cleanup_Record
3450 Typ
: Entity_Id
) return List_Id
3452 Loc
: constant Source_Ptr
:= Sloc
(N
);
3455 Stmts
: constant List_Id
:= New_List
;
3456 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3459 if Has_Discriminants
(U_Typ
)
3460 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3461 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3464 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3466 -- For now, do not attempt to free a component that may appear in a
3467 -- variant, and instead issue a warning. Doing this "properly" would
3468 -- require building a case statement and would be quite a mess. Note
3469 -- that the RM only requires that free "work" for the case of a task
3470 -- access value, so already we go way beyond this in that we deal
3471 -- with the array case and non-discriminated record cases.
3474 ("task/protected object in variant record will not be freed??", N
);
3475 return New_List
(Make_Null_Statement
(Loc
));
3478 Comp
:= First_Component
(Typ
);
3479 while Present
(Comp
) loop
3480 if Has_Task
(Etype
(Comp
))
3481 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3484 Make_Selected_Component
(Loc
,
3485 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3486 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3487 Set_Etype
(Tsk
, Etype
(Comp
));
3489 if Is_Task_Type
(Etype
(Comp
)) then
3490 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3492 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3493 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3495 elsif Is_Record_Type
(Etype
(Comp
)) then
3497 -- Recurse, by generating the prefix of the argument to
3498 -- the eventual cleanup call.
3500 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3502 elsif Is_Array_Type
(Etype
(Comp
)) then
3503 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3507 Next_Component
(Comp
);
3513 ------------------------------
3514 -- Cleanup_Protected_Object --
3515 ------------------------------
3517 function Cleanup_Protected_Object
3519 Ref
: Node_Id
) return Node_Id
3521 Loc
: constant Source_Ptr
:= Sloc
(N
);
3524 -- For restricted run-time libraries (Ravenscar), tasks are
3525 -- non-terminating, and protected objects can only appear at library
3526 -- level, so we do not want finalization of protected objects.
3528 if Restricted_Profile
then
3533 Make_Procedure_Call_Statement
(Loc
,
3535 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3536 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3538 end Cleanup_Protected_Object
;
3544 function Cleanup_Task
3546 Ref
: Node_Id
) return Node_Id
3548 Loc
: constant Source_Ptr
:= Sloc
(N
);
3551 -- For restricted run-time libraries (Ravenscar), tasks are
3552 -- non-terminating and they can only appear at library level, so we do
3553 -- not want finalization of task objects.
3555 if Restricted_Profile
then
3560 Make_Procedure_Call_Statement
(Loc
,
3562 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3563 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3567 ------------------------------
3568 -- Check_Visibly_Controlled --
3569 ------------------------------
3571 procedure Check_Visibly_Controlled
3572 (Prim
: Final_Primitives
;
3574 E
: in out Entity_Id
;
3575 Cref
: in out Node_Id
)
3577 Parent_Type
: Entity_Id
;
3581 if Is_Derived_Type
(Typ
)
3582 and then Comes_From_Source
(E
)
3583 and then not Present
(Overridden_Operation
(E
))
3585 -- We know that the explicit operation on the type does not override
3586 -- the inherited operation of the parent, and that the derivation
3587 -- is from a private type that is not visibly controlled.
3589 Parent_Type
:= Etype
(Typ
);
3590 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3592 if Present
(Op
) then
3595 -- Wrap the object to be initialized into the proper
3596 -- unchecked conversion, to be compatible with the operation
3599 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3600 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3602 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3606 end Check_Visibly_Controlled
;
3608 -------------------------------
3609 -- CW_Or_Has_Controlled_Part --
3610 -------------------------------
3612 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3614 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3615 end CW_Or_Has_Controlled_Part
;
3621 function Convert_View
3624 Ind
: Pos
:= 1) return Node_Id
3626 Fent
: Entity_Id
:= First_Entity
(Proc
);
3631 for J
in 2 .. Ind
loop
3635 Ftyp
:= Etype
(Fent
);
3637 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3638 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3640 Atyp
:= Etype
(Arg
);
3643 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3644 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3647 and then Present
(Atyp
)
3648 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3649 and then Base_Type
(Underlying_Type
(Atyp
)) =
3650 Base_Type
(Underlying_Type
(Ftyp
))
3652 return Unchecked_Convert_To
(Ftyp
, Arg
);
3654 -- If the argument is already a conversion, as generated by
3655 -- Make_Init_Call, set the target type to the type of the formal
3656 -- directly, to avoid spurious typing problems.
3658 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3659 and then not Is_Class_Wide_Type
(Atyp
)
3661 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3662 Set_Etype
(Arg
, Ftyp
);
3670 ------------------------
3671 -- Enclosing_Function --
3672 ------------------------
3674 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3675 Func_Id
: Entity_Id
;
3679 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
3680 if Ekind
(Func_Id
) = E_Function
then
3684 Func_Id
:= Scope
(Func_Id
);
3688 end Enclosing_Function
;
3690 -------------------------------
3691 -- Establish_Transient_Scope --
3692 -------------------------------
3694 -- This procedure is called each time a transient block has to be inserted
3695 -- that is to say for each call to a function with unconstrained or tagged
3696 -- result. It creates a new scope on the stack scope in order to enclose
3697 -- all transient variables generated.
3699 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3700 Loc
: constant Source_Ptr
:= Sloc
(N
);
3701 Iter_Loop
: Entity_Id
;
3702 Wrap_Node
: Node_Id
;
3705 -- Do not create a transient scope if we are already inside one
3707 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3708 if Scope_Stack
.Table
(S
).Is_Transient
then
3710 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3715 -- If we encounter Standard there are no enclosing transient scopes
3717 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3722 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3724 -- The context does not contain a node that requires a transient scope,
3727 if No
(Wrap_Node
) then
3730 -- If the node to wrap is an iteration_scheme, the expression is one of
3731 -- the bounds, and the expansion will make an explicit declaration for
3732 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3733 -- transformations here. Same for an Ada 2012 iterator specification,
3734 -- where a block is created for the expression that build the container.
3736 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3737 N_Iterator_Specification
)
3741 -- In formal verification mode, if the node to wrap is a pragma check,
3742 -- this node and enclosed expression are not expanded, so do not apply
3743 -- any transformations here.
3745 elsif GNATprove_Mode
3746 and then Nkind
(Wrap_Node
) = N_Pragma
3747 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3751 -- Create a block entity to act as a transient scope. Note that when the
3752 -- node to be wrapped is an expression or a statement, a real physical
3753 -- block is constructed (see routines Wrap_Transient_Expression and
3754 -- Wrap_Transient_Statement) and inserted into the tree.
3757 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3758 Set_Scope_Is_Transient
;
3760 -- The transient scope must also take care of the secondary stack
3764 Set_Uses_Sec_Stack
(Current_Scope
);
3765 Check_Restriction
(No_Secondary_Stack
, N
);
3767 -- The expansion of iterator loops generates references to objects
3768 -- in order to extract elements from a container:
3770 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3771 -- Obj : <object type> renames Ref.all.Element.all;
3773 -- These references are controlled and returned on the secondary
3774 -- stack. A new reference is created at each iteration of the loop
3775 -- and as a result it must be finalized and the space occupied by
3776 -- it on the secondary stack reclaimed at the end of the current
3779 -- When the context that requires a transient scope is a call to
3780 -- routine Reference, the node to be wrapped is the source object:
3782 -- for Obj of Container loop
3784 -- Routine Wrap_Transient_Declaration however does not generate a
3785 -- physical block as wrapping a declaration will kill it too ealy.
3786 -- To handle this peculiar case, mark the related iterator loop as
3787 -- requiring the secondary stack. This signals the finalization
3788 -- machinery to manage the secondary stack (see routine
3789 -- Process_Statements_For_Controlled_Objects).
3791 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
3793 if Present
(Iter_Loop
) then
3794 Set_Uses_Sec_Stack
(Iter_Loop
);
3798 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3799 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3801 if Debug_Flag_W
then
3802 Write_Str
(" <Transient>");
3806 end Establish_Transient_Scope
;
3808 ----------------------------
3809 -- Expand_Cleanup_Actions --
3810 ----------------------------
3812 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3813 Scop
: constant Entity_Id
:= Current_Scope
;
3815 Is_Asynchronous_Call
: constant Boolean :=
3816 Nkind
(N
) = N_Block_Statement
3817 and then Is_Asynchronous_Call_Block
(N
);
3818 Is_Master
: constant Boolean :=
3819 Nkind
(N
) /= N_Entry_Body
3820 and then Is_Task_Master
(N
);
3821 Is_Protected_Body
: constant Boolean :=
3822 Nkind
(N
) = N_Subprogram_Body
3823 and then Is_Protected_Subprogram_Body
(N
);
3824 Is_Task_Allocation
: constant Boolean :=
3825 Nkind
(N
) = N_Block_Statement
3826 and then Is_Task_Allocation_Block
(N
);
3827 Is_Task_Body
: constant Boolean :=
3828 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3829 Needs_Sec_Stack_Mark
: constant Boolean :=
3830 Uses_Sec_Stack
(Scop
)
3832 not Sec_Stack_Needed_For_Return
(Scop
)
3833 and then VM_Target
= No_VM
;
3834 Needs_Custom_Cleanup
: constant Boolean :=
3835 Nkind
(N
) = N_Block_Statement
3836 and then Present
(Cleanup_Actions
(N
));
3838 Actions_Required
: constant Boolean :=
3839 Requires_Cleanup_Actions
(N
, True)
3840 or else Is_Asynchronous_Call
3842 or else Is_Protected_Body
3843 or else Is_Task_Allocation
3844 or else Is_Task_Body
3845 or else Needs_Sec_Stack_Mark
3846 or else Needs_Custom_Cleanup
;
3848 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3852 procedure Wrap_HSS_In_Block
;
3853 -- Move HSS inside a new block along with the original exception
3854 -- handlers. Make the newly generated block the sole statement of HSS.
3856 -----------------------
3857 -- Wrap_HSS_In_Block --
3858 -----------------------
3860 procedure Wrap_HSS_In_Block
is
3865 -- Preserve end label to provide proper cross-reference information
3867 End_Lab
:= End_Label
(HSS
);
3869 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3871 -- Signal the finalization machinery that this particular block
3872 -- contains the original context.
3874 Set_Is_Finalization_Wrapper
(Block
);
3876 Set_Handled_Statement_Sequence
(N
,
3877 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3878 HSS
:= Handled_Statement_Sequence
(N
);
3880 Set_First_Real_Statement
(HSS
, Block
);
3881 Set_End_Label
(HSS
, End_Lab
);
3883 -- Comment needed here, see RH for 1.306 ???
3885 if Nkind
(N
) = N_Subprogram_Body
then
3886 Set_Has_Nested_Block_With_Handler
(Scop
);
3888 end Wrap_HSS_In_Block
;
3890 -- Start of processing for Expand_Cleanup_Actions
3893 -- The current construct does not need any form of servicing
3895 if not Actions_Required
then
3898 -- If the current node is a rewritten task body and the descriptors have
3899 -- not been delayed (due to some nested instantiations), do not generate
3900 -- redundant cleanup actions.
3903 and then Nkind
(N
) = N_Subprogram_Body
3904 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3909 if Needs_Custom_Cleanup
then
3910 Cln
:= Cleanup_Actions
(N
);
3916 Decls
: List_Id
:= Declarations
(N
);
3918 Mark
: Entity_Id
:= Empty
;
3919 New_Decls
: List_Id
;
3923 -- If we are generating expanded code for debugging purposes, use the
3924 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3925 -- be updated subsequently to reference the proper line in .dg files.
3926 -- If we are not debugging generated code, use No_Location instead,
3927 -- so that no debug information is generated for the cleanup code.
3928 -- This makes the behavior of the NEXT command in GDB monotonic, and
3929 -- makes the placement of breakpoints more accurate.
3931 if Debug_Generated_Code
then
3937 -- Set polling off. The finalization and cleanup code is executed
3938 -- with aborts deferred.
3940 Old_Poll
:= Polling_Required
;
3941 Polling_Required
:= False;
3943 -- A task activation call has already been built for a task
3944 -- allocation block.
3946 if not Is_Task_Allocation
then
3947 Build_Task_Activation_Call
(N
);
3951 Establish_Task_Master
(N
);
3954 New_Decls
:= New_List
;
3956 -- If secondary stack is in use, generate:
3958 -- Mnn : constant Mark_Id := SS_Mark;
3960 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3961 -- secondary stack is never used on a VM.
3963 if Needs_Sec_Stack_Mark
then
3964 Mark
:= Make_Temporary
(Loc
, 'M');
3966 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
3967 Set_Uses_Sec_Stack
(Scop
, False);
3970 -- If exception handlers are present, wrap the sequence of statements
3971 -- in a block since it is not possible to have exception handlers and
3972 -- an At_End handler in the same construct.
3974 if Present
(Exception_Handlers
(HSS
)) then
3977 -- Ensure that the First_Real_Statement field is set
3979 elsif No
(First_Real_Statement
(HSS
)) then
3980 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3983 -- Do not move the Activation_Chain declaration in the context of
3984 -- task allocation blocks. Task allocation blocks use _chain in their
3985 -- cleanup handlers and gigi complains if it is declared in the
3986 -- sequence of statements of the scope that declares the handler.
3988 if Is_Task_Allocation
then
3990 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3994 Decl
:= First
(Decls
);
3995 while Nkind
(Decl
) /= N_Object_Declaration
3996 or else Defining_Identifier
(Decl
) /= Chain
4000 -- A task allocation block should always include a _chain
4003 pragma Assert
(Present
(Decl
));
4007 Prepend_To
(New_Decls
, Decl
);
4011 -- Ensure the presence of a declaration list in order to successfully
4012 -- append all original statements to it.
4015 Set_Declarations
(N
, New_List
);
4016 Decls
:= Declarations
(N
);
4019 -- Move the declarations into the sequence of statements in order to
4020 -- have them protected by the At_End handler. It may seem weird to
4021 -- put declarations in the sequence of statement but in fact nothing
4022 -- forbids that at the tree level.
4024 Append_List_To
(Decls
, Statements
(HSS
));
4025 Set_Statements
(HSS
, Decls
);
4027 -- Reset the Sloc of the handled statement sequence to properly
4028 -- reflect the new initial "statement" in the sequence.
4030 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4032 -- The declarations of finalizer spec and auxiliary variables replace
4033 -- the old declarations that have been moved inward.
4035 Set_Declarations
(N
, New_Decls
);
4036 Analyze_Declarations
(New_Decls
);
4038 -- Generate finalization calls for all controlled objects appearing
4039 -- in the statements of N. Add context specific cleanup for various
4044 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4046 Top_Decls
=> New_Decls
,
4047 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4051 if Present
(Fin_Id
) then
4052 Build_Finalizer_Call
(N
, Fin_Id
);
4055 -- Restore saved polling mode
4057 Polling_Required
:= Old_Poll
;
4059 end Expand_Cleanup_Actions
;
4061 ---------------------------
4062 -- Expand_N_Package_Body --
4063 ---------------------------
4065 -- Add call to Activate_Tasks if body is an activator (actual processing
4066 -- is in chapter 9).
4068 -- Generate subprogram descriptor for elaboration routine
4070 -- Encode entity names in package body
4072 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4073 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
4077 -- This is done only for non-generic packages
4079 if Ekind
(Spec_Ent
) = E_Package
then
4080 Push_Scope
(Corresponding_Spec
(N
));
4082 -- Build dispatch tables of library level tagged types
4084 if Tagged_Type_Expansion
4085 and then Is_Library_Level_Entity
(Spec_Ent
)
4087 Build_Static_Dispatch_Tables
(N
);
4090 Build_Task_Activation_Call
(N
);
4092 -- When the package is subject to pragma Initial_Condition, the
4093 -- assertion expression must be verified at the end of the body
4096 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
4097 Expand_Pragma_Initial_Condition
(N
);
4103 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4104 Set_In_Package_Body
(Spec_Ent
, False);
4106 -- Set to encode entity names in package body before gigi is called
4108 Qualify_Entity_Names
(N
);
4110 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
4113 Clean_Stmts
=> No_List
,
4115 Top_Decls
=> No_List
,
4116 Defer_Abort
=> False,
4119 if Present
(Fin_Id
) then
4121 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4124 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4125 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4128 Set_Finalizer
(Body_Ent
, Fin_Id
);
4132 end Expand_N_Package_Body
;
4134 ----------------------------------
4135 -- Expand_N_Package_Declaration --
4136 ----------------------------------
4138 -- Add call to Activate_Tasks if there are tasks declared and the package
4139 -- has no body. Note that in Ada 83 this may result in premature activation
4140 -- of some tasks, given that we cannot tell whether a body will eventually
4143 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4144 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4145 Spec
: constant Node_Id
:= Specification
(N
);
4149 No_Body
: Boolean := False;
4150 -- True in the case of a package declaration that is a compilation
4151 -- unit and for which no associated body will be compiled in this
4155 -- Case of a package declaration other than a compilation unit
4157 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4160 -- Case of a compilation unit that does not require a body
4162 elsif not Body_Required
(Parent
(N
))
4163 and then not Unit_Requires_Body
(Id
)
4167 -- Special case of generating calling stubs for a remote call interface
4168 -- package: even though the package declaration requires one, the body
4169 -- won't be processed in this compilation (so any stubs for RACWs
4170 -- declared in the package must be generated here, along with the spec).
4172 elsif Parent
(N
) = Cunit
(Main_Unit
)
4173 and then Is_Remote_Call_Interface
(Id
)
4174 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4179 -- For a nested instance, delay processing until freeze point
4181 if Has_Delayed_Freeze
(Id
)
4182 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4187 -- For a package declaration that implies no associated body, generate
4188 -- task activation call and RACW supporting bodies now (since we won't
4189 -- have a specific separate compilation unit for that).
4194 -- Generate RACW subprogram bodies
4196 if Has_RACW
(Id
) then
4197 Decls
:= Private_Declarations
(Spec
);
4200 Decls
:= Visible_Declarations
(Spec
);
4205 Set_Visible_Declarations
(Spec
, Decls
);
4208 Append_RACW_Bodies
(Decls
, Id
);
4209 Analyze_List
(Decls
);
4212 -- Generate task activation call as last step of elaboration
4214 if Present
(Activation_Chain_Entity
(N
)) then
4215 Build_Task_Activation_Call
(N
);
4218 -- When the package is subject to pragma Initial_Condition and lacks
4219 -- a body, the assertion expression must be verified at the end of
4220 -- the visible declarations. Otherwise the check is performed at the
4221 -- end of the body statements (see Expand_N_Package_Body).
4223 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4224 Expand_Pragma_Initial_Condition
(N
);
4230 -- Build dispatch tables of library level tagged types
4232 if Tagged_Type_Expansion
4233 and then (Is_Compilation_Unit
(Id
)
4234 or else (Is_Generic_Instance
(Id
)
4235 and then Is_Library_Level_Entity
(Id
)))
4237 Build_Static_Dispatch_Tables
(N
);
4240 -- Note: it is not necessary to worry about generating a subprogram
4241 -- descriptor, since the only way to get exception handlers into a
4242 -- package spec is to include instantiations, and that would cause
4243 -- generation of subprogram descriptors to be delayed in any case.
4245 -- Set to encode entity names in package spec before gigi is called
4247 Qualify_Entity_Names
(N
);
4249 if Ekind
(Id
) /= E_Generic_Package
then
4252 Clean_Stmts
=> No_List
,
4254 Top_Decls
=> No_List
,
4255 Defer_Abort
=> False,
4258 Set_Finalizer
(Id
, Fin_Id
);
4260 end Expand_N_Package_Declaration
;
4262 -----------------------------
4263 -- Find_Node_To_Be_Wrapped --
4264 -----------------------------
4266 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4268 The_Parent
: Node_Id
;
4274 case Nkind
(The_Parent
) is
4276 -- Simple statement can be wrapped
4281 -- Usually assignments are good candidate for wrapping except
4282 -- when they have been generated as part of a controlled aggregate
4283 -- where the wrapping should take place more globally. Note that
4284 -- No_Ctrl_Actions may be set also for non-controlled assignements
4285 -- in order to disable the use of dispatching _assign, so we need
4286 -- to test explicitly for a controlled type here.
4288 when N_Assignment_Statement
=>
4289 if No_Ctrl_Actions
(The_Parent
)
4290 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4297 -- An entry call statement is a special case if it occurs in the
4298 -- context of a Timed_Entry_Call. In this case we wrap the entire
4299 -- timed entry call.
4301 when N_Entry_Call_Statement |
4302 N_Procedure_Call_Statement
=>
4303 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4304 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4306 N_Conditional_Entry_Call
)
4308 return Parent
(Parent
(The_Parent
));
4313 -- Object declarations are also a boundary for the transient scope
4314 -- even if they are not really wrapped. For further details, see
4315 -- Wrap_Transient_Declaration.
4317 when N_Object_Declaration |
4318 N_Object_Renaming_Declaration |
4319 N_Subtype_Declaration
=>
4322 -- The expression itself is to be wrapped if its parent is a
4323 -- compound statement or any other statement where the expression
4324 -- is known to be scalar.
4326 when N_Accept_Alternative |
4327 N_Attribute_Definition_Clause |
4330 N_Delay_Alternative |
4331 N_Delay_Until_Statement |
4332 N_Delay_Relative_Statement |
4333 N_Discriminant_Association |
4335 N_Entry_Body_Formal_Part |
4338 N_Iteration_Scheme |
4339 N_Terminate_Alternative
=>
4340 pragma Assert
(Present
(P
));
4343 when N_Attribute_Reference
=>
4345 if Is_Procedure_Attribute_Name
4346 (Attribute_Name
(The_Parent
))
4351 -- A raise statement can be wrapped. This will arise when the
4352 -- expression in a raise_with_expression uses the secondary
4353 -- stack, for example.
4355 when N_Raise_Statement
=>
4358 -- If the expression is within the iteration scheme of a loop,
4359 -- we must create a declaration for it, followed by an assignment
4360 -- in order to have a usable statement to wrap.
4362 when N_Loop_Parameter_Specification
=>
4363 return Parent
(The_Parent
);
4365 -- The following nodes contains "dummy calls" which don't need to
4368 when N_Parameter_Specification |
4369 N_Discriminant_Specification |
4370 N_Component_Declaration
=>
4373 -- The return statement is not to be wrapped when the function
4374 -- itself needs wrapping at the outer-level
4376 when N_Simple_Return_Statement
=>
4378 Applies_To
: constant Entity_Id
:=
4380 (Return_Statement_Entity
(The_Parent
));
4381 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4383 if Requires_Transient_Scope
(Return_Type
) then
4390 -- If we leave a scope without having been able to find a node to
4391 -- wrap, something is going wrong but this can happen in error
4392 -- situation that are not detected yet (such as a dynamic string
4393 -- in a pragma export)
4395 when N_Subprogram_Body |
4396 N_Package_Declaration |
4398 N_Block_Statement
=>
4401 -- Otherwise continue the search
4408 The_Parent
:= Parent
(P
);
4410 end Find_Node_To_Be_Wrapped
;
4412 ----------------------------------
4413 -- Has_New_Controlled_Component --
4414 ----------------------------------
4416 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4420 if not Is_Tagged_Type
(E
) then
4421 return Has_Controlled_Component
(E
);
4422 elsif not Is_Derived_Type
(E
) then
4423 return Has_Controlled_Component
(E
);
4426 Comp
:= First_Component
(E
);
4427 while Present
(Comp
) loop
4428 if Chars
(Comp
) = Name_uParent
then
4431 elsif Scope
(Original_Record_Component
(Comp
)) = E
4432 and then Needs_Finalization
(Etype
(Comp
))
4437 Next_Component
(Comp
);
4441 end Has_New_Controlled_Component
;
4443 ---------------------------------
4444 -- Has_Simple_Protected_Object --
4445 ---------------------------------
4447 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4449 if Has_Task
(T
) then
4452 elsif Is_Simple_Protected_Type
(T
) then
4455 elsif Is_Array_Type
(T
) then
4456 return Has_Simple_Protected_Object
(Component_Type
(T
));
4458 elsif Is_Record_Type
(T
) then
4463 Comp
:= First_Component
(T
);
4464 while Present
(Comp
) loop
4465 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4469 Next_Component
(Comp
);
4478 end Has_Simple_Protected_Object
;
4480 ------------------------------------
4481 -- Insert_Actions_In_Scope_Around --
4482 ------------------------------------
4484 procedure Insert_Actions_In_Scope_Around
4487 Manage_SS
: Boolean)
4489 Act_Before
: constant List_Id
:=
4490 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4491 Act_After
: constant List_Id
:=
4492 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4493 Act_Cleanup
: constant List_Id
:=
4494 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4495 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4496 -- Last), but this was incorrect as Process_Transient_Object may
4497 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4499 procedure Process_Transient_Objects
4500 (First_Object
: Node_Id
;
4501 Last_Object
: Node_Id
;
4502 Related_Node
: Node_Id
);
4503 -- First_Object and Last_Object define a list which contains potential
4504 -- controlled transient objects. Finalization flags are inserted before
4505 -- First_Object and finalization calls are inserted after Last_Object.
4506 -- Related_Node is the node for which transient objects have been
4509 -------------------------------
4510 -- Process_Transient_Objects --
4511 -------------------------------
4513 procedure Process_Transient_Objects
4514 (First_Object
: Node_Id
;
4515 Last_Object
: Node_Id
;
4516 Related_Node
: Node_Id
)
4518 Must_Hook
: Boolean := False;
4519 -- Flag denoting whether the context requires transient variable
4520 -- export to the outer finalizer.
4522 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4523 -- Determine whether an arbitrary node denotes a subprogram call
4525 procedure Detect_Subprogram_Call
is
4526 new Traverse_Proc
(Is_Subprogram_Call
);
4528 ------------------------
4529 -- Is_Subprogram_Call --
4530 ------------------------
4532 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4534 -- Complex constructs are factored out by the expander and their
4535 -- occurrences are replaced with references to temporaries or
4536 -- object renamings. Due to this expansion activity, inspect the
4537 -- original tree to detect subprogram calls.
4539 if Nkind_In
(N
, N_Identifier
,
4540 N_Object_Renaming_Declaration
)
4541 and then Original_Node
(N
) /= N
4543 Detect_Subprogram_Call
(Original_Node
(N
));
4545 -- The original construct contains a subprogram call, there is
4546 -- no point in continuing the tree traversal.
4554 -- The original construct contains a subprogram call, there is no
4555 -- point in continuing the tree traversal.
4557 elsif Nkind
(N
) = N_Object_Declaration
4558 and then Present
(Expression
(N
))
4559 and then Nkind
(Original_Node
(Expression
(N
))) = N_Function_Call
4564 -- A regular procedure or function call
4566 elsif Nkind
(N
) in N_Subprogram_Call
then
4575 end Is_Subprogram_Call
;
4579 Built
: Boolean := False;
4580 Desig_Typ
: Entity_Id
;
4582 Fin_Block
: Node_Id
;
4583 Fin_Data
: Finalization_Exception_Data
;
4584 Fin_Decls
: List_Id
;
4585 Fin_Insrt
: Node_Id
;
4586 Last_Fin
: Node_Id
:= Empty
;
4590 Obj_Typ
: Entity_Id
;
4591 Prev_Fin
: Node_Id
:= Empty
;
4595 Temp_Id
: Entity_Id
;
4598 -- Start of processing for Process_Transient_Objects
4601 -- Recognize a scenario where the transient context is an object
4602 -- declaration initialized by a build-in-place function call:
4604 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4606 -- The rough expansion of the above is:
4608 -- Temp : ... := Ctrl_Func_Call;
4610 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4612 -- The finalization of any controlled transient must happen after
4613 -- the build-in-place function call is executed.
4615 if Nkind
(N
) = N_Object_Declaration
4616 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
4619 Fin_Insrt
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
4621 -- Search the context for at least one subprogram call. If found, the
4622 -- machinery exports all transient objects to the enclosing finalizer
4623 -- due to the possibility of abnormal call termination.
4626 Detect_Subprogram_Call
(N
);
4627 Fin_Insrt
:= Last_Object
;
4630 -- Examine all objects in the list First_Object .. Last_Object
4632 Stmt
:= First_Object
;
4633 while Present
(Stmt
) loop
4634 if Nkind
(Stmt
) = N_Object_Declaration
4635 and then Analyzed
(Stmt
)
4636 and then Is_Finalizable_Transient
(Stmt
, N
)
4638 -- Do not process the node to be wrapped since it will be
4639 -- handled by the enclosing finalizer.
4641 and then Stmt
/= Related_Node
4644 Obj_Id
:= Defining_Identifier
(Stmt
);
4645 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4646 Desig_Typ
:= Obj_Typ
;
4648 Set_Is_Processed_Transient
(Obj_Id
);
4650 -- Handle access types
4652 if Is_Access_Type
(Desig_Typ
) then
4653 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4656 -- Create the necessary entities and declarations the first
4661 Fin_Decls
:= New_List
;
4663 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4666 -- Transient variables associated with subprogram calls need
4667 -- extra processing. These variables are usually created right
4668 -- before the call and finalized immediately after the call.
4669 -- If an exception occurs during the call, the clean up code
4670 -- is skipped due to the sudden change in control and the
4671 -- transient is never finalized.
4673 -- To handle this case, such variables are "exported" to the
4674 -- enclosing sequence of statements where their corresponding
4675 -- "hooks" are picked up by the finalization machinery.
4679 -- Step 1: Create an access type which provides a reference
4680 -- to the transient object. Generate:
4682 -- Ann : access [all] <Desig_Typ>;
4684 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4686 Insert_Action
(Stmt
,
4687 Make_Full_Type_Declaration
(Loc
,
4688 Defining_Identifier
=> Ptr_Id
,
4690 Make_Access_To_Object_Definition
(Loc
,
4692 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4693 Subtype_Indication
=>
4694 New_Occurrence_Of
(Desig_Typ
, Loc
))));
4696 -- Step 2: Create a temporary which acts as a hook to the
4697 -- transient object. Generate:
4699 -- Temp : Ptr_Id := null;
4701 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4703 Insert_Action
(Stmt
,
4704 Make_Object_Declaration
(Loc
,
4705 Defining_Identifier
=> Temp_Id
,
4706 Object_Definition
=>
4707 New_Occurrence_Of
(Ptr_Id
, Loc
)));
4709 -- Mark the temporary as a transient hook. This signals the
4710 -- machinery in Build_Finalizer to recognize this special
4713 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4715 -- Step 3: Hook the transient object to the temporary
4717 if Is_Access_Type
(Obj_Typ
) then
4719 Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
4722 Make_Attribute_Reference
(Loc
,
4723 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
4724 Attribute_Name
=> Name_Unrestricted_Access
);
4728 -- Temp := Ptr_Id (Obj_Id);
4730 -- Temp := Obj_Id'Unrestricted_Access;
4732 -- When the transient object is initialized by an aggregate,
4733 -- the hook must capture the object after the last component
4734 -- assignment takes place. Only then is the object fully
4737 if Ekind
(Obj_Id
) = E_Variable
4738 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
4740 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
4742 -- Otherwise the hook seizes the related object immediately
4748 Insert_After_And_Analyze
(Temp_Ins
,
4749 Make_Assignment_Statement
(Loc
,
4750 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4751 Expression
=> Expr
));
4756 -- The transient object is about to be finalized by the clean
4757 -- up code following the subprogram call. In order to avoid
4758 -- double finalization, clear the hook.
4765 Make_Assignment_Statement
(Loc
,
4766 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4767 Expression
=> Make_Null
(Loc
)));
4771 -- [Deep_]Finalize (Obj_Ref);
4773 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
4775 if Is_Access_Type
(Obj_Typ
) then
4776 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4780 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4785 -- [Deep_]Finalize (Obj_Ref);
4789 -- if not Raised then
4792 -- (Enn, Get_Current_Excep.all.all);
4797 Make_Block_Statement
(Loc
,
4798 Handled_Statement_Sequence
=>
4799 Make_Handled_Sequence_Of_Statements
(Loc
,
4800 Statements
=> Stmts
,
4801 Exception_Handlers
=> New_List
(
4802 Build_Exception_Handler
(Fin_Data
))));
4804 -- The single raise statement must be inserted after all the
4805 -- finalization blocks, and we put everything into a wrapper
4806 -- block to clearly expose the construct to the back-end.
4808 if Present
(Prev_Fin
) then
4809 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4811 Insert_After_And_Analyze
(Fin_Insrt
,
4812 Make_Block_Statement
(Loc
,
4813 Declarations
=> Fin_Decls
,
4814 Handled_Statement_Sequence
=>
4815 Make_Handled_Sequence_Of_Statements
(Loc
,
4816 Statements
=> New_List
(Fin_Block
))));
4818 Last_Fin
:= Fin_Block
;
4821 Prev_Fin
:= Fin_Block
;
4824 -- Terminate the scan after the last object has been processed to
4825 -- avoid touching unrelated code.
4827 if Stmt
= Last_Object
then
4835 if Present
(Prev_Fin
) then
4836 Insert_List_Before_And_Analyze
(Prev_Fin
, Act_Cleanup
);
4838 Insert_List_After_And_Analyze
(Fin_Insrt
, Act_Cleanup
);
4843 -- if Raised and then not Abort then
4844 -- Raise_From_Controlled_Operation (E);
4847 if Built
and then Present
(Last_Fin
) then
4848 Insert_After_And_Analyze
(Last_Fin
,
4849 Build_Raise_Statement
(Fin_Data
));
4851 end Process_Transient_Objects
;
4855 Loc
: constant Source_Ptr
:= Sloc
(N
);
4856 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4857 First_Obj
: Node_Id
;
4859 Mark_Id
: Entity_Id
;
4862 -- Start of processing for Insert_Actions_In_Scope_Around
4865 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
4869 -- If the node to be wrapped is the trigger of an asynchronous select,
4870 -- it is not part of a statement list. The actions must be inserted
4871 -- before the select itself, which is part of some list of statements.
4872 -- Note that the triggering alternative includes the triggering
4873 -- statement and an optional statement list. If the node to be
4874 -- wrapped is part of that list, the normal insertion applies.
4876 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4877 and then not Is_List_Member
(Node_To_Wrap
)
4879 Target
:= Parent
(Parent
(Node_To_Wrap
));
4884 First_Obj
:= Target
;
4887 -- Add all actions associated with a transient scope into the main tree.
4888 -- There are several scenarios here:
4890 -- +--- Before ----+ +----- After ---+
4891 -- 1) First_Obj ....... Target ........ Last_Obj
4893 -- 2) First_Obj ....... Target
4895 -- 3) Target ........ Last_Obj
4897 -- Flag declarations are inserted before the first object
4899 if Present
(Act_Before
) then
4900 First_Obj
:= First
(Act_Before
);
4901 Insert_List_Before
(Target
, Act_Before
);
4904 -- Finalization calls are inserted after the last object
4906 if Present
(Act_After
) then
4907 Last_Obj
:= Last
(Act_After
);
4908 Insert_List_After
(Target
, Act_After
);
4911 -- Mark and release the secondary stack when the context warrants it
4914 Mark_Id
:= Make_Temporary
(Loc
, 'M');
4917 -- Mnn : constant Mark_Id := SS_Mark;
4919 Insert_Before_And_Analyze
4920 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
4923 -- SS_Release (Mnn);
4925 Insert_After_And_Analyze
4926 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
4929 -- Check for transient controlled objects associated with Target and
4930 -- generate the appropriate finalization actions for them.
4932 Process_Transient_Objects
4933 (First_Object
=> First_Obj
,
4934 Last_Object
=> Last_Obj
,
4935 Related_Node
=> Target
);
4937 -- Reset the action lists
4940 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
4942 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
4946 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
4948 end Insert_Actions_In_Scope_Around
;
4950 ------------------------------
4951 -- Is_Simple_Protected_Type --
4952 ------------------------------
4954 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4957 Is_Protected_Type
(T
)
4958 and then not Uses_Lock_Free
(T
)
4959 and then not Has_Entries
(T
)
4960 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4961 end Is_Simple_Protected_Type
;
4963 -----------------------
4964 -- Make_Adjust_Call --
4965 -----------------------
4967 function Make_Adjust_Call
4970 Skip_Self
: Boolean := False) return Node_Id
4972 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4973 Adj_Id
: Entity_Id
:= Empty
;
4974 Ref
: Node_Id
:= Obj_Ref
;
4978 -- Recover the proper type which contains Deep_Adjust
4980 if Is_Class_Wide_Type
(Typ
) then
4981 Utyp
:= Root_Type
(Typ
);
4986 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4987 Set_Assignment_OK
(Ref
);
4989 -- Deal with untagged derivation of private views
4991 if Is_Untagged_Derivation
(Typ
) then
4992 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4993 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4994 Set_Assignment_OK
(Ref
);
4997 -- When dealing with the completion of a private type, use the base
5000 if Utyp
/= Base_Type
(Utyp
) then
5001 pragma Assert
(Is_Private_Type
(Typ
));
5003 Utyp
:= Base_Type
(Utyp
);
5004 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5008 if Has_Controlled_Component
(Utyp
) then
5009 if Is_Tagged_Type
(Utyp
) then
5010 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5012 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5016 -- Class-wide types, interfaces and types with controlled components
5018 elsif Is_Class_Wide_Type
(Typ
)
5019 or else Is_Interface
(Typ
)
5020 or else Has_Controlled_Component
(Utyp
)
5022 if Is_Tagged_Type
(Utyp
) then
5023 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5025 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5028 -- Derivations from [Limited_]Controlled
5030 elsif Is_Controlled
(Utyp
) then
5031 if Has_Controlled_Component
(Utyp
) then
5032 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5034 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5039 elsif Is_Tagged_Type
(Utyp
) then
5040 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5043 raise Program_Error
;
5046 if Present
(Adj_Id
) then
5048 -- If the object is unanalyzed, set its expected type for use in
5049 -- Convert_View in case an additional conversion is needed.
5052 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5054 Set_Etype
(Ref
, Typ
);
5057 -- The object reference may need another conversion depending on the
5058 -- type of the formal and that of the actual.
5060 if not Is_Class_Wide_Type
(Typ
) then
5061 Ref
:= Convert_View
(Adj_Id
, Ref
);
5067 Param
=> New_Copy_Tree
(Ref
),
5068 Skip_Self
=> Skip_Self
);
5072 end Make_Adjust_Call
;
5074 ----------------------
5075 -- Make_Attach_Call --
5076 ----------------------
5078 function Make_Attach_Call
5080 Ptr_Typ
: Entity_Id
) return Node_Id
5082 pragma Assert
(VM_Target
/= No_VM
);
5084 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5087 Make_Procedure_Call_Statement
(Loc
,
5089 New_Occurrence_Of
(RTE
(RE_Attach
), Loc
),
5090 Parameter_Associations
=> New_List
(
5091 New_Occurrence_Of
(Finalization_Master
(Ptr_Typ
), Loc
),
5092 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5093 end Make_Attach_Call
;
5095 ----------------------
5096 -- Make_Detach_Call --
5097 ----------------------
5099 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5100 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5104 Make_Procedure_Call_Statement
(Loc
,
5106 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5107 Parameter_Associations
=> New_List
(
5108 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5109 end Make_Detach_Call
;
5117 Proc_Id
: Entity_Id
;
5119 Skip_Self
: Boolean := False) return Node_Id
5121 Params
: constant List_Id
:= New_List
(Param
);
5124 -- Do not apply the controlled action to the object itself by signaling
5125 -- the related routine to avoid self.
5128 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5132 Make_Procedure_Call_Statement
(Loc
,
5133 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5134 Parameter_Associations
=> Params
);
5137 --------------------------
5138 -- Make_Deep_Array_Body --
5139 --------------------------
5141 function Make_Deep_Array_Body
5142 (Prim
: Final_Primitives
;
5143 Typ
: Entity_Id
) return List_Id
5145 function Build_Adjust_Or_Finalize_Statements
5146 (Typ
: Entity_Id
) return List_Id
;
5147 -- Create the statements necessary to adjust or finalize an array of
5148 -- controlled elements. Generate:
5151 -- Abort : constant Boolean := Triggered_By_Abort;
5153 -- Abort : constant Boolean := False; -- no abort
5155 -- E : Exception_Occurrence;
5156 -- Raised : Boolean := False;
5159 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5160 -- ^-- in the finalization case
5162 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5164 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5168 -- if not Raised then
5170 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5177 -- if Raised and then not Abort then
5178 -- Raise_From_Controlled_Operation (E);
5182 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5183 -- Create the statements necessary to initialize an array of controlled
5184 -- elements. Include a mechanism to carry out partial finalization if an
5185 -- exception occurs. Generate:
5188 -- Counter : Integer := 0;
5191 -- for J1 in V'Range (1) loop
5193 -- for JN in V'Range (N) loop
5195 -- [Deep_]Initialize (V (J1, ..., JN));
5197 -- Counter := Counter + 1;
5202 -- Abort : constant Boolean := Triggered_By_Abort;
5204 -- Abort : constant Boolean := False; -- no abort
5205 -- E : Exception_Occurence;
5206 -- Raised : Boolean := False;
5213 -- V'Length (N) - Counter;
5215 -- for F1 in reverse V'Range (1) loop
5217 -- for FN in reverse V'Range (N) loop
5218 -- if Counter > 0 then
5219 -- Counter := Counter - 1;
5222 -- [Deep_]Finalize (V (F1, ..., FN));
5226 -- if not Raised then
5228 -- Save_Occurrence (E,
5229 -- Get_Current_Excep.all.all);
5238 -- if Raised and then not Abort then
5239 -- Raise_From_Controlled_Operation (E);
5248 function New_References_To
5250 Loc
: Source_Ptr
) return List_Id
;
5251 -- Given a list of defining identifiers, return a list of references to
5252 -- the original identifiers, in the same order as they appear.
5254 -----------------------------------------
5255 -- Build_Adjust_Or_Finalize_Statements --
5256 -----------------------------------------
5258 function Build_Adjust_Or_Finalize_Statements
5259 (Typ
: Entity_Id
) return List_Id
5261 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5262 Index_List
: constant List_Id
:= New_List
;
5263 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5264 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5265 Finalizer_Decls
: List_Id
:= No_List
;
5266 Finalizer_Data
: Finalization_Exception_Data
;
5269 Core_Loop
: Node_Id
;
5272 Loop_Id
: Entity_Id
;
5275 Exceptions_OK
: constant Boolean :=
5276 not Restriction_Active
(No_Exception_Propagation
);
5278 procedure Build_Indexes
;
5279 -- Generate the indexes used in the dimension loops
5285 procedure Build_Indexes
is
5287 -- Generate the following identifiers:
5288 -- Jnn - for initialization
5290 for Dim
in 1 .. Num_Dims
loop
5291 Append_To
(Index_List
,
5292 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5296 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5299 Finalizer_Decls
:= New_List
;
5302 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5305 Make_Indexed_Component
(Loc
,
5306 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5307 Expressions
=> New_References_To
(Index_List
, Loc
));
5308 Set_Etype
(Comp_Ref
, Comp_Typ
);
5311 -- [Deep_]Adjust (V (J1, ..., JN))
5313 if Prim
= Adjust_Case
then
5314 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5317 -- [Deep_]Finalize (V (J1, ..., JN))
5319 else pragma Assert
(Prim
= Finalize_Case
);
5320 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5323 -- Generate the block which houses the adjust or finalize call:
5325 -- <adjust or finalize call>; -- No_Exception_Propagation
5327 -- begin -- Exception handlers allowed
5328 -- <adjust or finalize call>
5332 -- if not Raised then
5334 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5338 if Exceptions_OK
then
5340 Make_Block_Statement
(Loc
,
5341 Handled_Statement_Sequence
=>
5342 Make_Handled_Sequence_Of_Statements
(Loc
,
5343 Statements
=> New_List
(Call
),
5344 Exception_Handlers
=> New_List
(
5345 Build_Exception_Handler
(Finalizer_Data
))));
5350 -- Generate the dimension loops starting from the innermost one
5352 -- for Jnn in [reverse] V'Range (Dim) loop
5356 J
:= Last
(Index_List
);
5358 while Present
(J
) and then Dim
> 0 loop
5364 Make_Loop_Statement
(Loc
,
5366 Make_Iteration_Scheme
(Loc
,
5367 Loop_Parameter_Specification
=>
5368 Make_Loop_Parameter_Specification
(Loc
,
5369 Defining_Identifier
=> Loop_Id
,
5370 Discrete_Subtype_Definition
=>
5371 Make_Attribute_Reference
(Loc
,
5372 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5373 Attribute_Name
=> Name_Range
,
5374 Expressions
=> New_List
(
5375 Make_Integer_Literal
(Loc
, Dim
))),
5377 Reverse_Present
=> Prim
= Finalize_Case
)),
5379 Statements
=> New_List
(Core_Loop
),
5380 End_Label
=> Empty
);
5385 -- Generate the block which contains the core loop, the declarations
5386 -- of the abort flag, the exception occurrence, the raised flag and
5387 -- the conditional raise:
5390 -- Abort : constant Boolean := Triggered_By_Abort;
5392 -- Abort : constant Boolean := False; -- no abort
5394 -- E : Exception_Occurrence;
5395 -- Raised : Boolean := False;
5400 -- if Raised and then not Abort then -- Expection handlers OK
5401 -- Raise_From_Controlled_Operation (E);
5405 Stmts
:= New_List
(Core_Loop
);
5407 if Exceptions_OK
then
5409 Build_Raise_Statement
(Finalizer_Data
));
5414 Make_Block_Statement
(Loc
,
5417 Handled_Statement_Sequence
=>
5418 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5419 end Build_Adjust_Or_Finalize_Statements
;
5421 ---------------------------------
5422 -- Build_Initialize_Statements --
5423 ---------------------------------
5425 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5426 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5427 Final_List
: constant List_Id
:= New_List
;
5428 Index_List
: constant List_Id
:= New_List
;
5429 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5430 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5431 Counter_Id
: Entity_Id
;
5435 Final_Block
: Node_Id
;
5436 Final_Loop
: Node_Id
;
5437 Finalizer_Data
: Finalization_Exception_Data
;
5438 Finalizer_Decls
: List_Id
:= No_List
;
5439 Init_Loop
: Node_Id
;
5444 Exceptions_OK
: constant Boolean :=
5445 not Restriction_Active
(No_Exception_Propagation
);
5447 function Build_Counter_Assignment
return Node_Id
;
5448 -- Generate the following assignment:
5449 -- Counter := V'Length (1) *
5451 -- V'Length (N) - Counter;
5453 function Build_Finalization_Call
return Node_Id
;
5454 -- Generate a deep finalization call for an array element
5456 procedure Build_Indexes
;
5457 -- Generate the initialization and finalization indexes used in the
5460 function Build_Initialization_Call
return Node_Id
;
5461 -- Generate a deep initialization call for an array element
5463 ------------------------------
5464 -- Build_Counter_Assignment --
5465 ------------------------------
5467 function Build_Counter_Assignment
return Node_Id
is
5472 -- Start from the first dimension and generate:
5477 Make_Attribute_Reference
(Loc
,
5478 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5479 Attribute_Name
=> Name_Length
,
5480 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5482 -- Process the rest of the dimensions, generate:
5483 -- Expr * V'Length (N)
5486 while Dim
<= Num_Dims
loop
5488 Make_Op_Multiply
(Loc
,
5491 Make_Attribute_Reference
(Loc
,
5492 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5493 Attribute_Name
=> Name_Length
,
5494 Expressions
=> New_List
(
5495 Make_Integer_Literal
(Loc
, Dim
))));
5501 -- Counter := Expr - Counter;
5504 Make_Assignment_Statement
(Loc
,
5505 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5507 Make_Op_Subtract
(Loc
,
5509 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5510 end Build_Counter_Assignment
;
5512 -----------------------------
5513 -- Build_Finalization_Call --
5514 -----------------------------
5516 function Build_Finalization_Call
return Node_Id
is
5517 Comp_Ref
: constant Node_Id
:=
5518 Make_Indexed_Component
(Loc
,
5519 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5520 Expressions
=> New_References_To
(Final_List
, Loc
));
5523 Set_Etype
(Comp_Ref
, Comp_Typ
);
5526 -- [Deep_]Finalize (V);
5528 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5529 end Build_Finalization_Call
;
5535 procedure Build_Indexes
is
5537 -- Generate the following identifiers:
5538 -- Jnn - for initialization
5539 -- Fnn - for finalization
5541 for Dim
in 1 .. Num_Dims
loop
5542 Append_To
(Index_List
,
5543 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5545 Append_To
(Final_List
,
5546 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5550 -------------------------------
5551 -- Build_Initialization_Call --
5552 -------------------------------
5554 function Build_Initialization_Call
return Node_Id
is
5555 Comp_Ref
: constant Node_Id
:=
5556 Make_Indexed_Component
(Loc
,
5557 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5558 Expressions
=> New_References_To
(Index_List
, Loc
));
5561 Set_Etype
(Comp_Ref
, Comp_Typ
);
5564 -- [Deep_]Initialize (V (J1, ..., JN));
5566 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5567 end Build_Initialization_Call
;
5569 -- Start of processing for Build_Initialize_Statements
5572 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5573 Finalizer_Decls
:= New_List
;
5576 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5578 -- Generate the block which houses the finalization call, the index
5579 -- guard and the handler which triggers Program_Error later on.
5581 -- if Counter > 0 then
5582 -- Counter := Counter - 1;
5584 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5586 -- begin -- Exceptions allowed
5587 -- [Deep_]Finalize (V (F1, ..., FN));
5590 -- if not Raised then
5592 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5597 if Exceptions_OK
then
5599 Make_Block_Statement
(Loc
,
5600 Handled_Statement_Sequence
=>
5601 Make_Handled_Sequence_Of_Statements
(Loc
,
5602 Statements
=> New_List
(Build_Finalization_Call
),
5603 Exception_Handlers
=> New_List
(
5604 Build_Exception_Handler
(Finalizer_Data
))));
5606 Fin_Stmt
:= Build_Finalization_Call
;
5609 -- This is the core of the loop, the dimension iterators are added
5610 -- one by one in reverse.
5613 Make_If_Statement
(Loc
,
5616 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5617 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5619 Then_Statements
=> New_List
(
5620 Make_Assignment_Statement
(Loc
,
5621 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5623 Make_Op_Subtract
(Loc
,
5624 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5625 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5627 Else_Statements
=> New_List
(Fin_Stmt
));
5629 -- Generate all finalization loops starting from the innermost
5632 -- for Fnn in reverse V'Range (Dim) loop
5636 F
:= Last
(Final_List
);
5638 while Present
(F
) and then Dim
> 0 loop
5644 Make_Loop_Statement
(Loc
,
5646 Make_Iteration_Scheme
(Loc
,
5647 Loop_Parameter_Specification
=>
5648 Make_Loop_Parameter_Specification
(Loc
,
5649 Defining_Identifier
=> Loop_Id
,
5650 Discrete_Subtype_Definition
=>
5651 Make_Attribute_Reference
(Loc
,
5652 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5653 Attribute_Name
=> Name_Range
,
5654 Expressions
=> New_List
(
5655 Make_Integer_Literal
(Loc
, Dim
))),
5657 Reverse_Present
=> True)),
5659 Statements
=> New_List
(Final_Loop
),
5660 End_Label
=> Empty
);
5665 -- Generate the block which contains the finalization loops, the
5666 -- declarations of the abort flag, the exception occurrence, the
5667 -- raised flag and the conditional raise.
5670 -- Abort : constant Boolean := Triggered_By_Abort;
5672 -- Abort : constant Boolean := False; -- no abort
5674 -- E : Exception_Occurrence;
5675 -- Raised : Boolean := False;
5681 -- V'Length (N) - Counter;
5685 -- if Raised and then not Abort then -- Exception handlers OK
5686 -- Raise_From_Controlled_Operation (E);
5689 -- raise; -- Exception handlers OK
5692 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5694 if Exceptions_OK
then
5696 Build_Raise_Statement
(Finalizer_Data
));
5697 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5701 Make_Block_Statement
(Loc
,
5704 Handled_Statement_Sequence
=>
5705 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5707 -- Generate the block which contains the initialization call and
5708 -- the partial finalization code.
5711 -- [Deep_]Initialize (V (J1, ..., JN));
5713 -- Counter := Counter + 1;
5717 -- <finalization code>
5721 Make_Block_Statement
(Loc
,
5722 Handled_Statement_Sequence
=>
5723 Make_Handled_Sequence_Of_Statements
(Loc
,
5724 Statements
=> New_List
(Build_Initialization_Call
),
5725 Exception_Handlers
=> New_List
(
5726 Make_Exception_Handler
(Loc
,
5727 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5728 Statements
=> New_List
(Final_Block
)))));
5730 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5731 Make_Assignment_Statement
(Loc
,
5732 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5735 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5736 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5738 -- Generate all initialization loops starting from the innermost
5741 -- for Jnn in V'Range (Dim) loop
5745 J
:= Last
(Index_List
);
5747 while Present
(J
) and then Dim
> 0 loop
5753 Make_Loop_Statement
(Loc
,
5755 Make_Iteration_Scheme
(Loc
,
5756 Loop_Parameter_Specification
=>
5757 Make_Loop_Parameter_Specification
(Loc
,
5758 Defining_Identifier
=> Loop_Id
,
5759 Discrete_Subtype_Definition
=>
5760 Make_Attribute_Reference
(Loc
,
5761 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5762 Attribute_Name
=> Name_Range
,
5763 Expressions
=> New_List
(
5764 Make_Integer_Literal
(Loc
, Dim
))))),
5766 Statements
=> New_List
(Init_Loop
),
5767 End_Label
=> Empty
);
5772 -- Generate the block which contains the counter variable and the
5773 -- initialization loops.
5776 -- Counter : Integer := 0;
5783 Make_Block_Statement
(Loc
,
5784 Declarations
=> New_List
(
5785 Make_Object_Declaration
(Loc
,
5786 Defining_Identifier
=> Counter_Id
,
5787 Object_Definition
=>
5788 New_Occurrence_Of
(Standard_Integer
, Loc
),
5789 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5791 Handled_Statement_Sequence
=>
5792 Make_Handled_Sequence_Of_Statements
(Loc
,
5793 Statements
=> New_List
(Init_Loop
))));
5794 end Build_Initialize_Statements
;
5796 -----------------------
5797 -- New_References_To --
5798 -----------------------
5800 function New_References_To
5802 Loc
: Source_Ptr
) return List_Id
5804 Refs
: constant List_Id
:= New_List
;
5809 while Present
(Id
) loop
5810 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
5815 end New_References_To
;
5817 -- Start of processing for Make_Deep_Array_Body
5821 when Address_Case
=>
5822 return Make_Finalize_Address_Stmts
(Typ
);
5826 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5828 when Initialize_Case
=>
5829 return Build_Initialize_Statements
(Typ
);
5831 end Make_Deep_Array_Body
;
5833 --------------------
5834 -- Make_Deep_Proc --
5835 --------------------
5837 function Make_Deep_Proc
5838 (Prim
: Final_Primitives
;
5840 Stmts
: List_Id
) return Entity_Id
5842 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5844 Proc_Id
: Entity_Id
;
5847 -- Create the object formal, generate:
5848 -- V : System.Address
5850 if Prim
= Address_Case
then
5851 Formals
:= New_List
(
5852 Make_Parameter_Specification
(Loc
,
5853 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5855 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5862 Formals
:= New_List
(
5863 Make_Parameter_Specification
(Loc
,
5864 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5866 Out_Present
=> True,
5867 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
5869 -- F : Boolean := True
5871 if Prim
= Adjust_Case
5872 or else Prim
= Finalize_Case
5875 Make_Parameter_Specification
(Loc
,
5876 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5878 New_Occurrence_Of
(Standard_Boolean
, Loc
),
5880 New_Occurrence_Of
(Standard_True
, Loc
)));
5885 Make_Defining_Identifier
(Loc
,
5886 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5889 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5892 -- exception -- Finalize and Adjust cases only
5893 -- raise Program_Error;
5894 -- end Deep_Initialize / Adjust / Finalize;
5898 -- procedure Finalize_Address (V : System.Address) is
5901 -- end Finalize_Address;
5904 Make_Subprogram_Body
(Loc
,
5906 Make_Procedure_Specification
(Loc
,
5907 Defining_Unit_Name
=> Proc_Id
,
5908 Parameter_Specifications
=> Formals
),
5910 Declarations
=> Empty_List
,
5912 Handled_Statement_Sequence
=>
5913 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5918 ---------------------------
5919 -- Make_Deep_Record_Body --
5920 ---------------------------
5922 function Make_Deep_Record_Body
5923 (Prim
: Final_Primitives
;
5925 Is_Local
: Boolean := False) return List_Id
5927 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5928 -- Build the statements necessary to adjust a record type. The type may
5929 -- have discriminants and contain variant parts. Generate:
5933 -- [Deep_]Adjust (V.Comp_1);
5935 -- when Id : others =>
5936 -- if not Raised then
5938 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5943 -- [Deep_]Adjust (V.Comp_N);
5945 -- when Id : others =>
5946 -- if not Raised then
5948 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5953 -- Deep_Adjust (V._parent, False); -- If applicable
5955 -- when Id : others =>
5956 -- if not Raised then
5958 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5964 -- Adjust (V); -- If applicable
5967 -- if not Raised then
5969 -- Save_Occurence (E, Get_Current_Excep.all.all);
5974 -- if Raised and then not Abort then
5975 -- Raise_From_Controlled_Operation (E);
5979 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5980 -- Build the statements necessary to finalize a record type. The type
5981 -- may have discriminants and contain variant parts. Generate:
5984 -- Abort : constant Boolean := Triggered_By_Abort;
5986 -- Abort : constant Boolean := False; -- no abort
5987 -- E : Exception_Occurence;
5988 -- Raised : Boolean := False;
5993 -- Finalize (V); -- If applicable
5996 -- if not Raised then
5998 -- Save_Occurence (E, Get_Current_Excep.all.all);
6003 -- case Variant_1 is
6005 -- case State_Counter_N => -- If Is_Local is enabled
6015 -- <<LN>> -- If Is_Local is enabled
6017 -- [Deep_]Finalize (V.Comp_N);
6020 -- if not Raised then
6022 -- Save_Occurence (E, Get_Current_Excep.all.all);
6028 -- [Deep_]Finalize (V.Comp_1);
6031 -- if not Raised then
6033 -- Save_Occurence (E, Get_Current_Excep.all.all);
6039 -- case State_Counter_1 => -- If Is_Local is enabled
6045 -- Deep_Finalize (V._parent, False); -- If applicable
6047 -- when Id : others =>
6048 -- if not Raised then
6050 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6054 -- if Raised and then not Abort then
6055 -- Raise_From_Controlled_Operation (E);
6059 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6060 -- Given a derived tagged type Typ, traverse all components, find field
6061 -- _parent and return its type.
6063 procedure Preprocess_Components
6065 Num_Comps
: out Int
;
6066 Has_POC
: out Boolean);
6067 -- Examine all components in component list Comps, count all controlled
6068 -- components and determine whether at least one of them is per-object
6069 -- constrained. Component _parent is always skipped.
6071 -----------------------------
6072 -- Build_Adjust_Statements --
6073 -----------------------------
6075 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6076 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6077 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6078 Bod_Stmts
: List_Id
;
6079 Finalizer_Data
: Finalization_Exception_Data
;
6080 Finalizer_Decls
: List_Id
:= No_List
;
6084 Exceptions_OK
: constant Boolean :=
6085 not Restriction_Active
(No_Exception_Propagation
);
6087 function Process_Component_List_For_Adjust
6088 (Comps
: Node_Id
) return List_Id
;
6089 -- Build all necessary adjust statements for a single component list
6091 ---------------------------------------
6092 -- Process_Component_List_For_Adjust --
6093 ---------------------------------------
6095 function Process_Component_List_For_Adjust
6096 (Comps
: Node_Id
) return List_Id
6098 Stmts
: constant List_Id
:= New_List
;
6100 Decl_Id
: Entity_Id
;
6101 Decl_Typ
: Entity_Id
;
6105 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6106 -- Process the declaration of a single controlled component
6108 ----------------------------------
6109 -- Process_Component_For_Adjust --
6110 ----------------------------------
6112 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6113 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6114 Typ
: constant Entity_Id
:= Etype
(Id
);
6119 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6121 -- begin -- Exception handlers allowed
6122 -- [Deep_]Adjust (V.Id);
6125 -- if not Raised then
6127 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6134 Make_Selected_Component
(Loc
,
6135 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6136 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6139 if Exceptions_OK
then
6141 Make_Block_Statement
(Loc
,
6142 Handled_Statement_Sequence
=>
6143 Make_Handled_Sequence_Of_Statements
(Loc
,
6144 Statements
=> New_List
(Adj_Stmt
),
6145 Exception_Handlers
=> New_List
(
6146 Build_Exception_Handler
(Finalizer_Data
))));
6149 Append_To
(Stmts
, Adj_Stmt
);
6150 end Process_Component_For_Adjust
;
6152 -- Start of processing for Process_Component_List_For_Adjust
6155 -- Perform an initial check, determine the number of controlled
6156 -- components in the current list and whether at least one of them
6157 -- is per-object constrained.
6159 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6161 -- The processing in this routine is done in the following order:
6162 -- 1) Regular components
6163 -- 2) Per-object constrained components
6166 if Num_Comps
> 0 then
6168 -- Process all regular components in order of declarations
6170 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6171 while Present
(Decl
) loop
6172 Decl_Id
:= Defining_Identifier
(Decl
);
6173 Decl_Typ
:= Etype
(Decl_Id
);
6175 -- Skip _parent as well as per-object constrained components
6177 if Chars
(Decl_Id
) /= Name_uParent
6178 and then Needs_Finalization
(Decl_Typ
)
6180 if Has_Access_Constraint
(Decl_Id
)
6181 and then No
(Expression
(Decl
))
6185 Process_Component_For_Adjust
(Decl
);
6189 Next_Non_Pragma
(Decl
);
6192 -- Process all per-object constrained components in order of
6196 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6197 while Present
(Decl
) loop
6198 Decl_Id
:= Defining_Identifier
(Decl
);
6199 Decl_Typ
:= Etype
(Decl_Id
);
6203 if Chars
(Decl_Id
) /= Name_uParent
6204 and then Needs_Finalization
(Decl_Typ
)
6205 and then Has_Access_Constraint
(Decl_Id
)
6206 and then No
(Expression
(Decl
))
6208 Process_Component_For_Adjust
(Decl
);
6211 Next_Non_Pragma
(Decl
);
6216 -- Process all variants, if any
6219 if Present
(Variant_Part
(Comps
)) then
6221 Var_Alts
: constant List_Id
:= New_List
;
6225 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6226 while Present
(Var
) loop
6229 -- when <discrete choices> =>
6230 -- <adjust statements>
6232 Append_To
(Var_Alts
,
6233 Make_Case_Statement_Alternative
(Loc
,
6235 New_Copy_List
(Discrete_Choices
(Var
)),
6237 Process_Component_List_For_Adjust
(
6238 Component_List
(Var
))));
6240 Next_Non_Pragma
(Var
);
6244 -- case V.<discriminant> is
6245 -- when <discrete choices 1> =>
6246 -- <adjust statements 1>
6248 -- when <discrete choices N> =>
6249 -- <adjust statements N>
6253 Make_Case_Statement
(Loc
,
6255 Make_Selected_Component
(Loc
,
6256 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6258 Make_Identifier
(Loc
,
6259 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6260 Alternatives
=> Var_Alts
);
6264 -- Add the variant case statement to the list of statements
6266 if Present
(Var_Case
) then
6267 Append_To
(Stmts
, Var_Case
);
6270 -- If the component list did not have any controlled components
6271 -- nor variants, return null.
6273 if Is_Empty_List
(Stmts
) then
6274 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6278 end Process_Component_List_For_Adjust
;
6280 -- Start of processing for Build_Adjust_Statements
6283 Finalizer_Decls
:= New_List
;
6284 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6286 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6287 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6292 -- Create an adjust sequence for all record components
6294 if Present
(Component_List
(Rec_Def
)) then
6296 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6299 -- A derived record type must adjust all inherited components. This
6300 -- action poses the following problem:
6302 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6307 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6309 -- Deep_Adjust (Obj._parent);
6314 -- Adjusting the derived type will invoke Adjust of the parent and
6315 -- then that of the derived type. This is undesirable because both
6316 -- routines may modify shared components. Only the Adjust of the
6317 -- derived type should be invoked.
6319 -- To prevent this double adjustment of shared components,
6320 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6322 -- procedure Deep_Adjust
6323 -- (Obj : in out Some_Type;
6324 -- Flag : Boolean := True)
6332 -- When Deep_Adjust is invokes for field _parent, a value of False is
6333 -- provided for the flag:
6335 -- Deep_Adjust (Obj._parent, False);
6337 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6339 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6344 if Needs_Finalization
(Par_Typ
) then
6348 Make_Selected_Component
(Loc
,
6349 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6351 Make_Identifier
(Loc
, Name_uParent
)),
6356 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6358 -- begin -- Exceptions OK
6359 -- Deep_Adjust (V._parent, False);
6361 -- when Id : others =>
6362 -- if not Raised then
6364 -- Save_Occurrence (E,
6365 -- Get_Current_Excep.all.all);
6369 if Present
(Call
) then
6372 if Exceptions_OK
then
6374 Make_Block_Statement
(Loc
,
6375 Handled_Statement_Sequence
=>
6376 Make_Handled_Sequence_Of_Statements
(Loc
,
6377 Statements
=> New_List
(Adj_Stmt
),
6378 Exception_Handlers
=> New_List
(
6379 Build_Exception_Handler
(Finalizer_Data
))));
6382 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6388 -- Adjust the object. This action must be performed last after all
6389 -- components have been adjusted.
6391 if Is_Controlled
(Typ
) then
6397 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6401 -- Adjust (V); -- No_Exception_Propagation
6403 -- begin -- Exception handlers allowed
6407 -- if not Raised then
6409 -- Save_Occurrence (E,
6410 -- Get_Current_Excep.all.all);
6415 if Present
(Proc
) then
6417 Make_Procedure_Call_Statement
(Loc
,
6418 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6419 Parameter_Associations
=> New_List
(
6420 Make_Identifier
(Loc
, Name_V
)));
6422 if Exceptions_OK
then
6424 Make_Block_Statement
(Loc
,
6425 Handled_Statement_Sequence
=>
6426 Make_Handled_Sequence_Of_Statements
(Loc
,
6427 Statements
=> New_List
(Adj_Stmt
),
6428 Exception_Handlers
=> New_List
(
6429 Build_Exception_Handler
6430 (Finalizer_Data
))));
6433 Append_To
(Bod_Stmts
,
6434 Make_If_Statement
(Loc
,
6435 Condition
=> Make_Identifier
(Loc
, Name_F
),
6436 Then_Statements
=> New_List
(Adj_Stmt
)));
6441 -- At this point either all adjustment statements have been generated
6442 -- or the type is not controlled.
6444 if Is_Empty_List
(Bod_Stmts
) then
6445 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6451 -- Abort : constant Boolean := Triggered_By_Abort;
6453 -- Abort : constant Boolean := False; -- no abort
6455 -- E : Exception_Occurence;
6456 -- Raised : Boolean := False;
6459 -- <adjust statements>
6461 -- if Raised and then not Abort then
6462 -- Raise_From_Controlled_Operation (E);
6467 if Exceptions_OK
then
6468 Append_To
(Bod_Stmts
,
6469 Build_Raise_Statement
(Finalizer_Data
));
6474 Make_Block_Statement
(Loc
,
6477 Handled_Statement_Sequence
=>
6478 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6480 end Build_Adjust_Statements
;
6482 -------------------------------
6483 -- Build_Finalize_Statements --
6484 -------------------------------
6486 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6487 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6488 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6489 Bod_Stmts
: List_Id
;
6491 Finalizer_Data
: Finalization_Exception_Data
;
6492 Finalizer_Decls
: List_Id
:= No_List
;
6496 Exceptions_OK
: constant Boolean :=
6497 not Restriction_Active
(No_Exception_Propagation
);
6499 function Process_Component_List_For_Finalize
6500 (Comps
: Node_Id
) return List_Id
;
6501 -- Build all necessary finalization statements for a single component
6502 -- list. The statements may include a jump circuitry if flag Is_Local
6505 -----------------------------------------
6506 -- Process_Component_List_For_Finalize --
6507 -----------------------------------------
6509 function Process_Component_List_For_Finalize
6510 (Comps
: Node_Id
) return List_Id
6513 Counter_Id
: Entity_Id
;
6515 Decl_Id
: Entity_Id
;
6516 Decl_Typ
: Entity_Id
;
6519 Jump_Block
: Node_Id
;
6521 Label_Id
: Entity_Id
;
6525 procedure Process_Component_For_Finalize
6530 -- Process the declaration of a single controlled component. If
6531 -- flag Is_Local is enabled, create the corresponding label and
6532 -- jump circuitry. Alts is the list of case alternatives, Decls
6533 -- is the top level declaration list where labels are declared
6534 -- and Stmts is the list of finalization actions.
6536 ------------------------------------
6537 -- Process_Component_For_Finalize --
6538 ------------------------------------
6540 procedure Process_Component_For_Finalize
6546 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6547 Typ
: constant Entity_Id
:= Etype
(Id
);
6554 Label_Id
: Entity_Id
;
6561 Make_Identifier
(Loc
,
6562 Chars
=> New_External_Name
('L', Num_Comps
));
6563 Set_Entity
(Label_Id
,
6564 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6565 Label
:= Make_Label
(Loc
, Label_Id
);
6568 Make_Implicit_Label_Declaration
(Loc
,
6569 Defining_Identifier
=> Entity
(Label_Id
),
6570 Label_Construct
=> Label
));
6577 Make_Case_Statement_Alternative
(Loc
,
6578 Discrete_Choices
=> New_List
(
6579 Make_Integer_Literal
(Loc
, Num_Comps
)),
6581 Statements
=> New_List
(
6582 Make_Goto_Statement
(Loc
,
6584 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6589 Append_To
(Stmts
, Label
);
6591 -- Decrease the number of components to be processed.
6592 -- This action yields a new Label_Id in future calls.
6594 Num_Comps
:= Num_Comps
- 1;
6599 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6601 -- begin -- Exception handlers allowed
6602 -- [Deep_]Finalize (V.Id);
6605 -- if not Raised then
6607 -- Save_Occurrence (E,
6608 -- Get_Current_Excep.all.all);
6615 Make_Selected_Component
(Loc
,
6616 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6617 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6620 if not Restriction_Active
(No_Exception_Propagation
) then
6622 Make_Block_Statement
(Loc
,
6623 Handled_Statement_Sequence
=>
6624 Make_Handled_Sequence_Of_Statements
(Loc
,
6625 Statements
=> New_List
(Fin_Stmt
),
6626 Exception_Handlers
=> New_List
(
6627 Build_Exception_Handler
(Finalizer_Data
))));
6630 Append_To
(Stmts
, Fin_Stmt
);
6631 end Process_Component_For_Finalize
;
6633 -- Start of processing for Process_Component_List_For_Finalize
6636 -- Perform an initial check, look for controlled and per-object
6637 -- constrained components.
6639 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6641 -- Create a state counter to service the current component list.
6642 -- This step is performed before the variants are inspected in
6643 -- order to generate the same state counter names as those from
6644 -- Build_Initialize_Statements.
6646 if Num_Comps
> 0 and then Is_Local
then
6647 Counter
:= Counter
+ 1;
6650 Make_Defining_Identifier
(Loc
,
6651 Chars
=> New_External_Name
('C', Counter
));
6654 -- Process the component in the following order:
6656 -- 2) Per-object constrained components
6657 -- 3) Regular components
6659 -- Start with the variant parts
6662 if Present
(Variant_Part
(Comps
)) then
6664 Var_Alts
: constant List_Id
:= New_List
;
6668 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6669 while Present
(Var
) loop
6672 -- when <discrete choices> =>
6673 -- <finalize statements>
6675 Append_To
(Var_Alts
,
6676 Make_Case_Statement_Alternative
(Loc
,
6678 New_Copy_List
(Discrete_Choices
(Var
)),
6680 Process_Component_List_For_Finalize
(
6681 Component_List
(Var
))));
6683 Next_Non_Pragma
(Var
);
6687 -- case V.<discriminant> is
6688 -- when <discrete choices 1> =>
6689 -- <finalize statements 1>
6691 -- when <discrete choices N> =>
6692 -- <finalize statements N>
6696 Make_Case_Statement
(Loc
,
6698 Make_Selected_Component
(Loc
,
6699 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6701 Make_Identifier
(Loc
,
6702 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6703 Alternatives
=> Var_Alts
);
6707 -- The current component list does not have a single controlled
6708 -- component, however it may contain variants. Return the case
6709 -- statement for the variants or nothing.
6711 if Num_Comps
= 0 then
6712 if Present
(Var_Case
) then
6713 return New_List
(Var_Case
);
6715 return New_List
(Make_Null_Statement
(Loc
));
6719 -- Prepare all lists
6725 -- Process all per-object constrained components in reverse order
6728 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6729 while Present
(Decl
) loop
6730 Decl_Id
:= Defining_Identifier
(Decl
);
6731 Decl_Typ
:= Etype
(Decl_Id
);
6735 if Chars
(Decl_Id
) /= Name_uParent
6736 and then Needs_Finalization
(Decl_Typ
)
6737 and then Has_Access_Constraint
(Decl_Id
)
6738 and then No
(Expression
(Decl
))
6740 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6743 Prev_Non_Pragma
(Decl
);
6747 -- Process the rest of the components in reverse order
6749 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6750 while Present
(Decl
) loop
6751 Decl_Id
:= Defining_Identifier
(Decl
);
6752 Decl_Typ
:= Etype
(Decl_Id
);
6756 if Chars
(Decl_Id
) /= Name_uParent
6757 and then Needs_Finalization
(Decl_Typ
)
6759 -- Skip per-object constrained components since they were
6760 -- handled in the above step.
6762 if Has_Access_Constraint
(Decl_Id
)
6763 and then No
(Expression
(Decl
))
6767 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6771 Prev_Non_Pragma
(Decl
);
6776 -- LN : label; -- If Is_Local is enabled
6781 -- case CounterX is .
6791 -- <<LN>> -- If Is_Local is enabled
6793 -- [Deep_]Finalize (V.CompY);
6795 -- when Id : others =>
6796 -- if not Raised then
6798 -- Save_Occurrence (E,
6799 -- Get_Current_Excep.all.all);
6803 -- <<L0>> -- If Is_Local is enabled
6808 -- Add the declaration of default jump location L0, its
6809 -- corresponding alternative and its place in the statements.
6811 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6812 Set_Entity
(Label_Id
,
6813 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6814 Label
:= Make_Label
(Loc
, Label_Id
);
6816 Append_To
(Decls
, -- declaration
6817 Make_Implicit_Label_Declaration
(Loc
,
6818 Defining_Identifier
=> Entity
(Label_Id
),
6819 Label_Construct
=> Label
));
6821 Append_To
(Alts
, -- alternative
6822 Make_Case_Statement_Alternative
(Loc
,
6823 Discrete_Choices
=> New_List
(
6824 Make_Others_Choice
(Loc
)),
6826 Statements
=> New_List
(
6827 Make_Goto_Statement
(Loc
,
6828 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6830 Append_To
(Stmts
, Label
); -- statement
6832 -- Create the jump block
6835 Make_Case_Statement
(Loc
,
6836 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6837 Alternatives
=> Alts
));
6841 Make_Block_Statement
(Loc
,
6842 Declarations
=> Decls
,
6843 Handled_Statement_Sequence
=>
6844 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6846 if Present
(Var_Case
) then
6847 return New_List
(Var_Case
, Jump_Block
);
6849 return New_List
(Jump_Block
);
6851 end Process_Component_List_For_Finalize
;
6853 -- Start of processing for Build_Finalize_Statements
6856 Finalizer_Decls
:= New_List
;
6857 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6859 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6860 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6865 -- Create a finalization sequence for all record components
6867 if Present
(Component_List
(Rec_Def
)) then
6869 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6872 -- A derived record type must finalize all inherited components. This
6873 -- action poses the following problem:
6875 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6880 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6882 -- Deep_Finalize (Obj._parent);
6887 -- Finalizing the derived type will invoke Finalize of the parent and
6888 -- then that of the derived type. This is undesirable because both
6889 -- routines may modify shared components. Only the Finalize of the
6890 -- derived type should be invoked.
6892 -- To prevent this double adjustment of shared components,
6893 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6895 -- procedure Deep_Finalize
6896 -- (Obj : in out Some_Type;
6897 -- Flag : Boolean := True)
6905 -- When Deep_Finalize is invokes for field _parent, a value of False
6906 -- is provided for the flag:
6908 -- Deep_Finalize (Obj._parent, False);
6910 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6912 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6917 if Needs_Finalization
(Par_Typ
) then
6921 Make_Selected_Component
(Loc
,
6922 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6924 Make_Identifier
(Loc
, Name_uParent
)),
6929 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6931 -- begin -- Exceptions OK
6932 -- Deep_Finalize (V._parent, False);
6934 -- when Id : others =>
6935 -- if not Raised then
6937 -- Save_Occurrence (E,
6938 -- Get_Current_Excep.all.all);
6942 if Present
(Call
) then
6945 if Exceptions_OK
then
6947 Make_Block_Statement
(Loc
,
6948 Handled_Statement_Sequence
=>
6949 Make_Handled_Sequence_Of_Statements
(Loc
,
6950 Statements
=> New_List
(Fin_Stmt
),
6951 Exception_Handlers
=> New_List
(
6952 Build_Exception_Handler
6953 (Finalizer_Data
))));
6956 Append_To
(Bod_Stmts
, Fin_Stmt
);
6962 -- Finalize the object. This action must be performed first before
6963 -- all components have been finalized.
6965 if Is_Controlled
(Typ
) and then not Is_Local
then
6971 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6975 -- Finalize (V); -- No_Exception_Propagation
6981 -- if not Raised then
6983 -- Save_Occurrence (E,
6984 -- Get_Current_Excep.all.all);
6989 if Present
(Proc
) then
6991 Make_Procedure_Call_Statement
(Loc
,
6992 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6993 Parameter_Associations
=> New_List
(
6994 Make_Identifier
(Loc
, Name_V
)));
6996 if Exceptions_OK
then
6998 Make_Block_Statement
(Loc
,
6999 Handled_Statement_Sequence
=>
7000 Make_Handled_Sequence_Of_Statements
(Loc
,
7001 Statements
=> New_List
(Fin_Stmt
),
7002 Exception_Handlers
=> New_List
(
7003 Build_Exception_Handler
7004 (Finalizer_Data
))));
7007 Prepend_To
(Bod_Stmts
,
7008 Make_If_Statement
(Loc
,
7009 Condition
=> Make_Identifier
(Loc
, Name_F
),
7010 Then_Statements
=> New_List
(Fin_Stmt
)));
7015 -- At this point either all finalization statements have been
7016 -- generated or the type is not controlled.
7018 if No
(Bod_Stmts
) then
7019 return New_List
(Make_Null_Statement
(Loc
));
7023 -- Abort : constant Boolean := Triggered_By_Abort;
7025 -- Abort : constant Boolean := False; -- no abort
7027 -- E : Exception_Occurence;
7028 -- Raised : Boolean := False;
7031 -- <finalize statements>
7033 -- if Raised and then not Abort then
7034 -- Raise_From_Controlled_Operation (E);
7039 if Exceptions_OK
then
7040 Append_To
(Bod_Stmts
,
7041 Build_Raise_Statement
(Finalizer_Data
));
7046 Make_Block_Statement
(Loc
,
7049 Handled_Statement_Sequence
=>
7050 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7052 end Build_Finalize_Statements
;
7054 -----------------------
7055 -- Parent_Field_Type --
7056 -----------------------
7058 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7062 Field
:= First_Entity
(Typ
);
7063 while Present
(Field
) loop
7064 if Chars
(Field
) = Name_uParent
then
7065 return Etype
(Field
);
7068 Next_Entity
(Field
);
7071 -- A derived tagged type should always have a parent field
7073 raise Program_Error
;
7074 end Parent_Field_Type
;
7076 ---------------------------
7077 -- Preprocess_Components --
7078 ---------------------------
7080 procedure Preprocess_Components
7082 Num_Comps
: out Int
;
7083 Has_POC
: out Boolean)
7093 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7094 while Present
(Decl
) loop
7095 Id
:= Defining_Identifier
(Decl
);
7098 -- Skip field _parent
7100 if Chars
(Id
) /= Name_uParent
7101 and then Needs_Finalization
(Typ
)
7103 Num_Comps
:= Num_Comps
+ 1;
7105 if Has_Access_Constraint
(Id
)
7106 and then No
(Expression
(Decl
))
7112 Next_Non_Pragma
(Decl
);
7114 end Preprocess_Components
;
7116 -- Start of processing for Make_Deep_Record_Body
7120 when Address_Case
=>
7121 return Make_Finalize_Address_Stmts
(Typ
);
7124 return Build_Adjust_Statements
(Typ
);
7126 when Finalize_Case
=>
7127 return Build_Finalize_Statements
(Typ
);
7129 when Initialize_Case
=>
7131 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7134 if Is_Controlled
(Typ
) then
7136 Make_Procedure_Call_Statement
(Loc
,
7139 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7140 Parameter_Associations
=> New_List
(
7141 Make_Identifier
(Loc
, Name_V
))));
7147 end Make_Deep_Record_Body
;
7149 ----------------------
7150 -- Make_Final_Call --
7151 ----------------------
7153 function Make_Final_Call
7156 Skip_Self
: Boolean := False) return Node_Id
7158 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7160 Fin_Id
: Entity_Id
:= Empty
;
7165 -- Recover the proper type which contains [Deep_]Finalize
7167 if Is_Class_Wide_Type
(Typ
) then
7168 Utyp
:= Root_Type
(Typ
);
7172 elsif Is_Concurrent_Type
(Typ
) then
7173 Utyp
:= Corresponding_Record_Type
(Typ
);
7175 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7177 elsif Is_Private_Type
(Typ
)
7178 and then Present
(Full_View
(Typ
))
7179 and then Is_Concurrent_Type
(Full_View
(Typ
))
7181 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7183 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7191 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7192 Set_Assignment_OK
(Ref
);
7194 -- Deal with untagged derivation of private views. If the parent type
7195 -- is a protected type, Deep_Finalize is found on the corresponding
7196 -- record of the ancestor.
7198 if Is_Untagged_Derivation
(Typ
) then
7199 if Is_Protected_Type
(Typ
) then
7200 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7202 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7204 if Is_Protected_Type
(Utyp
) then
7205 Utyp
:= Corresponding_Record_Type
(Utyp
);
7209 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7210 Set_Assignment_OK
(Ref
);
7213 -- Deal with derived private types which do not inherit primitives from
7214 -- their parents. In this case, [Deep_]Finalize can be found in the full
7215 -- view of the parent type.
7217 if Is_Tagged_Type
(Utyp
)
7218 and then Is_Derived_Type
(Utyp
)
7219 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7220 and then Is_Private_Type
(Etype
(Utyp
))
7221 and then Present
(Full_View
(Etype
(Utyp
)))
7223 Utyp
:= Full_View
(Etype
(Utyp
));
7224 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7225 Set_Assignment_OK
(Ref
);
7228 -- When dealing with the completion of a private type, use the base type
7231 if Utyp
/= Base_Type
(Utyp
) then
7232 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7234 Utyp
:= Base_Type
(Utyp
);
7235 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7236 Set_Assignment_OK
(Ref
);
7240 if Has_Controlled_Component
(Utyp
) then
7241 if Is_Tagged_Type
(Utyp
) then
7242 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7244 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7248 -- Class-wide types, interfaces and types with controlled components
7250 elsif Is_Class_Wide_Type
(Typ
)
7251 or else Is_Interface
(Typ
)
7252 or else Has_Controlled_Component
(Utyp
)
7254 if Is_Tagged_Type
(Utyp
) then
7255 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7257 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7260 -- Derivations from [Limited_]Controlled
7262 elsif Is_Controlled
(Utyp
) then
7263 if Has_Controlled_Component
(Utyp
) then
7264 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7266 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7271 elsif Is_Tagged_Type
(Utyp
) then
7272 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7275 raise Program_Error
;
7278 if Present
(Fin_Id
) then
7280 -- When finalizing a class-wide object, do not convert to the root
7281 -- type in order to produce a dispatching call.
7283 if Is_Class_Wide_Type
(Typ
) then
7286 -- Ensure that a finalization routine is at least decorated in order
7287 -- to inspect the object parameter.
7289 elsif Analyzed
(Fin_Id
)
7290 or else Ekind
(Fin_Id
) = E_Procedure
7292 -- In certain cases, such as the creation of Stream_Read, the
7293 -- visible entity of the type is its full view. Since Stream_Read
7294 -- will have to create an object of type Typ, the local object
7295 -- will be finalzed by the scope finalizer generated later on. The
7296 -- object parameter of Deep_Finalize will always use the private
7297 -- view of the type. To avoid such a clash between a private and a
7298 -- full view, perform an unchecked conversion of the object
7299 -- reference to the private view.
7302 Formal_Typ
: constant Entity_Id
:=
7303 Etype
(First_Formal
(Fin_Id
));
7305 if Is_Private_Type
(Formal_Typ
)
7306 and then Present
(Full_View
(Formal_Typ
))
7307 and then Full_View
(Formal_Typ
) = Utyp
7309 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7313 Ref
:= Convert_View
(Fin_Id
, Ref
);
7319 Param
=> New_Copy_Tree
(Ref
),
7320 Skip_Self
=> Skip_Self
);
7324 end Make_Final_Call
;
7326 --------------------------------
7327 -- Make_Finalize_Address_Body --
7328 --------------------------------
7330 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7331 Is_Task
: constant Boolean :=
7332 Ekind
(Typ
) = E_Record_Type
7333 and then Is_Concurrent_Record_Type
(Typ
)
7334 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7336 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7337 Proc_Id
: Entity_Id
;
7341 -- The corresponding records of task types are not controlled by design.
7342 -- For the sake of completeness, create an empty Finalize_Address to be
7343 -- used in task class-wide allocations.
7348 -- Nothing to do if the type is not controlled or it already has a
7349 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7350 -- come from source. These are usually generated for completeness and
7351 -- do not need the Finalize_Address primitive.
7353 elsif not Needs_Finalization
(Typ
)
7354 or else Is_Abstract_Type
(Typ
)
7355 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7357 (Is_Class_Wide_Type
(Typ
)
7358 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7359 and then not Comes_From_Source
(Root_Type
(Typ
)))
7365 Make_Defining_Identifier
(Loc
,
7366 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7370 -- procedure <Typ>FD (V : System.Address) is
7372 -- null; -- for tasks
7374 -- declare -- for all other types
7375 -- type Pnn is access all Typ;
7376 -- for Pnn'Storage_Size use 0;
7378 -- [Deep_]Finalize (Pnn (V).all);
7383 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7385 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7389 Make_Subprogram_Body
(Loc
,
7391 Make_Procedure_Specification
(Loc
,
7392 Defining_Unit_Name
=> Proc_Id
,
7394 Parameter_Specifications
=> New_List
(
7395 Make_Parameter_Specification
(Loc
,
7396 Defining_Identifier
=>
7397 Make_Defining_Identifier
(Loc
, Name_V
),
7399 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7401 Declarations
=> No_List
,
7403 Handled_Statement_Sequence
=>
7404 Make_Handled_Sequence_Of_Statements
(Loc
,
7405 Statements
=> Stmts
)));
7407 Set_TSS
(Typ
, Proc_Id
);
7408 end Make_Finalize_Address_Body
;
7410 ---------------------------------
7411 -- Make_Finalize_Address_Stmts --
7412 ---------------------------------
7414 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7415 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7416 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7418 Desg_Typ
: Entity_Id
;
7422 if Is_Array_Type
(Typ
) then
7423 if Is_Constrained
(First_Subtype
(Typ
)) then
7424 Desg_Typ
:= First_Subtype
(Typ
);
7426 Desg_Typ
:= Base_Type
(Typ
);
7429 -- Class-wide types of constrained root types
7431 elsif Is_Class_Wide_Type
(Typ
)
7432 and then Has_Discriminants
(Root_Type
(Typ
))
7434 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7437 Parent_Typ
: Entity_Id
;
7440 -- Climb the parent type chain looking for a non-constrained type
7442 Parent_Typ
:= Root_Type
(Typ
);
7443 while Parent_Typ
/= Etype
(Parent_Typ
)
7444 and then Has_Discriminants
(Parent_Typ
)
7446 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7448 Parent_Typ
:= Etype
(Parent_Typ
);
7451 -- Handle views created for tagged types with unknown
7454 if Is_Underlying_Record_View
(Parent_Typ
) then
7455 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7458 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7468 -- type Ptr_Typ is access all Typ;
7469 -- for Ptr_Typ'Storage_Size use 0;
7472 Make_Full_Type_Declaration
(Loc
,
7473 Defining_Identifier
=> Ptr_Typ
,
7475 Make_Access_To_Object_Definition
(Loc
,
7476 All_Present
=> True,
7477 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7479 Make_Attribute_Definition_Clause
(Loc
,
7480 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7481 Chars
=> Name_Storage_Size
,
7482 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7484 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7486 -- Unconstrained arrays require special processing in order to retrieve
7487 -- the elements. To achieve this, we have to skip the dope vector which
7488 -- lays in front of the elements and then use a thin pointer to perform
7489 -- the address-to-access conversion.
7491 if Is_Array_Type
(Typ
)
7492 and then not Is_Constrained
(First_Subtype
(Typ
))
7495 Dope_Id
: Entity_Id
;
7498 -- Ensure that Ptr_Typ a thin pointer, generate:
7499 -- for Ptr_Typ'Size use System.Address'Size;
7502 Make_Attribute_Definition_Clause
(Loc
,
7503 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7506 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7509 -- Dnn : constant Storage_Offset :=
7510 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7512 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7515 Make_Object_Declaration
(Loc
,
7516 Defining_Identifier
=> Dope_Id
,
7517 Constant_Present
=> True,
7518 Object_Definition
=>
7519 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7521 Make_Op_Divide
(Loc
,
7523 Make_Attribute_Reference
(Loc
,
7524 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7525 Attribute_Name
=> Name_Descriptor_Size
),
7527 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7529 -- Shift the address from the start of the dope vector to the
7530 -- start of the elements:
7534 -- Note that this is done through a wrapper routine since RTSfind
7535 -- cannot retrieve operations with string names of the form "+".
7538 Make_Function_Call
(Loc
,
7540 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7541 Parameter_Associations
=> New_List
(
7543 New_Occurrence_Of
(Dope_Id
, Loc
)));
7547 -- Create the block and the finalization call
7550 Make_Block_Statement
(Loc
,
7551 Declarations
=> Decls
,
7553 Handled_Statement_Sequence
=>
7554 Make_Handled_Sequence_Of_Statements
(Loc
,
7555 Statements
=> New_List
(
7558 Make_Explicit_Dereference
(Loc
,
7559 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7560 Typ
=> Desg_Typ
)))));
7561 end Make_Finalize_Address_Stmts
;
7563 -------------------------------------
7564 -- Make_Handler_For_Ctrl_Operation --
7565 -------------------------------------
7569 -- when E : others =>
7570 -- Raise_From_Controlled_Operation (E);
7575 -- raise Program_Error [finalize raised exception];
7577 -- depending on whether Raise_From_Controlled_Operation is available
7579 function Make_Handler_For_Ctrl_Operation
7580 (Loc
: Source_Ptr
) return Node_Id
7583 -- Choice parameter (for the first case above)
7585 Raise_Node
: Node_Id
;
7586 -- Procedure call or raise statement
7589 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7590 -- it to Raise_From_Controlled_Operation so that the original exception
7591 -- name and message can be recorded in the exception message for
7594 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7595 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7597 Make_Procedure_Call_Statement
(Loc
,
7600 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7601 Parameter_Associations
=> New_List
(
7602 New_Occurrence_Of
(E_Occ
, Loc
)));
7604 -- Restricted run-time: exception messages are not supported
7609 Make_Raise_Program_Error
(Loc
,
7610 Reason
=> PE_Finalize_Raised_Exception
);
7614 Make_Implicit_Exception_Handler
(Loc
,
7615 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7616 Choice_Parameter
=> E_Occ
,
7617 Statements
=> New_List
(Raise_Node
));
7618 end Make_Handler_For_Ctrl_Operation
;
7620 --------------------
7621 -- Make_Init_Call --
7622 --------------------
7624 function Make_Init_Call
7626 Typ
: Entity_Id
) return Node_Id
7628 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7635 -- Deal with the type and object reference. Depending on the context, an
7636 -- object reference may need several conversions.
7638 if Is_Concurrent_Type
(Typ
) then
7640 Utyp
:= Corresponding_Record_Type
(Typ
);
7641 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7643 elsif Is_Private_Type
(Typ
)
7644 and then Present
(Full_View
(Typ
))
7645 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7648 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7649 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7657 Set_Assignment_OK
(Ref
);
7659 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7661 -- Deal with untagged derivation of private views
7663 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
7664 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7665 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7667 -- The following is to prevent problems with UC see 1.156 RH ???
7669 Set_Assignment_OK
(Ref
);
7672 -- If the underlying_type is a subtype, then we are dealing with the
7673 -- completion of a private type. We need to access the base type and
7674 -- generate a conversion to it.
7676 if Utyp
/= Base_Type
(Utyp
) then
7677 pragma Assert
(Is_Private_Type
(Typ
));
7678 Utyp
:= Base_Type
(Utyp
);
7679 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7682 -- Select the appropriate version of initialize
7684 if Has_Controlled_Component
(Utyp
) then
7685 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7687 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7688 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7691 -- The object reference may need another conversion depending on the
7692 -- type of the formal and that of the actual.
7694 Ref
:= Convert_View
(Proc
, Ref
);
7697 -- [Deep_]Initialize (Ref);
7700 Make_Procedure_Call_Statement
(Loc
,
7702 New_Occurrence_Of
(Proc
, Loc
),
7703 Parameter_Associations
=> New_List
(Ref
));
7706 ------------------------------
7707 -- Make_Local_Deep_Finalize --
7708 ------------------------------
7710 function Make_Local_Deep_Finalize
7712 Nam
: Entity_Id
) return Node_Id
7714 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7718 Formals
:= New_List
(
7722 Make_Parameter_Specification
(Loc
,
7723 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7725 Out_Present
=> True,
7726 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
7728 -- F : Boolean := True
7730 Make_Parameter_Specification
(Loc
,
7731 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7732 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7733 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
7735 -- Add the necessary number of counters to represent the initialization
7736 -- state of an object.
7739 Make_Subprogram_Body
(Loc
,
7741 Make_Procedure_Specification
(Loc
,
7742 Defining_Unit_Name
=> Nam
,
7743 Parameter_Specifications
=> Formals
),
7745 Declarations
=> No_List
,
7747 Handled_Statement_Sequence
=>
7748 Make_Handled_Sequence_Of_Statements
(Loc
,
7749 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7750 end Make_Local_Deep_Finalize
;
7752 ------------------------------------
7753 -- Make_Set_Finalize_Address_Call --
7754 ------------------------------------
7756 function Make_Set_Finalize_Address_Call
7759 Ptr_Typ
: Entity_Id
) return Node_Id
7761 Desig_Typ
: constant Entity_Id
:=
7762 Available_View
(Designated_Type
(Ptr_Typ
));
7763 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7764 Fin_Mas_Ref
: Node_Id
;
7768 -- If the context is a class-wide allocator, we use the class-wide type
7769 -- to obtain the proper Finalize_Address routine.
7771 if Is_Class_Wide_Type
(Desig_Typ
) then
7777 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7778 Utyp
:= Full_View
(Utyp
);
7781 if Is_Concurrent_Type
(Utyp
) then
7782 Utyp
:= Corresponding_Record_Type
(Utyp
);
7786 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7788 -- Deal with untagged derivation of private views. If the parent is
7789 -- now known to be protected, the finalization routine is the one
7790 -- defined on the corresponding record of the ancestor (corresponding
7791 -- records do not automatically inherit operations, but maybe they
7794 if Is_Untagged_Derivation
(Typ
) then
7795 if Is_Protected_Type
(Typ
) then
7796 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7798 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7800 if Is_Protected_Type
(Utyp
) then
7801 Utyp
:= Corresponding_Record_Type
(Utyp
);
7806 -- If the underlying_type is a subtype, we are dealing with the
7807 -- completion of a private type. We need to access the base type and
7808 -- generate a conversion to it.
7810 if Utyp
/= Base_Type
(Utyp
) then
7811 pragma Assert
(Is_Private_Type
(Typ
));
7813 Utyp
:= Base_Type
(Utyp
);
7816 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7818 -- If the call is from a build-in-place function, the Master parameter
7819 -- is actually a pointer. Dereference it for the call.
7821 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7822 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7826 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7829 Make_Procedure_Call_Statement
(Loc
,
7831 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
7832 Parameter_Associations
=> New_List
(
7834 Make_Attribute_Reference
(Loc
,
7836 New_Occurrence_Of
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7837 Attribute_Name
=> Name_Unrestricted_Access
)));
7838 end Make_Set_Finalize_Address_Call
;
7840 --------------------------
7841 -- Make_Transient_Block --
7842 --------------------------
7844 function Make_Transient_Block
7847 Par
: Node_Id
) return Node_Id
7849 Decls
: constant List_Id
:= New_List
;
7850 Instrs
: constant List_Id
:= New_List
(Action
);
7855 -- Case where only secondary stack use is involved
7857 if VM_Target
= No_VM
7858 and then Uses_Sec_Stack
(Current_Scope
)
7859 and then Nkind
(Action
) /= N_Simple_Return_Statement
7860 and then Nkind
(Par
) /= N_Exception_Handler
7866 S
:= Scope
(Current_Scope
);
7868 -- At the outer level, no need to release the sec stack
7870 if S
= Standard_Standard
then
7871 Set_Uses_Sec_Stack
(Current_Scope
, False);
7874 -- In a function, only release the sec stack if the function
7875 -- does not return on the sec stack otherwise the result may
7876 -- be lost. The caller is responsible for releasing.
7878 elsif Ekind
(S
) = E_Function
then
7879 Set_Uses_Sec_Stack
(Current_Scope
, False);
7881 if not Requires_Transient_Scope
(Etype
(S
)) then
7882 Set_Uses_Sec_Stack
(S
, True);
7883 Check_Restriction
(No_Secondary_Stack
, Action
);
7888 -- In a loop or entry we should install a block encompassing
7889 -- all the construct. For now just release right away.
7891 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7894 -- In a procedure or a block, we release on exit of the
7895 -- procedure or block. ??? memory leak can be created by
7898 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7899 Set_Uses_Sec_Stack
(S
, True);
7900 Check_Restriction
(No_Secondary_Stack
, Action
);
7901 Set_Uses_Sec_Stack
(Current_Scope
, False);
7911 -- Create the transient block. Set the parent now since the block itself
7912 -- is not part of the tree. The current scope is the E_Block entity
7913 -- that has been pushed by Establish_Transient_Scope.
7915 pragma Assert
(Ekind
(Current_Scope
) = E_Block
);
7917 Make_Block_Statement
(Loc
,
7918 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
7919 Declarations
=> Decls
,
7920 Handled_Statement_Sequence
=>
7921 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7922 Has_Created_Identifier
=> True);
7923 Set_Parent
(Block
, Par
);
7925 -- Insert actions stuck in the transient scopes as well as all freezing
7926 -- nodes needed by those actions. Do not insert cleanup actions here,
7927 -- they will be transferred to the newly created block.
7929 Insert_Actions_In_Scope_Around
7930 (Action
, Clean
=> False, Manage_SS
=> False);
7932 Insert
:= Prev
(Action
);
7933 if Present
(Insert
) then
7934 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7937 -- Transfer cleanup actions to the newly created block
7940 Cleanup_Actions
: List_Id
7941 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
7942 Actions_To_Be_Wrapped
(Cleanup
);
7944 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
7945 Cleanup_Actions
:= No_List
;
7948 -- When the transient scope was established, we pushed the entry for the
7949 -- transient scope onto the scope stack, so that the scope was active
7950 -- for the installation of finalizable entities etc. Now we must remove
7951 -- this entry, since we have constructed a proper block.
7956 end Make_Transient_Block
;
7958 ------------------------
7959 -- Node_To_Be_Wrapped --
7960 ------------------------
7962 function Node_To_Be_Wrapped
return Node_Id
is
7964 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7965 end Node_To_Be_Wrapped
;
7967 ----------------------------
7968 -- Set_Node_To_Be_Wrapped --
7969 ----------------------------
7971 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7973 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7974 end Set_Node_To_Be_Wrapped
;
7976 ----------------------------
7977 -- Store_Actions_In_Scope --
7978 ----------------------------
7980 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
7981 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7982 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
7985 if No
(Actions
) then
7988 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7989 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7991 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7996 elsif AK
= Before
then
7997 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8000 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8002 end Store_Actions_In_Scope
;
8004 ----------------------------------
8005 -- Store_After_Actions_In_Scope --
8006 ----------------------------------
8008 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8010 Store_Actions_In_Scope
(After
, L
);
8011 end Store_After_Actions_In_Scope
;
8013 -----------------------------------
8014 -- Store_Before_Actions_In_Scope --
8015 -----------------------------------
8017 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8019 Store_Actions_In_Scope
(Before
, L
);
8020 end Store_Before_Actions_In_Scope
;
8022 -----------------------------------
8023 -- Store_Cleanup_Actions_In_Scope --
8024 -----------------------------------
8026 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8028 Store_Actions_In_Scope
(Cleanup
, L
);
8029 end Store_Cleanup_Actions_In_Scope
;
8031 --------------------------------
8032 -- Wrap_Transient_Declaration --
8033 --------------------------------
8035 -- If a transient scope has been established during the processing of the
8036 -- Expression of an Object_Declaration, it is not possible to wrap the
8037 -- declaration into a transient block as usual case, otherwise the object
8038 -- would be itself declared in the wrong scope. Therefore, all entities (if
8039 -- any) defined in the transient block are moved to the proper enclosing
8040 -- scope. Furthermore, if they are controlled variables they are finalized
8041 -- right after the declaration. The finalization list of the transient
8042 -- scope is defined as a renaming of the enclosing one so during their
8043 -- initialization they will be attached to the proper finalization list.
8044 -- For instance, the following declaration :
8046 -- X : Typ := F (G (A), G (B));
8048 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8049 -- is expanded into :
8051 -- X : Typ := [ complex Expression-Action ];
8052 -- [Deep_]Finalize (_v1);
8053 -- [Deep_]Finalize (_v2);
8055 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8060 Curr_S
:= Current_Scope
;
8061 Encl_S
:= Scope
(Curr_S
);
8063 -- Insert all actions inluding cleanup generated while analyzing or
8064 -- expanding the transient context back into the tree. Manage the
8065 -- secondary stack when the object declaration appears in a library
8066 -- level package [body]. This is not needed for .NET/JVM as those do
8067 -- not support the secondary stack.
8069 Insert_Actions_In_Scope_Around
8074 and then Uses_Sec_Stack
(Curr_S
)
8075 and then Nkind
(N
) = N_Object_Declaration
8076 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8077 and then Is_Library_Level_Entity
(Encl_S
));
8080 -- Relocate local entities declared within the transient scope to the
8081 -- enclosing scope. This action sets their Is_Public flag accordingly.
8083 Transfer_Entities
(Curr_S
, Encl_S
);
8085 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8086 -- is properly released upon exiting the said scope. This is not needed
8087 -- for .NET/JVM as those do not support the secondary stack.
8089 if VM_Target
= No_VM
and then Uses_Sec_Stack
(Curr_S
) then
8090 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8092 -- Do not mark a function that returns on the secondary stack as the
8093 -- reclamation is done by the caller.
8095 if Ekind
(Curr_S
) = E_Function
8096 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8100 -- Otherwise mark the enclosing dynamic scope
8103 Set_Uses_Sec_Stack
(Curr_S
);
8104 Check_Restriction
(No_Secondary_Stack
, N
);
8107 end Wrap_Transient_Declaration
;
8109 -------------------------------
8110 -- Wrap_Transient_Expression --
8111 -------------------------------
8113 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8114 Loc
: constant Source_Ptr
:= Sloc
(N
);
8115 Expr
: Node_Id
:= Relocate_Node
(N
);
8116 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8117 Typ
: constant Entity_Id
:= Etype
(N
);
8124 -- M : constant Mark_Id := SS_Mark;
8125 -- procedure Finalizer is ... (See Build_Finalizer)
8128 -- Temp := <Expr>; -- general case
8129 -- Temp := (if <Expr> then True else False); -- boolean case
8135 -- A special case is made for Boolean expressions so that the back-end
8136 -- knows to generate a conditional branch instruction, if running with
8137 -- -fpreserve-control-flow. This ensures that a control flow change
8138 -- signalling the decision outcome occurs before the cleanup actions.
8140 if Opt
.Suppress_Control_Flow_Optimizations
8141 and then Is_Boolean_Type
(Typ
)
8144 Make_If_Expression
(Loc
,
8145 Expressions
=> New_List
(
8147 New_Occurrence_Of
(Standard_True
, Loc
),
8148 New_Occurrence_Of
(Standard_False
, Loc
)));
8151 Insert_Actions
(N
, New_List
(
8152 Make_Object_Declaration
(Loc
,
8153 Defining_Identifier
=> Temp
,
8154 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8156 Make_Transient_Block
(Loc
,
8158 Make_Assignment_Statement
(Loc
,
8159 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8160 Expression
=> Expr
),
8161 Par
=> Parent
(N
))));
8163 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8164 Analyze_And_Resolve
(N
, Typ
);
8165 end Wrap_Transient_Expression
;
8167 ------------------------------
8168 -- Wrap_Transient_Statement --
8169 ------------------------------
8171 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8172 Loc
: constant Source_Ptr
:= Sloc
(N
);
8173 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8178 -- M : constant Mark_Id := SS_Mark;
8179 -- procedure Finalizer is ... (See Build_Finalizer)
8189 Make_Transient_Block
(Loc
,
8191 Par
=> Parent
(N
)));
8193 -- With the scope stack back to normal, we can call analyze on the
8194 -- resulting block. At this point, the transient scope is being
8195 -- treated like a perfectly normal scope, so there is nothing
8196 -- special about it.
8198 -- Note: Wrap_Transient_Statement is called with the node already
8199 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8200 -- otherwise we would get a recursive processing of the node when
8201 -- we do this Analyze call.
8204 end Wrap_Transient_Statement
;