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
);
3665 -- Otherwise, introduce a conversion when the designated object
3666 -- has a type derived from the formal of the controlled routine.
3668 elsif Is_Private_Type
(Ftyp
)
3669 and then Present
(Atyp
)
3670 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
3672 return Unchecked_Convert_To
(Ftyp
, Arg
);
3679 ------------------------
3680 -- Enclosing_Function --
3681 ------------------------
3683 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3684 Func_Id
: Entity_Id
;
3688 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
3689 if Ekind
(Func_Id
) = E_Function
then
3693 Func_Id
:= Scope
(Func_Id
);
3697 end Enclosing_Function
;
3699 -------------------------------
3700 -- Establish_Transient_Scope --
3701 -------------------------------
3703 -- This procedure is called each time a transient block has to be inserted
3704 -- that is to say for each call to a function with unconstrained or tagged
3705 -- result. It creates a new scope on the stack scope in order to enclose
3706 -- all transient variables generated.
3708 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3709 Loc
: constant Source_Ptr
:= Sloc
(N
);
3710 Iter_Loop
: Entity_Id
;
3711 Wrap_Node
: Node_Id
;
3714 -- Do not create a transient scope if we are already inside one
3716 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3717 if Scope_Stack
.Table
(S
).Is_Transient
then
3719 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3724 -- If we encounter Standard there are no enclosing transient scopes
3726 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3731 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3733 -- The context does not contain a node that requires a transient scope,
3736 if No
(Wrap_Node
) then
3739 -- If the node to wrap is an iteration_scheme, the expression is one of
3740 -- the bounds, and the expansion will make an explicit declaration for
3741 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3742 -- transformations here. Same for an Ada 2012 iterator specification,
3743 -- where a block is created for the expression that build the container.
3745 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3746 N_Iterator_Specification
)
3750 -- In formal verification mode, if the node to wrap is a pragma check,
3751 -- this node and enclosed expression are not expanded, so do not apply
3752 -- any transformations here.
3754 elsif GNATprove_Mode
3755 and then Nkind
(Wrap_Node
) = N_Pragma
3756 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3760 -- Create a block entity to act as a transient scope. Note that when the
3761 -- node to be wrapped is an expression or a statement, a real physical
3762 -- block is constructed (see routines Wrap_Transient_Expression and
3763 -- Wrap_Transient_Statement) and inserted into the tree.
3766 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3767 Set_Scope_Is_Transient
;
3769 -- The transient scope must also take care of the secondary stack
3773 Set_Uses_Sec_Stack
(Current_Scope
);
3774 Check_Restriction
(No_Secondary_Stack
, N
);
3776 -- The expansion of iterator loops generates references to objects
3777 -- in order to extract elements from a container:
3779 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3780 -- Obj : <object type> renames Ref.all.Element.all;
3782 -- These references are controlled and returned on the secondary
3783 -- stack. A new reference is created at each iteration of the loop
3784 -- and as a result it must be finalized and the space occupied by
3785 -- it on the secondary stack reclaimed at the end of the current
3788 -- When the context that requires a transient scope is a call to
3789 -- routine Reference, the node to be wrapped is the source object:
3791 -- for Obj of Container loop
3793 -- Routine Wrap_Transient_Declaration however does not generate a
3794 -- physical block as wrapping a declaration will kill it too ealy.
3795 -- To handle this peculiar case, mark the related iterator loop as
3796 -- requiring the secondary stack. This signals the finalization
3797 -- machinery to manage the secondary stack (see routine
3798 -- Process_Statements_For_Controlled_Objects).
3800 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
3802 if Present
(Iter_Loop
) then
3803 Set_Uses_Sec_Stack
(Iter_Loop
);
3807 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3808 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3810 if Debug_Flag_W
then
3811 Write_Str
(" <Transient>");
3815 end Establish_Transient_Scope
;
3817 ----------------------------
3818 -- Expand_Cleanup_Actions --
3819 ----------------------------
3821 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3822 Scop
: constant Entity_Id
:= Current_Scope
;
3824 Is_Asynchronous_Call
: constant Boolean :=
3825 Nkind
(N
) = N_Block_Statement
3826 and then Is_Asynchronous_Call_Block
(N
);
3827 Is_Master
: constant Boolean :=
3828 Nkind
(N
) /= N_Entry_Body
3829 and then Is_Task_Master
(N
);
3830 Is_Protected_Body
: constant Boolean :=
3831 Nkind
(N
) = N_Subprogram_Body
3832 and then Is_Protected_Subprogram_Body
(N
);
3833 Is_Task_Allocation
: constant Boolean :=
3834 Nkind
(N
) = N_Block_Statement
3835 and then Is_Task_Allocation_Block
(N
);
3836 Is_Task_Body
: constant Boolean :=
3837 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3838 Needs_Sec_Stack_Mark
: constant Boolean :=
3839 Uses_Sec_Stack
(Scop
)
3841 not Sec_Stack_Needed_For_Return
(Scop
)
3842 and then VM_Target
= No_VM
;
3843 Needs_Custom_Cleanup
: constant Boolean :=
3844 Nkind
(N
) = N_Block_Statement
3845 and then Present
(Cleanup_Actions
(N
));
3847 Actions_Required
: constant Boolean :=
3848 Requires_Cleanup_Actions
(N
, True)
3849 or else Is_Asynchronous_Call
3851 or else Is_Protected_Body
3852 or else Is_Task_Allocation
3853 or else Is_Task_Body
3854 or else Needs_Sec_Stack_Mark
3855 or else Needs_Custom_Cleanup
;
3857 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3861 procedure Wrap_HSS_In_Block
;
3862 -- Move HSS inside a new block along with the original exception
3863 -- handlers. Make the newly generated block the sole statement of HSS.
3865 -----------------------
3866 -- Wrap_HSS_In_Block --
3867 -----------------------
3869 procedure Wrap_HSS_In_Block
is
3874 -- Preserve end label to provide proper cross-reference information
3876 End_Lab
:= End_Label
(HSS
);
3878 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3880 -- Signal the finalization machinery that this particular block
3881 -- contains the original context.
3883 Set_Is_Finalization_Wrapper
(Block
);
3885 Set_Handled_Statement_Sequence
(N
,
3886 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3887 HSS
:= Handled_Statement_Sequence
(N
);
3889 Set_First_Real_Statement
(HSS
, Block
);
3890 Set_End_Label
(HSS
, End_Lab
);
3892 -- Comment needed here, see RH for 1.306 ???
3894 if Nkind
(N
) = N_Subprogram_Body
then
3895 Set_Has_Nested_Block_With_Handler
(Scop
);
3897 end Wrap_HSS_In_Block
;
3899 -- Start of processing for Expand_Cleanup_Actions
3902 -- The current construct does not need any form of servicing
3904 if not Actions_Required
then
3907 -- If the current node is a rewritten task body and the descriptors have
3908 -- not been delayed (due to some nested instantiations), do not generate
3909 -- redundant cleanup actions.
3912 and then Nkind
(N
) = N_Subprogram_Body
3913 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3918 if Needs_Custom_Cleanup
then
3919 Cln
:= Cleanup_Actions
(N
);
3925 Decls
: List_Id
:= Declarations
(N
);
3927 Mark
: Entity_Id
:= Empty
;
3928 New_Decls
: List_Id
;
3932 -- If we are generating expanded code for debugging purposes, use the
3933 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3934 -- be updated subsequently to reference the proper line in .dg files.
3935 -- If we are not debugging generated code, use No_Location instead,
3936 -- so that no debug information is generated for the cleanup code.
3937 -- This makes the behavior of the NEXT command in GDB monotonic, and
3938 -- makes the placement of breakpoints more accurate.
3940 if Debug_Generated_Code
then
3946 -- Set polling off. The finalization and cleanup code is executed
3947 -- with aborts deferred.
3949 Old_Poll
:= Polling_Required
;
3950 Polling_Required
:= False;
3952 -- A task activation call has already been built for a task
3953 -- allocation block.
3955 if not Is_Task_Allocation
then
3956 Build_Task_Activation_Call
(N
);
3960 Establish_Task_Master
(N
);
3963 New_Decls
:= New_List
;
3965 -- If secondary stack is in use, generate:
3967 -- Mnn : constant Mark_Id := SS_Mark;
3969 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3970 -- secondary stack is never used on a VM.
3972 if Needs_Sec_Stack_Mark
then
3973 Mark
:= Make_Temporary
(Loc
, 'M');
3975 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
3976 Set_Uses_Sec_Stack
(Scop
, False);
3979 -- If exception handlers are present, wrap the sequence of statements
3980 -- in a block since it is not possible to have exception handlers and
3981 -- an At_End handler in the same construct.
3983 if Present
(Exception_Handlers
(HSS
)) then
3986 -- Ensure that the First_Real_Statement field is set
3988 elsif No
(First_Real_Statement
(HSS
)) then
3989 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3992 -- Do not move the Activation_Chain declaration in the context of
3993 -- task allocation blocks. Task allocation blocks use _chain in their
3994 -- cleanup handlers and gigi complains if it is declared in the
3995 -- sequence of statements of the scope that declares the handler.
3997 if Is_Task_Allocation
then
3999 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4003 Decl
:= First
(Decls
);
4004 while Nkind
(Decl
) /= N_Object_Declaration
4005 or else Defining_Identifier
(Decl
) /= Chain
4009 -- A task allocation block should always include a _chain
4012 pragma Assert
(Present
(Decl
));
4016 Prepend_To
(New_Decls
, Decl
);
4020 -- Ensure the presence of a declaration list in order to successfully
4021 -- append all original statements to it.
4024 Set_Declarations
(N
, New_List
);
4025 Decls
:= Declarations
(N
);
4028 -- Move the declarations into the sequence of statements in order to
4029 -- have them protected by the At_End handler. It may seem weird to
4030 -- put declarations in the sequence of statement but in fact nothing
4031 -- forbids that at the tree level.
4033 Append_List_To
(Decls
, Statements
(HSS
));
4034 Set_Statements
(HSS
, Decls
);
4036 -- Reset the Sloc of the handled statement sequence to properly
4037 -- reflect the new initial "statement" in the sequence.
4039 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4041 -- The declarations of finalizer spec and auxiliary variables replace
4042 -- the old declarations that have been moved inward.
4044 Set_Declarations
(N
, New_Decls
);
4045 Analyze_Declarations
(New_Decls
);
4047 -- Generate finalization calls for all controlled objects appearing
4048 -- in the statements of N. Add context specific cleanup for various
4053 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4055 Top_Decls
=> New_Decls
,
4056 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4060 if Present
(Fin_Id
) then
4061 Build_Finalizer_Call
(N
, Fin_Id
);
4064 -- Restore saved polling mode
4066 Polling_Required
:= Old_Poll
;
4068 end Expand_Cleanup_Actions
;
4070 ---------------------------
4071 -- Expand_N_Package_Body --
4072 ---------------------------
4074 -- Add call to Activate_Tasks if body is an activator (actual processing
4075 -- is in chapter 9).
4077 -- Generate subprogram descriptor for elaboration routine
4079 -- Encode entity names in package body
4081 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4082 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
4086 -- This is done only for non-generic packages
4088 if Ekind
(Spec_Ent
) = E_Package
then
4089 Push_Scope
(Corresponding_Spec
(N
));
4091 -- Build dispatch tables of library level tagged types
4093 if Tagged_Type_Expansion
4094 and then Is_Library_Level_Entity
(Spec_Ent
)
4096 Build_Static_Dispatch_Tables
(N
);
4099 Build_Task_Activation_Call
(N
);
4101 -- When the package is subject to pragma Initial_Condition, the
4102 -- assertion expression must be verified at the end of the body
4105 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
4106 Expand_Pragma_Initial_Condition
(N
);
4112 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4113 Set_In_Package_Body
(Spec_Ent
, False);
4115 -- Set to encode entity names in package body before gigi is called
4117 Qualify_Entity_Names
(N
);
4119 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
4122 Clean_Stmts
=> No_List
,
4124 Top_Decls
=> No_List
,
4125 Defer_Abort
=> False,
4128 if Present
(Fin_Id
) then
4130 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4133 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4134 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4137 Set_Finalizer
(Body_Ent
, Fin_Id
);
4141 end Expand_N_Package_Body
;
4143 ----------------------------------
4144 -- Expand_N_Package_Declaration --
4145 ----------------------------------
4147 -- Add call to Activate_Tasks if there are tasks declared and the package
4148 -- has no body. Note that in Ada 83 this may result in premature activation
4149 -- of some tasks, given that we cannot tell whether a body will eventually
4152 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4153 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4154 Spec
: constant Node_Id
:= Specification
(N
);
4158 No_Body
: Boolean := False;
4159 -- True in the case of a package declaration that is a compilation
4160 -- unit and for which no associated body will be compiled in this
4164 -- Case of a package declaration other than a compilation unit
4166 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4169 -- Case of a compilation unit that does not require a body
4171 elsif not Body_Required
(Parent
(N
))
4172 and then not Unit_Requires_Body
(Id
)
4176 -- Special case of generating calling stubs for a remote call interface
4177 -- package: even though the package declaration requires one, the body
4178 -- won't be processed in this compilation (so any stubs for RACWs
4179 -- declared in the package must be generated here, along with the spec).
4181 elsif Parent
(N
) = Cunit
(Main_Unit
)
4182 and then Is_Remote_Call_Interface
(Id
)
4183 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4188 -- For a nested instance, delay processing until freeze point
4190 if Has_Delayed_Freeze
(Id
)
4191 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4196 -- For a package declaration that implies no associated body, generate
4197 -- task activation call and RACW supporting bodies now (since we won't
4198 -- have a specific separate compilation unit for that).
4203 -- Generate RACW subprogram bodies
4205 if Has_RACW
(Id
) then
4206 Decls
:= Private_Declarations
(Spec
);
4209 Decls
:= Visible_Declarations
(Spec
);
4214 Set_Visible_Declarations
(Spec
, Decls
);
4217 Append_RACW_Bodies
(Decls
, Id
);
4218 Analyze_List
(Decls
);
4221 -- Generate task activation call as last step of elaboration
4223 if Present
(Activation_Chain_Entity
(N
)) then
4224 Build_Task_Activation_Call
(N
);
4227 -- When the package is subject to pragma Initial_Condition and lacks
4228 -- a body, the assertion expression must be verified at the end of
4229 -- the visible declarations. Otherwise the check is performed at the
4230 -- end of the body statements (see Expand_N_Package_Body).
4232 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4233 Expand_Pragma_Initial_Condition
(N
);
4239 -- Build dispatch tables of library level tagged types
4241 if Tagged_Type_Expansion
4242 and then (Is_Compilation_Unit
(Id
)
4243 or else (Is_Generic_Instance
(Id
)
4244 and then Is_Library_Level_Entity
(Id
)))
4246 Build_Static_Dispatch_Tables
(N
);
4249 -- Note: it is not necessary to worry about generating a subprogram
4250 -- descriptor, since the only way to get exception handlers into a
4251 -- package spec is to include instantiations, and that would cause
4252 -- generation of subprogram descriptors to be delayed in any case.
4254 -- Set to encode entity names in package spec before gigi is called
4256 Qualify_Entity_Names
(N
);
4258 if Ekind
(Id
) /= E_Generic_Package
then
4261 Clean_Stmts
=> No_List
,
4263 Top_Decls
=> No_List
,
4264 Defer_Abort
=> False,
4267 Set_Finalizer
(Id
, Fin_Id
);
4269 end Expand_N_Package_Declaration
;
4271 -----------------------------
4272 -- Find_Node_To_Be_Wrapped --
4273 -----------------------------
4275 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4277 The_Parent
: Node_Id
;
4283 case Nkind
(The_Parent
) is
4285 -- Simple statement can be wrapped
4290 -- Usually assignments are good candidate for wrapping except
4291 -- when they have been generated as part of a controlled aggregate
4292 -- where the wrapping should take place more globally. Note that
4293 -- No_Ctrl_Actions may be set also for non-controlled assignements
4294 -- in order to disable the use of dispatching _assign, so we need
4295 -- to test explicitly for a controlled type here.
4297 when N_Assignment_Statement
=>
4298 if No_Ctrl_Actions
(The_Parent
)
4299 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4306 -- An entry call statement is a special case if it occurs in the
4307 -- context of a Timed_Entry_Call. In this case we wrap the entire
4308 -- timed entry call.
4310 when N_Entry_Call_Statement |
4311 N_Procedure_Call_Statement
=>
4312 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4313 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4315 N_Conditional_Entry_Call
)
4317 return Parent
(Parent
(The_Parent
));
4322 -- Object declarations are also a boundary for the transient scope
4323 -- even if they are not really wrapped. For further details, see
4324 -- Wrap_Transient_Declaration.
4326 when N_Object_Declaration |
4327 N_Object_Renaming_Declaration |
4328 N_Subtype_Declaration
=>
4331 -- The expression itself is to be wrapped if its parent is a
4332 -- compound statement or any other statement where the expression
4333 -- is known to be scalar.
4335 when N_Accept_Alternative |
4336 N_Attribute_Definition_Clause |
4339 N_Delay_Alternative |
4340 N_Delay_Until_Statement |
4341 N_Delay_Relative_Statement |
4342 N_Discriminant_Association |
4344 N_Entry_Body_Formal_Part |
4347 N_Iteration_Scheme |
4348 N_Terminate_Alternative
=>
4349 pragma Assert
(Present
(P
));
4352 when N_Attribute_Reference
=>
4354 if Is_Procedure_Attribute_Name
4355 (Attribute_Name
(The_Parent
))
4360 -- A raise statement can be wrapped. This will arise when the
4361 -- expression in a raise_with_expression uses the secondary
4362 -- stack, for example.
4364 when N_Raise_Statement
=>
4367 -- If the expression is within the iteration scheme of a loop,
4368 -- we must create a declaration for it, followed by an assignment
4369 -- in order to have a usable statement to wrap.
4371 when N_Loop_Parameter_Specification
=>
4372 return Parent
(The_Parent
);
4374 -- The following nodes contains "dummy calls" which don't need to
4377 when N_Parameter_Specification |
4378 N_Discriminant_Specification |
4379 N_Component_Declaration
=>
4382 -- The return statement is not to be wrapped when the function
4383 -- itself needs wrapping at the outer-level
4385 when N_Simple_Return_Statement
=>
4387 Applies_To
: constant Entity_Id
:=
4389 (Return_Statement_Entity
(The_Parent
));
4390 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4392 if Requires_Transient_Scope
(Return_Type
) then
4399 -- If we leave a scope without having been able to find a node to
4400 -- wrap, something is going wrong but this can happen in error
4401 -- situation that are not detected yet (such as a dynamic string
4402 -- in a pragma export)
4404 when N_Subprogram_Body |
4405 N_Package_Declaration |
4407 N_Block_Statement
=>
4410 -- Otherwise continue the search
4417 The_Parent
:= Parent
(P
);
4419 end Find_Node_To_Be_Wrapped
;
4421 ----------------------------------
4422 -- Has_New_Controlled_Component --
4423 ----------------------------------
4425 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4429 if not Is_Tagged_Type
(E
) then
4430 return Has_Controlled_Component
(E
);
4431 elsif not Is_Derived_Type
(E
) then
4432 return Has_Controlled_Component
(E
);
4435 Comp
:= First_Component
(E
);
4436 while Present
(Comp
) loop
4437 if Chars
(Comp
) = Name_uParent
then
4440 elsif Scope
(Original_Record_Component
(Comp
)) = E
4441 and then Needs_Finalization
(Etype
(Comp
))
4446 Next_Component
(Comp
);
4450 end Has_New_Controlled_Component
;
4452 ---------------------------------
4453 -- Has_Simple_Protected_Object --
4454 ---------------------------------
4456 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4458 if Has_Task
(T
) then
4461 elsif Is_Simple_Protected_Type
(T
) then
4464 elsif Is_Array_Type
(T
) then
4465 return Has_Simple_Protected_Object
(Component_Type
(T
));
4467 elsif Is_Record_Type
(T
) then
4472 Comp
:= First_Component
(T
);
4473 while Present
(Comp
) loop
4474 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4478 Next_Component
(Comp
);
4487 end Has_Simple_Protected_Object
;
4489 ------------------------------------
4490 -- Insert_Actions_In_Scope_Around --
4491 ------------------------------------
4493 procedure Insert_Actions_In_Scope_Around
4496 Manage_SS
: Boolean)
4498 Act_Before
: constant List_Id
:=
4499 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4500 Act_After
: constant List_Id
:=
4501 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4502 Act_Cleanup
: constant List_Id
:=
4503 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4504 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4505 -- Last), but this was incorrect as Process_Transient_Object may
4506 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4508 procedure Process_Transient_Objects
4509 (First_Object
: Node_Id
;
4510 Last_Object
: Node_Id
;
4511 Related_Node
: Node_Id
);
4512 -- First_Object and Last_Object define a list which contains potential
4513 -- controlled transient objects. Finalization flags are inserted before
4514 -- First_Object and finalization calls are inserted after Last_Object.
4515 -- Related_Node is the node for which transient objects have been
4518 -------------------------------
4519 -- Process_Transient_Objects --
4520 -------------------------------
4522 procedure Process_Transient_Objects
4523 (First_Object
: Node_Id
;
4524 Last_Object
: Node_Id
;
4525 Related_Node
: Node_Id
)
4527 Must_Hook
: Boolean := False;
4528 -- Flag denoting whether the context requires transient variable
4529 -- export to the outer finalizer.
4531 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4532 -- Determine whether an arbitrary node denotes a subprogram call
4534 procedure Detect_Subprogram_Call
is
4535 new Traverse_Proc
(Is_Subprogram_Call
);
4537 ------------------------
4538 -- Is_Subprogram_Call --
4539 ------------------------
4541 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4543 -- Complex constructs are factored out by the expander and their
4544 -- occurrences are replaced with references to temporaries or
4545 -- object renamings. Due to this expansion activity, inspect the
4546 -- original tree to detect subprogram calls.
4548 if Nkind_In
(N
, N_Identifier
,
4549 N_Object_Renaming_Declaration
)
4550 and then Original_Node
(N
) /= N
4552 Detect_Subprogram_Call
(Original_Node
(N
));
4554 -- The original construct contains a subprogram call, there is
4555 -- no point in continuing the tree traversal.
4563 -- The original construct contains a subprogram call, there is no
4564 -- point in continuing the tree traversal.
4566 elsif Nkind
(N
) = N_Object_Declaration
4567 and then Present
(Expression
(N
))
4568 and then Nkind
(Original_Node
(Expression
(N
))) = N_Function_Call
4573 -- A regular procedure or function call
4575 elsif Nkind
(N
) in N_Subprogram_Call
then
4584 end Is_Subprogram_Call
;
4588 Built
: Boolean := False;
4589 Desig_Typ
: Entity_Id
;
4591 Fin_Block
: Node_Id
;
4592 Fin_Data
: Finalization_Exception_Data
;
4593 Fin_Decls
: List_Id
;
4594 Fin_Insrt
: Node_Id
;
4595 Last_Fin
: Node_Id
:= Empty
;
4599 Obj_Typ
: Entity_Id
;
4600 Prev_Fin
: Node_Id
:= Empty
;
4604 Temp_Id
: Entity_Id
;
4607 -- Start of processing for Process_Transient_Objects
4610 -- Recognize a scenario where the transient context is an object
4611 -- declaration initialized by a build-in-place function call:
4613 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4615 -- The rough expansion of the above is:
4617 -- Temp : ... := Ctrl_Func_Call;
4619 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4621 -- The finalization of any controlled transient must happen after
4622 -- the build-in-place function call is executed.
4624 if Nkind
(N
) = N_Object_Declaration
4625 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
4628 Fin_Insrt
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
4630 -- Search the context for at least one subprogram call. If found, the
4631 -- machinery exports all transient objects to the enclosing finalizer
4632 -- due to the possibility of abnormal call termination.
4635 Detect_Subprogram_Call
(N
);
4636 Fin_Insrt
:= Last_Object
;
4639 -- Examine all objects in the list First_Object .. Last_Object
4641 Stmt
:= First_Object
;
4642 while Present
(Stmt
) loop
4643 if Nkind
(Stmt
) = N_Object_Declaration
4644 and then Analyzed
(Stmt
)
4645 and then Is_Finalizable_Transient
(Stmt
, N
)
4647 -- Do not process the node to be wrapped since it will be
4648 -- handled by the enclosing finalizer.
4650 and then Stmt
/= Related_Node
4653 Obj_Id
:= Defining_Identifier
(Stmt
);
4654 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4655 Desig_Typ
:= Obj_Typ
;
4657 Set_Is_Processed_Transient
(Obj_Id
);
4659 -- Handle access types
4661 if Is_Access_Type
(Desig_Typ
) then
4662 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4665 -- Create the necessary entities and declarations the first
4670 Fin_Decls
:= New_List
;
4672 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4675 -- Transient variables associated with subprogram calls need
4676 -- extra processing. These variables are usually created right
4677 -- before the call and finalized immediately after the call.
4678 -- If an exception occurs during the call, the clean up code
4679 -- is skipped due to the sudden change in control and the
4680 -- transient is never finalized.
4682 -- To handle this case, such variables are "exported" to the
4683 -- enclosing sequence of statements where their corresponding
4684 -- "hooks" are picked up by the finalization machinery.
4688 -- Step 1: Create an access type which provides a reference
4689 -- to the transient object. Generate:
4691 -- Ann : access [all] <Desig_Typ>;
4693 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4695 Insert_Action
(Stmt
,
4696 Make_Full_Type_Declaration
(Loc
,
4697 Defining_Identifier
=> Ptr_Id
,
4699 Make_Access_To_Object_Definition
(Loc
,
4701 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4702 Subtype_Indication
=>
4703 New_Occurrence_Of
(Desig_Typ
, Loc
))));
4705 -- Step 2: Create a temporary which acts as a hook to the
4706 -- transient object. Generate:
4708 -- Temp : Ptr_Id := null;
4710 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4712 Insert_Action
(Stmt
,
4713 Make_Object_Declaration
(Loc
,
4714 Defining_Identifier
=> Temp_Id
,
4715 Object_Definition
=>
4716 New_Occurrence_Of
(Ptr_Id
, Loc
)));
4718 -- Mark the temporary as a transient hook. This signals the
4719 -- machinery in Build_Finalizer to recognize this special
4722 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4724 -- Step 3: Hook the transient object to the temporary
4726 if Is_Access_Type
(Obj_Typ
) then
4728 Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
4731 Make_Attribute_Reference
(Loc
,
4732 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
4733 Attribute_Name
=> Name_Unrestricted_Access
);
4737 -- Temp := Ptr_Id (Obj_Id);
4739 -- Temp := Obj_Id'Unrestricted_Access;
4741 -- When the transient object is initialized by an aggregate,
4742 -- the hook must capture the object after the last component
4743 -- assignment takes place. Only then is the object fully
4746 if Ekind
(Obj_Id
) = E_Variable
4747 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
4749 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
4751 -- Otherwise the hook seizes the related object immediately
4757 Insert_After_And_Analyze
(Temp_Ins
,
4758 Make_Assignment_Statement
(Loc
,
4759 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4760 Expression
=> Expr
));
4765 -- The transient object is about to be finalized by the clean
4766 -- up code following the subprogram call. In order to avoid
4767 -- double finalization, clear the hook.
4774 Make_Assignment_Statement
(Loc
,
4775 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4776 Expression
=> Make_Null
(Loc
)));
4780 -- [Deep_]Finalize (Obj_Ref);
4782 -- Set type of dereference, so that proper conversion are
4783 -- generated when operation is inherited.
4785 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
4787 if Is_Access_Type
(Obj_Typ
) then
4788 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4789 Set_Etype
(Obj_Ref
, Directly_Designated_Type
(Obj_Typ
));
4793 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4798 -- [Deep_]Finalize (Obj_Ref);
4802 -- if not Raised then
4805 -- (Enn, Get_Current_Excep.all.all);
4810 Make_Block_Statement
(Loc
,
4811 Handled_Statement_Sequence
=>
4812 Make_Handled_Sequence_Of_Statements
(Loc
,
4813 Statements
=> Stmts
,
4814 Exception_Handlers
=> New_List
(
4815 Build_Exception_Handler
(Fin_Data
))));
4817 -- The single raise statement must be inserted after all the
4818 -- finalization blocks, and we put everything into a wrapper
4819 -- block to clearly expose the construct to the back-end.
4821 if Present
(Prev_Fin
) then
4822 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4824 Insert_After_And_Analyze
(Fin_Insrt
,
4825 Make_Block_Statement
(Loc
,
4826 Declarations
=> Fin_Decls
,
4827 Handled_Statement_Sequence
=>
4828 Make_Handled_Sequence_Of_Statements
(Loc
,
4829 Statements
=> New_List
(Fin_Block
))));
4831 Last_Fin
:= Fin_Block
;
4834 Prev_Fin
:= Fin_Block
;
4837 -- Terminate the scan after the last object has been processed to
4838 -- avoid touching unrelated code.
4840 if Stmt
= Last_Object
then
4848 if Present
(Prev_Fin
) then
4849 Insert_List_Before_And_Analyze
(Prev_Fin
, Act_Cleanup
);
4851 Insert_List_After_And_Analyze
(Fin_Insrt
, Act_Cleanup
);
4856 -- if Raised and then not Abort then
4857 -- Raise_From_Controlled_Operation (E);
4860 if Built
and then Present
(Last_Fin
) then
4861 Insert_After_And_Analyze
(Last_Fin
,
4862 Build_Raise_Statement
(Fin_Data
));
4864 end Process_Transient_Objects
;
4868 Loc
: constant Source_Ptr
:= Sloc
(N
);
4869 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4870 First_Obj
: Node_Id
;
4872 Mark_Id
: Entity_Id
;
4875 -- Start of processing for Insert_Actions_In_Scope_Around
4878 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
4882 -- If the node to be wrapped is the trigger of an asynchronous select,
4883 -- it is not part of a statement list. The actions must be inserted
4884 -- before the select itself, which is part of some list of statements.
4885 -- Note that the triggering alternative includes the triggering
4886 -- statement and an optional statement list. If the node to be
4887 -- wrapped is part of that list, the normal insertion applies.
4889 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4890 and then not Is_List_Member
(Node_To_Wrap
)
4892 Target
:= Parent
(Parent
(Node_To_Wrap
));
4897 First_Obj
:= Target
;
4900 -- Add all actions associated with a transient scope into the main tree.
4901 -- There are several scenarios here:
4903 -- +--- Before ----+ +----- After ---+
4904 -- 1) First_Obj ....... Target ........ Last_Obj
4906 -- 2) First_Obj ....... Target
4908 -- 3) Target ........ Last_Obj
4910 -- Flag declarations are inserted before the first object
4912 if Present
(Act_Before
) then
4913 First_Obj
:= First
(Act_Before
);
4914 Insert_List_Before
(Target
, Act_Before
);
4917 -- Finalization calls are inserted after the last object
4919 if Present
(Act_After
) then
4920 Last_Obj
:= Last
(Act_After
);
4921 Insert_List_After
(Target
, Act_After
);
4924 -- Mark and release the secondary stack when the context warrants it
4927 Mark_Id
:= Make_Temporary
(Loc
, 'M');
4930 -- Mnn : constant Mark_Id := SS_Mark;
4932 Insert_Before_And_Analyze
4933 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
4936 -- SS_Release (Mnn);
4938 Insert_After_And_Analyze
4939 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
4942 -- Check for transient controlled objects associated with Target and
4943 -- generate the appropriate finalization actions for them.
4945 Process_Transient_Objects
4946 (First_Object
=> First_Obj
,
4947 Last_Object
=> Last_Obj
,
4948 Related_Node
=> Target
);
4950 -- Reset the action lists
4953 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
4955 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
4959 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
4961 end Insert_Actions_In_Scope_Around
;
4963 ------------------------------
4964 -- Is_Simple_Protected_Type --
4965 ------------------------------
4967 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4970 Is_Protected_Type
(T
)
4971 and then not Uses_Lock_Free
(T
)
4972 and then not Has_Entries
(T
)
4973 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4974 end Is_Simple_Protected_Type
;
4976 -----------------------
4977 -- Make_Adjust_Call --
4978 -----------------------
4980 function Make_Adjust_Call
4983 Skip_Self
: Boolean := False) return Node_Id
4985 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4986 Adj_Id
: Entity_Id
:= Empty
;
4987 Ref
: Node_Id
:= Obj_Ref
;
4991 -- Recover the proper type which contains Deep_Adjust
4993 if Is_Class_Wide_Type
(Typ
) then
4994 Utyp
:= Root_Type
(Typ
);
4999 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5000 Set_Assignment_OK
(Ref
);
5002 -- Deal with untagged derivation of private views
5004 if Is_Untagged_Derivation
(Typ
) then
5005 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5006 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5007 Set_Assignment_OK
(Ref
);
5010 -- When dealing with the completion of a private type, use the base
5013 if Utyp
/= Base_Type
(Utyp
) then
5014 pragma Assert
(Is_Private_Type
(Typ
));
5016 Utyp
:= Base_Type
(Utyp
);
5017 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5021 if Has_Controlled_Component
(Utyp
) then
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
);
5029 -- Class-wide types, interfaces and types with controlled components
5031 elsif Is_Class_Wide_Type
(Typ
)
5032 or else Is_Interface
(Typ
)
5033 or else Has_Controlled_Component
(Utyp
)
5035 if Is_Tagged_Type
(Utyp
) then
5036 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5038 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5041 -- Derivations from [Limited_]Controlled
5043 elsif Is_Controlled
(Utyp
) then
5044 if Has_Controlled_Component
(Utyp
) then
5045 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5047 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5052 elsif Is_Tagged_Type
(Utyp
) then
5053 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5056 raise Program_Error
;
5059 if Present
(Adj_Id
) then
5061 -- If the object is unanalyzed, set its expected type for use in
5062 -- Convert_View in case an additional conversion is needed.
5065 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5067 Set_Etype
(Ref
, Typ
);
5070 -- The object reference may need another conversion depending on the
5071 -- type of the formal and that of the actual.
5073 if not Is_Class_Wide_Type
(Typ
) then
5074 Ref
:= Convert_View
(Adj_Id
, Ref
);
5080 Param
=> New_Copy_Tree
(Ref
),
5081 Skip_Self
=> Skip_Self
);
5085 end Make_Adjust_Call
;
5087 ----------------------
5088 -- Make_Attach_Call --
5089 ----------------------
5091 function Make_Attach_Call
5093 Ptr_Typ
: Entity_Id
) return Node_Id
5095 pragma Assert
(VM_Target
/= No_VM
);
5097 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5100 Make_Procedure_Call_Statement
(Loc
,
5102 New_Occurrence_Of
(RTE
(RE_Attach
), Loc
),
5103 Parameter_Associations
=> New_List
(
5104 New_Occurrence_Of
(Finalization_Master
(Ptr_Typ
), Loc
),
5105 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5106 end Make_Attach_Call
;
5108 ----------------------
5109 -- Make_Detach_Call --
5110 ----------------------
5112 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5113 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5117 Make_Procedure_Call_Statement
(Loc
,
5119 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5120 Parameter_Associations
=> New_List
(
5121 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5122 end Make_Detach_Call
;
5130 Proc_Id
: Entity_Id
;
5132 Skip_Self
: Boolean := False) return Node_Id
5134 Params
: constant List_Id
:= New_List
(Param
);
5137 -- Do not apply the controlled action to the object itself by signaling
5138 -- the related routine to avoid self.
5141 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5145 Make_Procedure_Call_Statement
(Loc
,
5146 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5147 Parameter_Associations
=> Params
);
5150 --------------------------
5151 -- Make_Deep_Array_Body --
5152 --------------------------
5154 function Make_Deep_Array_Body
5155 (Prim
: Final_Primitives
;
5156 Typ
: Entity_Id
) return List_Id
5158 function Build_Adjust_Or_Finalize_Statements
5159 (Typ
: Entity_Id
) return List_Id
;
5160 -- Create the statements necessary to adjust or finalize an array of
5161 -- controlled elements. Generate:
5164 -- Abort : constant Boolean := Triggered_By_Abort;
5166 -- Abort : constant Boolean := False; -- no abort
5168 -- E : Exception_Occurrence;
5169 -- Raised : Boolean := False;
5172 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5173 -- ^-- in the finalization case
5175 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5177 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5181 -- if not Raised then
5183 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5190 -- if Raised and then not Abort then
5191 -- Raise_From_Controlled_Operation (E);
5195 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5196 -- Create the statements necessary to initialize an array of controlled
5197 -- elements. Include a mechanism to carry out partial finalization if an
5198 -- exception occurs. Generate:
5201 -- Counter : Integer := 0;
5204 -- for J1 in V'Range (1) loop
5206 -- for JN in V'Range (N) loop
5208 -- [Deep_]Initialize (V (J1, ..., JN));
5210 -- Counter := Counter + 1;
5215 -- Abort : constant Boolean := Triggered_By_Abort;
5217 -- Abort : constant Boolean := False; -- no abort
5218 -- E : Exception_Occurence;
5219 -- Raised : Boolean := False;
5226 -- V'Length (N) - Counter;
5228 -- for F1 in reverse V'Range (1) loop
5230 -- for FN in reverse V'Range (N) loop
5231 -- if Counter > 0 then
5232 -- Counter := Counter - 1;
5235 -- [Deep_]Finalize (V (F1, ..., FN));
5239 -- if not Raised then
5241 -- Save_Occurrence (E,
5242 -- Get_Current_Excep.all.all);
5251 -- if Raised and then not Abort then
5252 -- Raise_From_Controlled_Operation (E);
5261 function New_References_To
5263 Loc
: Source_Ptr
) return List_Id
;
5264 -- Given a list of defining identifiers, return a list of references to
5265 -- the original identifiers, in the same order as they appear.
5267 -----------------------------------------
5268 -- Build_Adjust_Or_Finalize_Statements --
5269 -----------------------------------------
5271 function Build_Adjust_Or_Finalize_Statements
5272 (Typ
: Entity_Id
) return List_Id
5274 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5275 Index_List
: constant List_Id
:= New_List
;
5276 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5277 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5278 Finalizer_Decls
: List_Id
:= No_List
;
5279 Finalizer_Data
: Finalization_Exception_Data
;
5282 Core_Loop
: Node_Id
;
5285 Loop_Id
: Entity_Id
;
5288 Exceptions_OK
: constant Boolean :=
5289 not Restriction_Active
(No_Exception_Propagation
);
5291 procedure Build_Indexes
;
5292 -- Generate the indexes used in the dimension loops
5298 procedure Build_Indexes
is
5300 -- Generate the following identifiers:
5301 -- Jnn - for initialization
5303 for Dim
in 1 .. Num_Dims
loop
5304 Append_To
(Index_List
,
5305 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5309 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5312 Finalizer_Decls
:= New_List
;
5315 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5318 Make_Indexed_Component
(Loc
,
5319 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5320 Expressions
=> New_References_To
(Index_List
, Loc
));
5321 Set_Etype
(Comp_Ref
, Comp_Typ
);
5324 -- [Deep_]Adjust (V (J1, ..., JN))
5326 if Prim
= Adjust_Case
then
5327 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5330 -- [Deep_]Finalize (V (J1, ..., JN))
5332 else pragma Assert
(Prim
= Finalize_Case
);
5333 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5336 -- Generate the block which houses the adjust or finalize call:
5338 -- <adjust or finalize call>; -- No_Exception_Propagation
5340 -- begin -- Exception handlers allowed
5341 -- <adjust or finalize call>
5345 -- if not Raised then
5347 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5351 if Exceptions_OK
then
5353 Make_Block_Statement
(Loc
,
5354 Handled_Statement_Sequence
=>
5355 Make_Handled_Sequence_Of_Statements
(Loc
,
5356 Statements
=> New_List
(Call
),
5357 Exception_Handlers
=> New_List
(
5358 Build_Exception_Handler
(Finalizer_Data
))));
5363 -- Generate the dimension loops starting from the innermost one
5365 -- for Jnn in [reverse] V'Range (Dim) loop
5369 J
:= Last
(Index_List
);
5371 while Present
(J
) and then Dim
> 0 loop
5377 Make_Loop_Statement
(Loc
,
5379 Make_Iteration_Scheme
(Loc
,
5380 Loop_Parameter_Specification
=>
5381 Make_Loop_Parameter_Specification
(Loc
,
5382 Defining_Identifier
=> Loop_Id
,
5383 Discrete_Subtype_Definition
=>
5384 Make_Attribute_Reference
(Loc
,
5385 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5386 Attribute_Name
=> Name_Range
,
5387 Expressions
=> New_List
(
5388 Make_Integer_Literal
(Loc
, Dim
))),
5390 Reverse_Present
=> Prim
= Finalize_Case
)),
5392 Statements
=> New_List
(Core_Loop
),
5393 End_Label
=> Empty
);
5398 -- Generate the block which contains the core loop, the declarations
5399 -- of the abort flag, the exception occurrence, the raised flag and
5400 -- the conditional raise:
5403 -- Abort : constant Boolean := Triggered_By_Abort;
5405 -- Abort : constant Boolean := False; -- no abort
5407 -- E : Exception_Occurrence;
5408 -- Raised : Boolean := False;
5413 -- if Raised and then not Abort then -- Expection handlers OK
5414 -- Raise_From_Controlled_Operation (E);
5418 Stmts
:= New_List
(Core_Loop
);
5420 if Exceptions_OK
then
5422 Build_Raise_Statement
(Finalizer_Data
));
5427 Make_Block_Statement
(Loc
,
5430 Handled_Statement_Sequence
=>
5431 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5432 end Build_Adjust_Or_Finalize_Statements
;
5434 ---------------------------------
5435 -- Build_Initialize_Statements --
5436 ---------------------------------
5438 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5439 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5440 Final_List
: constant List_Id
:= New_List
;
5441 Index_List
: constant List_Id
:= New_List
;
5442 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5443 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5444 Counter_Id
: Entity_Id
;
5448 Final_Block
: Node_Id
;
5449 Final_Loop
: Node_Id
;
5450 Finalizer_Data
: Finalization_Exception_Data
;
5451 Finalizer_Decls
: List_Id
:= No_List
;
5452 Init_Loop
: Node_Id
;
5457 Exceptions_OK
: constant Boolean :=
5458 not Restriction_Active
(No_Exception_Propagation
);
5460 function Build_Counter_Assignment
return Node_Id
;
5461 -- Generate the following assignment:
5462 -- Counter := V'Length (1) *
5464 -- V'Length (N) - Counter;
5466 function Build_Finalization_Call
return Node_Id
;
5467 -- Generate a deep finalization call for an array element
5469 procedure Build_Indexes
;
5470 -- Generate the initialization and finalization indexes used in the
5473 function Build_Initialization_Call
return Node_Id
;
5474 -- Generate a deep initialization call for an array element
5476 ------------------------------
5477 -- Build_Counter_Assignment --
5478 ------------------------------
5480 function Build_Counter_Assignment
return Node_Id
is
5485 -- Start from the first dimension and generate:
5490 Make_Attribute_Reference
(Loc
,
5491 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5492 Attribute_Name
=> Name_Length
,
5493 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5495 -- Process the rest of the dimensions, generate:
5496 -- Expr * V'Length (N)
5499 while Dim
<= Num_Dims
loop
5501 Make_Op_Multiply
(Loc
,
5504 Make_Attribute_Reference
(Loc
,
5505 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5506 Attribute_Name
=> Name_Length
,
5507 Expressions
=> New_List
(
5508 Make_Integer_Literal
(Loc
, Dim
))));
5514 -- Counter := Expr - Counter;
5517 Make_Assignment_Statement
(Loc
,
5518 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5520 Make_Op_Subtract
(Loc
,
5522 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5523 end Build_Counter_Assignment
;
5525 -----------------------------
5526 -- Build_Finalization_Call --
5527 -----------------------------
5529 function Build_Finalization_Call
return Node_Id
is
5530 Comp_Ref
: constant Node_Id
:=
5531 Make_Indexed_Component
(Loc
,
5532 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5533 Expressions
=> New_References_To
(Final_List
, Loc
));
5536 Set_Etype
(Comp_Ref
, Comp_Typ
);
5539 -- [Deep_]Finalize (V);
5541 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5542 end Build_Finalization_Call
;
5548 procedure Build_Indexes
is
5550 -- Generate the following identifiers:
5551 -- Jnn - for initialization
5552 -- Fnn - for finalization
5554 for Dim
in 1 .. Num_Dims
loop
5555 Append_To
(Index_List
,
5556 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5558 Append_To
(Final_List
,
5559 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5563 -------------------------------
5564 -- Build_Initialization_Call --
5565 -------------------------------
5567 function Build_Initialization_Call
return Node_Id
is
5568 Comp_Ref
: constant Node_Id
:=
5569 Make_Indexed_Component
(Loc
,
5570 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5571 Expressions
=> New_References_To
(Index_List
, Loc
));
5574 Set_Etype
(Comp_Ref
, Comp_Typ
);
5577 -- [Deep_]Initialize (V (J1, ..., JN));
5579 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5580 end Build_Initialization_Call
;
5582 -- Start of processing for Build_Initialize_Statements
5585 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5586 Finalizer_Decls
:= New_List
;
5589 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5591 -- Generate the block which houses the finalization call, the index
5592 -- guard and the handler which triggers Program_Error later on.
5594 -- if Counter > 0 then
5595 -- Counter := Counter - 1;
5597 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5599 -- begin -- Exceptions allowed
5600 -- [Deep_]Finalize (V (F1, ..., FN));
5603 -- if not Raised then
5605 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5610 if Exceptions_OK
then
5612 Make_Block_Statement
(Loc
,
5613 Handled_Statement_Sequence
=>
5614 Make_Handled_Sequence_Of_Statements
(Loc
,
5615 Statements
=> New_List
(Build_Finalization_Call
),
5616 Exception_Handlers
=> New_List
(
5617 Build_Exception_Handler
(Finalizer_Data
))));
5619 Fin_Stmt
:= Build_Finalization_Call
;
5622 -- This is the core of the loop, the dimension iterators are added
5623 -- one by one in reverse.
5626 Make_If_Statement
(Loc
,
5629 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5630 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5632 Then_Statements
=> New_List
(
5633 Make_Assignment_Statement
(Loc
,
5634 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5636 Make_Op_Subtract
(Loc
,
5637 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5638 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5640 Else_Statements
=> New_List
(Fin_Stmt
));
5642 -- Generate all finalization loops starting from the innermost
5645 -- for Fnn in reverse V'Range (Dim) loop
5649 F
:= Last
(Final_List
);
5651 while Present
(F
) and then Dim
> 0 loop
5657 Make_Loop_Statement
(Loc
,
5659 Make_Iteration_Scheme
(Loc
,
5660 Loop_Parameter_Specification
=>
5661 Make_Loop_Parameter_Specification
(Loc
,
5662 Defining_Identifier
=> Loop_Id
,
5663 Discrete_Subtype_Definition
=>
5664 Make_Attribute_Reference
(Loc
,
5665 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5666 Attribute_Name
=> Name_Range
,
5667 Expressions
=> New_List
(
5668 Make_Integer_Literal
(Loc
, Dim
))),
5670 Reverse_Present
=> True)),
5672 Statements
=> New_List
(Final_Loop
),
5673 End_Label
=> Empty
);
5678 -- Generate the block which contains the finalization loops, the
5679 -- declarations of the abort flag, the exception occurrence, the
5680 -- raised flag and the conditional raise.
5683 -- Abort : constant Boolean := Triggered_By_Abort;
5685 -- Abort : constant Boolean := False; -- no abort
5687 -- E : Exception_Occurrence;
5688 -- Raised : Boolean := False;
5694 -- V'Length (N) - Counter;
5698 -- if Raised and then not Abort then -- Exception handlers OK
5699 -- Raise_From_Controlled_Operation (E);
5702 -- raise; -- Exception handlers OK
5705 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5707 if Exceptions_OK
then
5709 Build_Raise_Statement
(Finalizer_Data
));
5710 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5714 Make_Block_Statement
(Loc
,
5717 Handled_Statement_Sequence
=>
5718 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5720 -- Generate the block which contains the initialization call and
5721 -- the partial finalization code.
5724 -- [Deep_]Initialize (V (J1, ..., JN));
5726 -- Counter := Counter + 1;
5730 -- <finalization code>
5734 Make_Block_Statement
(Loc
,
5735 Handled_Statement_Sequence
=>
5736 Make_Handled_Sequence_Of_Statements
(Loc
,
5737 Statements
=> New_List
(Build_Initialization_Call
),
5738 Exception_Handlers
=> New_List
(
5739 Make_Exception_Handler
(Loc
,
5740 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5741 Statements
=> New_List
(Final_Block
)))));
5743 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5744 Make_Assignment_Statement
(Loc
,
5745 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5748 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5749 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5751 -- Generate all initialization loops starting from the innermost
5754 -- for Jnn in V'Range (Dim) loop
5758 J
:= Last
(Index_List
);
5760 while Present
(J
) and then Dim
> 0 loop
5766 Make_Loop_Statement
(Loc
,
5768 Make_Iteration_Scheme
(Loc
,
5769 Loop_Parameter_Specification
=>
5770 Make_Loop_Parameter_Specification
(Loc
,
5771 Defining_Identifier
=> Loop_Id
,
5772 Discrete_Subtype_Definition
=>
5773 Make_Attribute_Reference
(Loc
,
5774 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5775 Attribute_Name
=> Name_Range
,
5776 Expressions
=> New_List
(
5777 Make_Integer_Literal
(Loc
, Dim
))))),
5779 Statements
=> New_List
(Init_Loop
),
5780 End_Label
=> Empty
);
5785 -- Generate the block which contains the counter variable and the
5786 -- initialization loops.
5789 -- Counter : Integer := 0;
5796 Make_Block_Statement
(Loc
,
5797 Declarations
=> New_List
(
5798 Make_Object_Declaration
(Loc
,
5799 Defining_Identifier
=> Counter_Id
,
5800 Object_Definition
=>
5801 New_Occurrence_Of
(Standard_Integer
, Loc
),
5802 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5804 Handled_Statement_Sequence
=>
5805 Make_Handled_Sequence_Of_Statements
(Loc
,
5806 Statements
=> New_List
(Init_Loop
))));
5807 end Build_Initialize_Statements
;
5809 -----------------------
5810 -- New_References_To --
5811 -----------------------
5813 function New_References_To
5815 Loc
: Source_Ptr
) return List_Id
5817 Refs
: constant List_Id
:= New_List
;
5822 while Present
(Id
) loop
5823 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
5828 end New_References_To
;
5830 -- Start of processing for Make_Deep_Array_Body
5834 when Address_Case
=>
5835 return Make_Finalize_Address_Stmts
(Typ
);
5839 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5841 when Initialize_Case
=>
5842 return Build_Initialize_Statements
(Typ
);
5844 end Make_Deep_Array_Body
;
5846 --------------------
5847 -- Make_Deep_Proc --
5848 --------------------
5850 function Make_Deep_Proc
5851 (Prim
: Final_Primitives
;
5853 Stmts
: List_Id
) return Entity_Id
5855 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5857 Proc_Id
: Entity_Id
;
5860 -- Create the object formal, generate:
5861 -- V : System.Address
5863 if Prim
= Address_Case
then
5864 Formals
:= New_List
(
5865 Make_Parameter_Specification
(Loc
,
5866 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5868 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5875 Formals
:= New_List
(
5876 Make_Parameter_Specification
(Loc
,
5877 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5879 Out_Present
=> True,
5880 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
5882 -- F : Boolean := True
5884 if Prim
= Adjust_Case
5885 or else Prim
= Finalize_Case
5888 Make_Parameter_Specification
(Loc
,
5889 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5891 New_Occurrence_Of
(Standard_Boolean
, Loc
),
5893 New_Occurrence_Of
(Standard_True
, Loc
)));
5898 Make_Defining_Identifier
(Loc
,
5899 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5902 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5905 -- exception -- Finalize and Adjust cases only
5906 -- raise Program_Error;
5907 -- end Deep_Initialize / Adjust / Finalize;
5911 -- procedure Finalize_Address (V : System.Address) is
5914 -- end Finalize_Address;
5917 Make_Subprogram_Body
(Loc
,
5919 Make_Procedure_Specification
(Loc
,
5920 Defining_Unit_Name
=> Proc_Id
,
5921 Parameter_Specifications
=> Formals
),
5923 Declarations
=> Empty_List
,
5925 Handled_Statement_Sequence
=>
5926 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5931 ---------------------------
5932 -- Make_Deep_Record_Body --
5933 ---------------------------
5935 function Make_Deep_Record_Body
5936 (Prim
: Final_Primitives
;
5938 Is_Local
: Boolean := False) return List_Id
5940 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5941 -- Build the statements necessary to adjust a record type. The type may
5942 -- have discriminants and contain variant parts. Generate:
5946 -- [Deep_]Adjust (V.Comp_1);
5948 -- when Id : others =>
5949 -- if not Raised then
5951 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5956 -- [Deep_]Adjust (V.Comp_N);
5958 -- when Id : others =>
5959 -- if not Raised then
5961 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5966 -- Deep_Adjust (V._parent, False); -- If applicable
5968 -- when Id : others =>
5969 -- if not Raised then
5971 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5977 -- Adjust (V); -- If applicable
5980 -- if not Raised then
5982 -- Save_Occurence (E, Get_Current_Excep.all.all);
5987 -- if Raised and then not Abort then
5988 -- Raise_From_Controlled_Operation (E);
5992 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5993 -- Build the statements necessary to finalize a record type. The type
5994 -- may have discriminants and contain variant parts. Generate:
5997 -- Abort : constant Boolean := Triggered_By_Abort;
5999 -- Abort : constant Boolean := False; -- no abort
6000 -- E : Exception_Occurence;
6001 -- Raised : Boolean := False;
6006 -- Finalize (V); -- If applicable
6009 -- if not Raised then
6011 -- Save_Occurence (E, Get_Current_Excep.all.all);
6016 -- case Variant_1 is
6018 -- case State_Counter_N => -- If Is_Local is enabled
6028 -- <<LN>> -- If Is_Local is enabled
6030 -- [Deep_]Finalize (V.Comp_N);
6033 -- if not Raised then
6035 -- Save_Occurence (E, Get_Current_Excep.all.all);
6041 -- [Deep_]Finalize (V.Comp_1);
6044 -- if not Raised then
6046 -- Save_Occurence (E, Get_Current_Excep.all.all);
6052 -- case State_Counter_1 => -- If Is_Local is enabled
6058 -- Deep_Finalize (V._parent, False); -- If applicable
6060 -- when Id : others =>
6061 -- if not Raised then
6063 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6067 -- if Raised and then not Abort then
6068 -- Raise_From_Controlled_Operation (E);
6072 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6073 -- Given a derived tagged type Typ, traverse all components, find field
6074 -- _parent and return its type.
6076 procedure Preprocess_Components
6078 Num_Comps
: out Int
;
6079 Has_POC
: out Boolean);
6080 -- Examine all components in component list Comps, count all controlled
6081 -- components and determine whether at least one of them is per-object
6082 -- constrained. Component _parent is always skipped.
6084 -----------------------------
6085 -- Build_Adjust_Statements --
6086 -----------------------------
6088 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6089 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6090 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6091 Bod_Stmts
: List_Id
;
6092 Finalizer_Data
: Finalization_Exception_Data
;
6093 Finalizer_Decls
: List_Id
:= No_List
;
6097 Exceptions_OK
: constant Boolean :=
6098 not Restriction_Active
(No_Exception_Propagation
);
6100 function Process_Component_List_For_Adjust
6101 (Comps
: Node_Id
) return List_Id
;
6102 -- Build all necessary adjust statements for a single component list
6104 ---------------------------------------
6105 -- Process_Component_List_For_Adjust --
6106 ---------------------------------------
6108 function Process_Component_List_For_Adjust
6109 (Comps
: Node_Id
) return List_Id
6111 Stmts
: constant List_Id
:= New_List
;
6113 Decl_Id
: Entity_Id
;
6114 Decl_Typ
: Entity_Id
;
6118 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6119 -- Process the declaration of a single controlled component
6121 ----------------------------------
6122 -- Process_Component_For_Adjust --
6123 ----------------------------------
6125 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6126 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6127 Typ
: constant Entity_Id
:= Etype
(Id
);
6132 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6134 -- begin -- Exception handlers allowed
6135 -- [Deep_]Adjust (V.Id);
6138 -- if not Raised then
6140 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6147 Make_Selected_Component
(Loc
,
6148 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6149 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6152 if Exceptions_OK
then
6154 Make_Block_Statement
(Loc
,
6155 Handled_Statement_Sequence
=>
6156 Make_Handled_Sequence_Of_Statements
(Loc
,
6157 Statements
=> New_List
(Adj_Stmt
),
6158 Exception_Handlers
=> New_List
(
6159 Build_Exception_Handler
(Finalizer_Data
))));
6162 Append_To
(Stmts
, Adj_Stmt
);
6163 end Process_Component_For_Adjust
;
6165 -- Start of processing for Process_Component_List_For_Adjust
6168 -- Perform an initial check, determine the number of controlled
6169 -- components in the current list and whether at least one of them
6170 -- is per-object constrained.
6172 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6174 -- The processing in this routine is done in the following order:
6175 -- 1) Regular components
6176 -- 2) Per-object constrained components
6179 if Num_Comps
> 0 then
6181 -- Process all regular components in order of declarations
6183 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6184 while Present
(Decl
) loop
6185 Decl_Id
:= Defining_Identifier
(Decl
);
6186 Decl_Typ
:= Etype
(Decl_Id
);
6188 -- Skip _parent as well as per-object constrained components
6190 if Chars
(Decl_Id
) /= Name_uParent
6191 and then Needs_Finalization
(Decl_Typ
)
6193 if Has_Access_Constraint
(Decl_Id
)
6194 and then No
(Expression
(Decl
))
6198 Process_Component_For_Adjust
(Decl
);
6202 Next_Non_Pragma
(Decl
);
6205 -- Process all per-object constrained components in order of
6209 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6210 while Present
(Decl
) loop
6211 Decl_Id
:= Defining_Identifier
(Decl
);
6212 Decl_Typ
:= Etype
(Decl_Id
);
6216 if Chars
(Decl_Id
) /= Name_uParent
6217 and then Needs_Finalization
(Decl_Typ
)
6218 and then Has_Access_Constraint
(Decl_Id
)
6219 and then No
(Expression
(Decl
))
6221 Process_Component_For_Adjust
(Decl
);
6224 Next_Non_Pragma
(Decl
);
6229 -- Process all variants, if any
6232 if Present
(Variant_Part
(Comps
)) then
6234 Var_Alts
: constant List_Id
:= New_List
;
6238 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6239 while Present
(Var
) loop
6242 -- when <discrete choices> =>
6243 -- <adjust statements>
6245 Append_To
(Var_Alts
,
6246 Make_Case_Statement_Alternative
(Loc
,
6248 New_Copy_List
(Discrete_Choices
(Var
)),
6250 Process_Component_List_For_Adjust
(
6251 Component_List
(Var
))));
6253 Next_Non_Pragma
(Var
);
6257 -- case V.<discriminant> is
6258 -- when <discrete choices 1> =>
6259 -- <adjust statements 1>
6261 -- when <discrete choices N> =>
6262 -- <adjust statements N>
6266 Make_Case_Statement
(Loc
,
6268 Make_Selected_Component
(Loc
,
6269 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6271 Make_Identifier
(Loc
,
6272 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6273 Alternatives
=> Var_Alts
);
6277 -- Add the variant case statement to the list of statements
6279 if Present
(Var_Case
) then
6280 Append_To
(Stmts
, Var_Case
);
6283 -- If the component list did not have any controlled components
6284 -- nor variants, return null.
6286 if Is_Empty_List
(Stmts
) then
6287 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6291 end Process_Component_List_For_Adjust
;
6293 -- Start of processing for Build_Adjust_Statements
6296 Finalizer_Decls
:= New_List
;
6297 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6299 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6300 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6305 -- Create an adjust sequence for all record components
6307 if Present
(Component_List
(Rec_Def
)) then
6309 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6312 -- A derived record type must adjust all inherited components. This
6313 -- action poses the following problem:
6315 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6320 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6322 -- Deep_Adjust (Obj._parent);
6327 -- Adjusting the derived type will invoke Adjust of the parent and
6328 -- then that of the derived type. This is undesirable because both
6329 -- routines may modify shared components. Only the Adjust of the
6330 -- derived type should be invoked.
6332 -- To prevent this double adjustment of shared components,
6333 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6335 -- procedure Deep_Adjust
6336 -- (Obj : in out Some_Type;
6337 -- Flag : Boolean := True)
6345 -- When Deep_Adjust is invokes for field _parent, a value of False is
6346 -- provided for the flag:
6348 -- Deep_Adjust (Obj._parent, False);
6350 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6352 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6357 if Needs_Finalization
(Par_Typ
) then
6361 Make_Selected_Component
(Loc
,
6362 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6364 Make_Identifier
(Loc
, Name_uParent
)),
6369 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6371 -- begin -- Exceptions OK
6372 -- Deep_Adjust (V._parent, False);
6374 -- when Id : others =>
6375 -- if not Raised then
6377 -- Save_Occurrence (E,
6378 -- Get_Current_Excep.all.all);
6382 if Present
(Call
) then
6385 if Exceptions_OK
then
6387 Make_Block_Statement
(Loc
,
6388 Handled_Statement_Sequence
=>
6389 Make_Handled_Sequence_Of_Statements
(Loc
,
6390 Statements
=> New_List
(Adj_Stmt
),
6391 Exception_Handlers
=> New_List
(
6392 Build_Exception_Handler
(Finalizer_Data
))));
6395 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6401 -- Adjust the object. This action must be performed last after all
6402 -- components have been adjusted.
6404 if Is_Controlled
(Typ
) then
6410 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6414 -- Adjust (V); -- No_Exception_Propagation
6416 -- begin -- Exception handlers allowed
6420 -- if not Raised then
6422 -- Save_Occurrence (E,
6423 -- Get_Current_Excep.all.all);
6428 if Present
(Proc
) then
6430 Make_Procedure_Call_Statement
(Loc
,
6431 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6432 Parameter_Associations
=> New_List
(
6433 Make_Identifier
(Loc
, Name_V
)));
6435 if Exceptions_OK
then
6437 Make_Block_Statement
(Loc
,
6438 Handled_Statement_Sequence
=>
6439 Make_Handled_Sequence_Of_Statements
(Loc
,
6440 Statements
=> New_List
(Adj_Stmt
),
6441 Exception_Handlers
=> New_List
(
6442 Build_Exception_Handler
6443 (Finalizer_Data
))));
6446 Append_To
(Bod_Stmts
,
6447 Make_If_Statement
(Loc
,
6448 Condition
=> Make_Identifier
(Loc
, Name_F
),
6449 Then_Statements
=> New_List
(Adj_Stmt
)));
6454 -- At this point either all adjustment statements have been generated
6455 -- or the type is not controlled.
6457 if Is_Empty_List
(Bod_Stmts
) then
6458 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6464 -- Abort : constant Boolean := Triggered_By_Abort;
6466 -- Abort : constant Boolean := False; -- no abort
6468 -- E : Exception_Occurence;
6469 -- Raised : Boolean := False;
6472 -- <adjust statements>
6474 -- if Raised and then not Abort then
6475 -- Raise_From_Controlled_Operation (E);
6480 if Exceptions_OK
then
6481 Append_To
(Bod_Stmts
,
6482 Build_Raise_Statement
(Finalizer_Data
));
6487 Make_Block_Statement
(Loc
,
6490 Handled_Statement_Sequence
=>
6491 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6493 end Build_Adjust_Statements
;
6495 -------------------------------
6496 -- Build_Finalize_Statements --
6497 -------------------------------
6499 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6500 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6501 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6502 Bod_Stmts
: List_Id
;
6504 Finalizer_Data
: Finalization_Exception_Data
;
6505 Finalizer_Decls
: List_Id
:= No_List
;
6509 Exceptions_OK
: constant Boolean :=
6510 not Restriction_Active
(No_Exception_Propagation
);
6512 function Process_Component_List_For_Finalize
6513 (Comps
: Node_Id
) return List_Id
;
6514 -- Build all necessary finalization statements for a single component
6515 -- list. The statements may include a jump circuitry if flag Is_Local
6518 -----------------------------------------
6519 -- Process_Component_List_For_Finalize --
6520 -----------------------------------------
6522 function Process_Component_List_For_Finalize
6523 (Comps
: Node_Id
) return List_Id
6526 Counter_Id
: Entity_Id
;
6528 Decl_Id
: Entity_Id
;
6529 Decl_Typ
: Entity_Id
;
6532 Jump_Block
: Node_Id
;
6534 Label_Id
: Entity_Id
;
6538 procedure Process_Component_For_Finalize
6543 -- Process the declaration of a single controlled component. If
6544 -- flag Is_Local is enabled, create the corresponding label and
6545 -- jump circuitry. Alts is the list of case alternatives, Decls
6546 -- is the top level declaration list where labels are declared
6547 -- and Stmts is the list of finalization actions.
6549 ------------------------------------
6550 -- Process_Component_For_Finalize --
6551 ------------------------------------
6553 procedure Process_Component_For_Finalize
6559 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6560 Typ
: constant Entity_Id
:= Etype
(Id
);
6567 Label_Id
: Entity_Id
;
6574 Make_Identifier
(Loc
,
6575 Chars
=> New_External_Name
('L', Num_Comps
));
6576 Set_Entity
(Label_Id
,
6577 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6578 Label
:= Make_Label
(Loc
, Label_Id
);
6581 Make_Implicit_Label_Declaration
(Loc
,
6582 Defining_Identifier
=> Entity
(Label_Id
),
6583 Label_Construct
=> Label
));
6590 Make_Case_Statement_Alternative
(Loc
,
6591 Discrete_Choices
=> New_List
(
6592 Make_Integer_Literal
(Loc
, Num_Comps
)),
6594 Statements
=> New_List
(
6595 Make_Goto_Statement
(Loc
,
6597 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6602 Append_To
(Stmts
, Label
);
6604 -- Decrease the number of components to be processed.
6605 -- This action yields a new Label_Id in future calls.
6607 Num_Comps
:= Num_Comps
- 1;
6612 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6614 -- begin -- Exception handlers allowed
6615 -- [Deep_]Finalize (V.Id);
6618 -- if not Raised then
6620 -- Save_Occurrence (E,
6621 -- Get_Current_Excep.all.all);
6628 Make_Selected_Component
(Loc
,
6629 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6630 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6633 if not Restriction_Active
(No_Exception_Propagation
) then
6635 Make_Block_Statement
(Loc
,
6636 Handled_Statement_Sequence
=>
6637 Make_Handled_Sequence_Of_Statements
(Loc
,
6638 Statements
=> New_List
(Fin_Stmt
),
6639 Exception_Handlers
=> New_List
(
6640 Build_Exception_Handler
(Finalizer_Data
))));
6643 Append_To
(Stmts
, Fin_Stmt
);
6644 end Process_Component_For_Finalize
;
6646 -- Start of processing for Process_Component_List_For_Finalize
6649 -- Perform an initial check, look for controlled and per-object
6650 -- constrained components.
6652 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6654 -- Create a state counter to service the current component list.
6655 -- This step is performed before the variants are inspected in
6656 -- order to generate the same state counter names as those from
6657 -- Build_Initialize_Statements.
6659 if Num_Comps
> 0 and then Is_Local
then
6660 Counter
:= Counter
+ 1;
6663 Make_Defining_Identifier
(Loc
,
6664 Chars
=> New_External_Name
('C', Counter
));
6667 -- Process the component in the following order:
6669 -- 2) Per-object constrained components
6670 -- 3) Regular components
6672 -- Start with the variant parts
6675 if Present
(Variant_Part
(Comps
)) then
6677 Var_Alts
: constant List_Id
:= New_List
;
6681 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6682 while Present
(Var
) loop
6685 -- when <discrete choices> =>
6686 -- <finalize statements>
6688 Append_To
(Var_Alts
,
6689 Make_Case_Statement_Alternative
(Loc
,
6691 New_Copy_List
(Discrete_Choices
(Var
)),
6693 Process_Component_List_For_Finalize
(
6694 Component_List
(Var
))));
6696 Next_Non_Pragma
(Var
);
6700 -- case V.<discriminant> is
6701 -- when <discrete choices 1> =>
6702 -- <finalize statements 1>
6704 -- when <discrete choices N> =>
6705 -- <finalize statements N>
6709 Make_Case_Statement
(Loc
,
6711 Make_Selected_Component
(Loc
,
6712 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6714 Make_Identifier
(Loc
,
6715 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6716 Alternatives
=> Var_Alts
);
6720 -- The current component list does not have a single controlled
6721 -- component, however it may contain variants. Return the case
6722 -- statement for the variants or nothing.
6724 if Num_Comps
= 0 then
6725 if Present
(Var_Case
) then
6726 return New_List
(Var_Case
);
6728 return New_List
(Make_Null_Statement
(Loc
));
6732 -- Prepare all lists
6738 -- Process all per-object constrained components in reverse order
6741 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6742 while Present
(Decl
) loop
6743 Decl_Id
:= Defining_Identifier
(Decl
);
6744 Decl_Typ
:= Etype
(Decl_Id
);
6748 if Chars
(Decl_Id
) /= Name_uParent
6749 and then Needs_Finalization
(Decl_Typ
)
6750 and then Has_Access_Constraint
(Decl_Id
)
6751 and then No
(Expression
(Decl
))
6753 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6756 Prev_Non_Pragma
(Decl
);
6760 -- Process the rest of the components in reverse order
6762 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6763 while Present
(Decl
) loop
6764 Decl_Id
:= Defining_Identifier
(Decl
);
6765 Decl_Typ
:= Etype
(Decl_Id
);
6769 if Chars
(Decl_Id
) /= Name_uParent
6770 and then Needs_Finalization
(Decl_Typ
)
6772 -- Skip per-object constrained components since they were
6773 -- handled in the above step.
6775 if Has_Access_Constraint
(Decl_Id
)
6776 and then No
(Expression
(Decl
))
6780 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6784 Prev_Non_Pragma
(Decl
);
6789 -- LN : label; -- If Is_Local is enabled
6794 -- case CounterX is .
6804 -- <<LN>> -- If Is_Local is enabled
6806 -- [Deep_]Finalize (V.CompY);
6808 -- when Id : others =>
6809 -- if not Raised then
6811 -- Save_Occurrence (E,
6812 -- Get_Current_Excep.all.all);
6816 -- <<L0>> -- If Is_Local is enabled
6821 -- Add the declaration of default jump location L0, its
6822 -- corresponding alternative and its place in the statements.
6824 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6825 Set_Entity
(Label_Id
,
6826 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6827 Label
:= Make_Label
(Loc
, Label_Id
);
6829 Append_To
(Decls
, -- declaration
6830 Make_Implicit_Label_Declaration
(Loc
,
6831 Defining_Identifier
=> Entity
(Label_Id
),
6832 Label_Construct
=> Label
));
6834 Append_To
(Alts
, -- alternative
6835 Make_Case_Statement_Alternative
(Loc
,
6836 Discrete_Choices
=> New_List
(
6837 Make_Others_Choice
(Loc
)),
6839 Statements
=> New_List
(
6840 Make_Goto_Statement
(Loc
,
6841 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6843 Append_To
(Stmts
, Label
); -- statement
6845 -- Create the jump block
6848 Make_Case_Statement
(Loc
,
6849 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6850 Alternatives
=> Alts
));
6854 Make_Block_Statement
(Loc
,
6855 Declarations
=> Decls
,
6856 Handled_Statement_Sequence
=>
6857 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6859 if Present
(Var_Case
) then
6860 return New_List
(Var_Case
, Jump_Block
);
6862 return New_List
(Jump_Block
);
6864 end Process_Component_List_For_Finalize
;
6866 -- Start of processing for Build_Finalize_Statements
6869 Finalizer_Decls
:= New_List
;
6870 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6872 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6873 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6878 -- Create a finalization sequence for all record components
6880 if Present
(Component_List
(Rec_Def
)) then
6882 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6885 -- A derived record type must finalize all inherited components. This
6886 -- action poses the following problem:
6888 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6893 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6895 -- Deep_Finalize (Obj._parent);
6900 -- Finalizing the derived type will invoke Finalize of the parent and
6901 -- then that of the derived type. This is undesirable because both
6902 -- routines may modify shared components. Only the Finalize of the
6903 -- derived type should be invoked.
6905 -- To prevent this double adjustment of shared components,
6906 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6908 -- procedure Deep_Finalize
6909 -- (Obj : in out Some_Type;
6910 -- Flag : Boolean := True)
6918 -- When Deep_Finalize is invokes for field _parent, a value of False
6919 -- is provided for the flag:
6921 -- Deep_Finalize (Obj._parent, False);
6923 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6925 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6930 if Needs_Finalization
(Par_Typ
) then
6934 Make_Selected_Component
(Loc
,
6935 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6937 Make_Identifier
(Loc
, Name_uParent
)),
6942 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6944 -- begin -- Exceptions OK
6945 -- Deep_Finalize (V._parent, False);
6947 -- when Id : others =>
6948 -- if not Raised then
6950 -- Save_Occurrence (E,
6951 -- Get_Current_Excep.all.all);
6955 if Present
(Call
) then
6958 if Exceptions_OK
then
6960 Make_Block_Statement
(Loc
,
6961 Handled_Statement_Sequence
=>
6962 Make_Handled_Sequence_Of_Statements
(Loc
,
6963 Statements
=> New_List
(Fin_Stmt
),
6964 Exception_Handlers
=> New_List
(
6965 Build_Exception_Handler
6966 (Finalizer_Data
))));
6969 Append_To
(Bod_Stmts
, Fin_Stmt
);
6975 -- Finalize the object. This action must be performed first before
6976 -- all components have been finalized.
6978 if Is_Controlled
(Typ
) and then not Is_Local
then
6984 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6988 -- Finalize (V); -- No_Exception_Propagation
6994 -- if not Raised then
6996 -- Save_Occurrence (E,
6997 -- Get_Current_Excep.all.all);
7002 if Present
(Proc
) then
7004 Make_Procedure_Call_Statement
(Loc
,
7005 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7006 Parameter_Associations
=> New_List
(
7007 Make_Identifier
(Loc
, Name_V
)));
7009 if Exceptions_OK
then
7011 Make_Block_Statement
(Loc
,
7012 Handled_Statement_Sequence
=>
7013 Make_Handled_Sequence_Of_Statements
(Loc
,
7014 Statements
=> New_List
(Fin_Stmt
),
7015 Exception_Handlers
=> New_List
(
7016 Build_Exception_Handler
7017 (Finalizer_Data
))));
7020 Prepend_To
(Bod_Stmts
,
7021 Make_If_Statement
(Loc
,
7022 Condition
=> Make_Identifier
(Loc
, Name_F
),
7023 Then_Statements
=> New_List
(Fin_Stmt
)));
7028 -- At this point either all finalization statements have been
7029 -- generated or the type is not controlled.
7031 if No
(Bod_Stmts
) then
7032 return New_List
(Make_Null_Statement
(Loc
));
7036 -- Abort : constant Boolean := Triggered_By_Abort;
7038 -- Abort : constant Boolean := False; -- no abort
7040 -- E : Exception_Occurence;
7041 -- Raised : Boolean := False;
7044 -- <finalize statements>
7046 -- if Raised and then not Abort then
7047 -- Raise_From_Controlled_Operation (E);
7052 if Exceptions_OK
then
7053 Append_To
(Bod_Stmts
,
7054 Build_Raise_Statement
(Finalizer_Data
));
7059 Make_Block_Statement
(Loc
,
7062 Handled_Statement_Sequence
=>
7063 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7065 end Build_Finalize_Statements
;
7067 -----------------------
7068 -- Parent_Field_Type --
7069 -----------------------
7071 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7075 Field
:= First_Entity
(Typ
);
7076 while Present
(Field
) loop
7077 if Chars
(Field
) = Name_uParent
then
7078 return Etype
(Field
);
7081 Next_Entity
(Field
);
7084 -- A derived tagged type should always have a parent field
7086 raise Program_Error
;
7087 end Parent_Field_Type
;
7089 ---------------------------
7090 -- Preprocess_Components --
7091 ---------------------------
7093 procedure Preprocess_Components
7095 Num_Comps
: out Int
;
7096 Has_POC
: out Boolean)
7106 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7107 while Present
(Decl
) loop
7108 Id
:= Defining_Identifier
(Decl
);
7111 -- Skip field _parent
7113 if Chars
(Id
) /= Name_uParent
7114 and then Needs_Finalization
(Typ
)
7116 Num_Comps
:= Num_Comps
+ 1;
7118 if Has_Access_Constraint
(Id
)
7119 and then No
(Expression
(Decl
))
7125 Next_Non_Pragma
(Decl
);
7127 end Preprocess_Components
;
7129 -- Start of processing for Make_Deep_Record_Body
7133 when Address_Case
=>
7134 return Make_Finalize_Address_Stmts
(Typ
);
7137 return Build_Adjust_Statements
(Typ
);
7139 when Finalize_Case
=>
7140 return Build_Finalize_Statements
(Typ
);
7142 when Initialize_Case
=>
7144 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7147 if Is_Controlled
(Typ
) then
7149 Make_Procedure_Call_Statement
(Loc
,
7152 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7153 Parameter_Associations
=> New_List
(
7154 Make_Identifier
(Loc
, Name_V
))));
7160 end Make_Deep_Record_Body
;
7162 ----------------------
7163 -- Make_Final_Call --
7164 ----------------------
7166 function Make_Final_Call
7169 Skip_Self
: Boolean := False) return Node_Id
7171 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7173 Fin_Id
: Entity_Id
:= Empty
;
7178 -- Recover the proper type which contains [Deep_]Finalize
7180 if Is_Class_Wide_Type
(Typ
) then
7181 Utyp
:= Root_Type
(Typ
);
7185 elsif Is_Concurrent_Type
(Typ
) then
7186 Utyp
:= Corresponding_Record_Type
(Typ
);
7188 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7190 elsif Is_Private_Type
(Typ
)
7191 and then Present
(Full_View
(Typ
))
7192 and then Is_Concurrent_Type
(Full_View
(Typ
))
7194 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7196 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7204 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7205 Set_Assignment_OK
(Ref
);
7207 -- Deal with untagged derivation of private views. If the parent type
7208 -- is a protected type, Deep_Finalize is found on the corresponding
7209 -- record of the ancestor.
7211 if Is_Untagged_Derivation
(Typ
) then
7212 if Is_Protected_Type
(Typ
) then
7213 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7215 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7217 if Is_Protected_Type
(Utyp
) then
7218 Utyp
:= Corresponding_Record_Type
(Utyp
);
7222 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7223 Set_Assignment_OK
(Ref
);
7226 -- Deal with derived private types which do not inherit primitives from
7227 -- their parents. In this case, [Deep_]Finalize can be found in the full
7228 -- view of the parent type.
7230 if Is_Tagged_Type
(Utyp
)
7231 and then Is_Derived_Type
(Utyp
)
7232 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7233 and then Is_Private_Type
(Etype
(Utyp
))
7234 and then Present
(Full_View
(Etype
(Utyp
)))
7236 Utyp
:= Full_View
(Etype
(Utyp
));
7237 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7238 Set_Assignment_OK
(Ref
);
7241 -- When dealing with the completion of a private type, use the base type
7244 if Utyp
/= Base_Type
(Utyp
) then
7245 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7247 Utyp
:= Base_Type
(Utyp
);
7248 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7249 Set_Assignment_OK
(Ref
);
7253 if Has_Controlled_Component
(Utyp
) then
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
);
7261 -- Class-wide types, interfaces and types with controlled components
7263 elsif Is_Class_Wide_Type
(Typ
)
7264 or else Is_Interface
(Typ
)
7265 or else Has_Controlled_Component
(Utyp
)
7267 if Is_Tagged_Type
(Utyp
) then
7268 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7270 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7273 -- Derivations from [Limited_]Controlled
7275 elsif Is_Controlled
(Utyp
) then
7276 if Has_Controlled_Component
(Utyp
) then
7277 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7279 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7284 elsif Is_Tagged_Type
(Utyp
) then
7285 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7288 raise Program_Error
;
7291 if Present
(Fin_Id
) then
7293 -- When finalizing a class-wide object, do not convert to the root
7294 -- type in order to produce a dispatching call.
7296 if Is_Class_Wide_Type
(Typ
) then
7299 -- Ensure that a finalization routine is at least decorated in order
7300 -- to inspect the object parameter.
7302 elsif Analyzed
(Fin_Id
)
7303 or else Ekind
(Fin_Id
) = E_Procedure
7305 -- In certain cases, such as the creation of Stream_Read, the
7306 -- visible entity of the type is its full view. Since Stream_Read
7307 -- will have to create an object of type Typ, the local object
7308 -- will be finalzed by the scope finalizer generated later on. The
7309 -- object parameter of Deep_Finalize will always use the private
7310 -- view of the type. To avoid such a clash between a private and a
7311 -- full view, perform an unchecked conversion of the object
7312 -- reference to the private view.
7315 Formal_Typ
: constant Entity_Id
:=
7316 Etype
(First_Formal
(Fin_Id
));
7318 if Is_Private_Type
(Formal_Typ
)
7319 and then Present
(Full_View
(Formal_Typ
))
7320 and then Full_View
(Formal_Typ
) = Utyp
7322 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7326 Ref
:= Convert_View
(Fin_Id
, Ref
);
7332 Param
=> New_Copy_Tree
(Ref
),
7333 Skip_Self
=> Skip_Self
);
7337 end Make_Final_Call
;
7339 --------------------------------
7340 -- Make_Finalize_Address_Body --
7341 --------------------------------
7343 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7344 Is_Task
: constant Boolean :=
7345 Ekind
(Typ
) = E_Record_Type
7346 and then Is_Concurrent_Record_Type
(Typ
)
7347 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7349 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7350 Proc_Id
: Entity_Id
;
7354 -- The corresponding records of task types are not controlled by design.
7355 -- For the sake of completeness, create an empty Finalize_Address to be
7356 -- used in task class-wide allocations.
7361 -- Nothing to do if the type is not controlled or it already has a
7362 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7363 -- come from source. These are usually generated for completeness and
7364 -- do not need the Finalize_Address primitive.
7366 elsif not Needs_Finalization
(Typ
)
7367 or else Is_Abstract_Type
(Typ
)
7368 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7370 (Is_Class_Wide_Type
(Typ
)
7371 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7372 and then not Comes_From_Source
(Root_Type
(Typ
)))
7378 Make_Defining_Identifier
(Loc
,
7379 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7383 -- procedure <Typ>FD (V : System.Address) is
7385 -- null; -- for tasks
7387 -- declare -- for all other types
7388 -- type Pnn is access all Typ;
7389 -- for Pnn'Storage_Size use 0;
7391 -- [Deep_]Finalize (Pnn (V).all);
7396 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7398 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7402 Make_Subprogram_Body
(Loc
,
7404 Make_Procedure_Specification
(Loc
,
7405 Defining_Unit_Name
=> Proc_Id
,
7407 Parameter_Specifications
=> New_List
(
7408 Make_Parameter_Specification
(Loc
,
7409 Defining_Identifier
=>
7410 Make_Defining_Identifier
(Loc
, Name_V
),
7412 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7414 Declarations
=> No_List
,
7416 Handled_Statement_Sequence
=>
7417 Make_Handled_Sequence_Of_Statements
(Loc
,
7418 Statements
=> Stmts
)));
7420 Set_TSS
(Typ
, Proc_Id
);
7421 end Make_Finalize_Address_Body
;
7423 ---------------------------------
7424 -- Make_Finalize_Address_Stmts --
7425 ---------------------------------
7427 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7428 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7429 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7431 Desg_Typ
: Entity_Id
;
7435 if Is_Array_Type
(Typ
) then
7436 if Is_Constrained
(First_Subtype
(Typ
)) then
7437 Desg_Typ
:= First_Subtype
(Typ
);
7439 Desg_Typ
:= Base_Type
(Typ
);
7442 -- Class-wide types of constrained root types
7444 elsif Is_Class_Wide_Type
(Typ
)
7445 and then Has_Discriminants
(Root_Type
(Typ
))
7447 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7450 Parent_Typ
: Entity_Id
;
7453 -- Climb the parent type chain looking for a non-constrained type
7455 Parent_Typ
:= Root_Type
(Typ
);
7456 while Parent_Typ
/= Etype
(Parent_Typ
)
7457 and then Has_Discriminants
(Parent_Typ
)
7459 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7461 Parent_Typ
:= Etype
(Parent_Typ
);
7464 -- Handle views created for tagged types with unknown
7467 if Is_Underlying_Record_View
(Parent_Typ
) then
7468 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7471 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7481 -- type Ptr_Typ is access all Typ;
7482 -- for Ptr_Typ'Storage_Size use 0;
7485 Make_Full_Type_Declaration
(Loc
,
7486 Defining_Identifier
=> Ptr_Typ
,
7488 Make_Access_To_Object_Definition
(Loc
,
7489 All_Present
=> True,
7490 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7492 Make_Attribute_Definition_Clause
(Loc
,
7493 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7494 Chars
=> Name_Storage_Size
,
7495 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7497 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7499 -- Unconstrained arrays require special processing in order to retrieve
7500 -- the elements. To achieve this, we have to skip the dope vector which
7501 -- lays in front of the elements and then use a thin pointer to perform
7502 -- the address-to-access conversion.
7504 if Is_Array_Type
(Typ
)
7505 and then not Is_Constrained
(First_Subtype
(Typ
))
7508 Dope_Id
: Entity_Id
;
7511 -- Ensure that Ptr_Typ a thin pointer, generate:
7512 -- for Ptr_Typ'Size use System.Address'Size;
7515 Make_Attribute_Definition_Clause
(Loc
,
7516 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7519 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7522 -- Dnn : constant Storage_Offset :=
7523 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7525 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7528 Make_Object_Declaration
(Loc
,
7529 Defining_Identifier
=> Dope_Id
,
7530 Constant_Present
=> True,
7531 Object_Definition
=>
7532 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7534 Make_Op_Divide
(Loc
,
7536 Make_Attribute_Reference
(Loc
,
7537 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7538 Attribute_Name
=> Name_Descriptor_Size
),
7540 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7542 -- Shift the address from the start of the dope vector to the
7543 -- start of the elements:
7547 -- Note that this is done through a wrapper routine since RTSfind
7548 -- cannot retrieve operations with string names of the form "+".
7551 Make_Function_Call
(Loc
,
7553 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7554 Parameter_Associations
=> New_List
(
7556 New_Occurrence_Of
(Dope_Id
, Loc
)));
7560 -- Create the block and the finalization call
7563 Make_Block_Statement
(Loc
,
7564 Declarations
=> Decls
,
7566 Handled_Statement_Sequence
=>
7567 Make_Handled_Sequence_Of_Statements
(Loc
,
7568 Statements
=> New_List
(
7571 Make_Explicit_Dereference
(Loc
,
7572 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7573 Typ
=> Desg_Typ
)))));
7574 end Make_Finalize_Address_Stmts
;
7576 -------------------------------------
7577 -- Make_Handler_For_Ctrl_Operation --
7578 -------------------------------------
7582 -- when E : others =>
7583 -- Raise_From_Controlled_Operation (E);
7588 -- raise Program_Error [finalize raised exception];
7590 -- depending on whether Raise_From_Controlled_Operation is available
7592 function Make_Handler_For_Ctrl_Operation
7593 (Loc
: Source_Ptr
) return Node_Id
7596 -- Choice parameter (for the first case above)
7598 Raise_Node
: Node_Id
;
7599 -- Procedure call or raise statement
7602 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7603 -- it to Raise_From_Controlled_Operation so that the original exception
7604 -- name and message can be recorded in the exception message for
7607 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7608 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7610 Make_Procedure_Call_Statement
(Loc
,
7613 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7614 Parameter_Associations
=> New_List
(
7615 New_Occurrence_Of
(E_Occ
, Loc
)));
7617 -- Restricted run-time: exception messages are not supported
7622 Make_Raise_Program_Error
(Loc
,
7623 Reason
=> PE_Finalize_Raised_Exception
);
7627 Make_Implicit_Exception_Handler
(Loc
,
7628 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7629 Choice_Parameter
=> E_Occ
,
7630 Statements
=> New_List
(Raise_Node
));
7631 end Make_Handler_For_Ctrl_Operation
;
7633 --------------------
7634 -- Make_Init_Call --
7635 --------------------
7637 function Make_Init_Call
7639 Typ
: Entity_Id
) return Node_Id
7641 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7648 -- Deal with the type and object reference. Depending on the context, an
7649 -- object reference may need several conversions.
7651 if Is_Concurrent_Type
(Typ
) then
7653 Utyp
:= Corresponding_Record_Type
(Typ
);
7654 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7656 elsif Is_Private_Type
(Typ
)
7657 and then Present
(Full_View
(Typ
))
7658 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7661 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7662 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7670 Set_Assignment_OK
(Ref
);
7672 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7674 -- Deal with untagged derivation of private views
7676 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
7677 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7678 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7680 -- The following is to prevent problems with UC see 1.156 RH ???
7682 Set_Assignment_OK
(Ref
);
7685 -- If the underlying_type is a subtype, then we are dealing with the
7686 -- completion of a private type. We need to access the base type and
7687 -- generate a conversion to it.
7689 if Utyp
/= Base_Type
(Utyp
) then
7690 pragma Assert
(Is_Private_Type
(Typ
));
7691 Utyp
:= Base_Type
(Utyp
);
7692 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7695 -- Select the appropriate version of initialize
7697 if Has_Controlled_Component
(Utyp
) then
7698 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7700 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7701 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7704 -- The object reference may need another conversion depending on the
7705 -- type of the formal and that of the actual.
7707 Ref
:= Convert_View
(Proc
, Ref
);
7710 -- [Deep_]Initialize (Ref);
7713 Make_Procedure_Call_Statement
(Loc
,
7715 New_Occurrence_Of
(Proc
, Loc
),
7716 Parameter_Associations
=> New_List
(Ref
));
7719 ------------------------------
7720 -- Make_Local_Deep_Finalize --
7721 ------------------------------
7723 function Make_Local_Deep_Finalize
7725 Nam
: Entity_Id
) return Node_Id
7727 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7731 Formals
:= New_List
(
7735 Make_Parameter_Specification
(Loc
,
7736 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7738 Out_Present
=> True,
7739 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
7741 -- F : Boolean := True
7743 Make_Parameter_Specification
(Loc
,
7744 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7745 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7746 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
7748 -- Add the necessary number of counters to represent the initialization
7749 -- state of an object.
7752 Make_Subprogram_Body
(Loc
,
7754 Make_Procedure_Specification
(Loc
,
7755 Defining_Unit_Name
=> Nam
,
7756 Parameter_Specifications
=> Formals
),
7758 Declarations
=> No_List
,
7760 Handled_Statement_Sequence
=>
7761 Make_Handled_Sequence_Of_Statements
(Loc
,
7762 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7763 end Make_Local_Deep_Finalize
;
7765 ------------------------------------
7766 -- Make_Set_Finalize_Address_Call --
7767 ------------------------------------
7769 function Make_Set_Finalize_Address_Call
7772 Ptr_Typ
: Entity_Id
) return Node_Id
7774 Desig_Typ
: constant Entity_Id
:=
7775 Available_View
(Designated_Type
(Ptr_Typ
));
7776 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7777 Fin_Mas_Ref
: Node_Id
;
7781 -- If the context is a class-wide allocator, we use the class-wide type
7782 -- to obtain the proper Finalize_Address routine.
7784 if Is_Class_Wide_Type
(Desig_Typ
) then
7790 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7791 Utyp
:= Full_View
(Utyp
);
7794 if Is_Concurrent_Type
(Utyp
) then
7795 Utyp
:= Corresponding_Record_Type
(Utyp
);
7799 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7801 -- Deal with untagged derivation of private views. If the parent is
7802 -- now known to be protected, the finalization routine is the one
7803 -- defined on the corresponding record of the ancestor (corresponding
7804 -- records do not automatically inherit operations, but maybe they
7807 if Is_Untagged_Derivation
(Typ
) then
7808 if Is_Protected_Type
(Typ
) then
7809 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7811 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7813 if Is_Protected_Type
(Utyp
) then
7814 Utyp
:= Corresponding_Record_Type
(Utyp
);
7819 -- If the underlying_type is a subtype, we are dealing with the
7820 -- completion of a private type. We need to access the base type and
7821 -- generate a conversion to it.
7823 if Utyp
/= Base_Type
(Utyp
) then
7824 pragma Assert
(Is_Private_Type
(Typ
));
7826 Utyp
:= Base_Type
(Utyp
);
7829 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7831 -- If the call is from a build-in-place function, the Master parameter
7832 -- is actually a pointer. Dereference it for the call.
7834 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7835 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7839 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7842 Make_Procedure_Call_Statement
(Loc
,
7844 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
7845 Parameter_Associations
=> New_List
(
7847 Make_Attribute_Reference
(Loc
,
7849 New_Occurrence_Of
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7850 Attribute_Name
=> Name_Unrestricted_Access
)));
7851 end Make_Set_Finalize_Address_Call
;
7853 --------------------------
7854 -- Make_Transient_Block --
7855 --------------------------
7857 function Make_Transient_Block
7860 Par
: Node_Id
) return Node_Id
7862 Decls
: constant List_Id
:= New_List
;
7863 Instrs
: constant List_Id
:= New_List
(Action
);
7868 -- Case where only secondary stack use is involved
7870 if VM_Target
= No_VM
7871 and then Uses_Sec_Stack
(Current_Scope
)
7872 and then Nkind
(Action
) /= N_Simple_Return_Statement
7873 and then Nkind
(Par
) /= N_Exception_Handler
7879 S
:= Scope
(Current_Scope
);
7881 -- At the outer level, no need to release the sec stack
7883 if S
= Standard_Standard
then
7884 Set_Uses_Sec_Stack
(Current_Scope
, False);
7887 -- In a function, only release the sec stack if the function
7888 -- does not return on the sec stack otherwise the result may
7889 -- be lost. The caller is responsible for releasing.
7891 elsif Ekind
(S
) = E_Function
then
7892 Set_Uses_Sec_Stack
(Current_Scope
, False);
7894 if not Requires_Transient_Scope
(Etype
(S
)) then
7895 Set_Uses_Sec_Stack
(S
, True);
7896 Check_Restriction
(No_Secondary_Stack
, Action
);
7901 -- In a loop or entry we should install a block encompassing
7902 -- all the construct. For now just release right away.
7904 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7907 -- In a procedure or a block, we release on exit of the
7908 -- procedure or block. ??? memory leak can be created by
7911 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7912 Set_Uses_Sec_Stack
(S
, True);
7913 Check_Restriction
(No_Secondary_Stack
, Action
);
7914 Set_Uses_Sec_Stack
(Current_Scope
, False);
7924 -- Create the transient block. Set the parent now since the block itself
7925 -- is not part of the tree. The current scope is the E_Block entity
7926 -- that has been pushed by Establish_Transient_Scope.
7928 pragma Assert
(Ekind
(Current_Scope
) = E_Block
);
7930 Make_Block_Statement
(Loc
,
7931 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
7932 Declarations
=> Decls
,
7933 Handled_Statement_Sequence
=>
7934 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7935 Has_Created_Identifier
=> True);
7936 Set_Parent
(Block
, Par
);
7938 -- Insert actions stuck in the transient scopes as well as all freezing
7939 -- nodes needed by those actions. Do not insert cleanup actions here,
7940 -- they will be transferred to the newly created block.
7942 Insert_Actions_In_Scope_Around
7943 (Action
, Clean
=> False, Manage_SS
=> False);
7945 Insert
:= Prev
(Action
);
7946 if Present
(Insert
) then
7947 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7950 -- Transfer cleanup actions to the newly created block
7953 Cleanup_Actions
: List_Id
7954 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
7955 Actions_To_Be_Wrapped
(Cleanup
);
7957 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
7958 Cleanup_Actions
:= No_List
;
7961 -- When the transient scope was established, we pushed the entry for the
7962 -- transient scope onto the scope stack, so that the scope was active
7963 -- for the installation of finalizable entities etc. Now we must remove
7964 -- this entry, since we have constructed a proper block.
7969 end Make_Transient_Block
;
7971 ------------------------
7972 -- Node_To_Be_Wrapped --
7973 ------------------------
7975 function Node_To_Be_Wrapped
return Node_Id
is
7977 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7978 end Node_To_Be_Wrapped
;
7980 ----------------------------
7981 -- Set_Node_To_Be_Wrapped --
7982 ----------------------------
7984 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7986 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7987 end Set_Node_To_Be_Wrapped
;
7989 ----------------------------
7990 -- Store_Actions_In_Scope --
7991 ----------------------------
7993 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
7994 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7995 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
7998 if No
(Actions
) then
8001 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8002 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8004 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8009 elsif AK
= Before
then
8010 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8013 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8015 end Store_Actions_In_Scope
;
8017 ----------------------------------
8018 -- Store_After_Actions_In_Scope --
8019 ----------------------------------
8021 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8023 Store_Actions_In_Scope
(After
, L
);
8024 end Store_After_Actions_In_Scope
;
8026 -----------------------------------
8027 -- Store_Before_Actions_In_Scope --
8028 -----------------------------------
8030 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8032 Store_Actions_In_Scope
(Before
, L
);
8033 end Store_Before_Actions_In_Scope
;
8035 -----------------------------------
8036 -- Store_Cleanup_Actions_In_Scope --
8037 -----------------------------------
8039 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8041 Store_Actions_In_Scope
(Cleanup
, L
);
8042 end Store_Cleanup_Actions_In_Scope
;
8044 --------------------------------
8045 -- Wrap_Transient_Declaration --
8046 --------------------------------
8048 -- If a transient scope has been established during the processing of the
8049 -- Expression of an Object_Declaration, it is not possible to wrap the
8050 -- declaration into a transient block as usual case, otherwise the object
8051 -- would be itself declared in the wrong scope. Therefore, all entities (if
8052 -- any) defined in the transient block are moved to the proper enclosing
8053 -- scope. Furthermore, if they are controlled variables they are finalized
8054 -- right after the declaration. The finalization list of the transient
8055 -- scope is defined as a renaming of the enclosing one so during their
8056 -- initialization they will be attached to the proper finalization list.
8057 -- For instance, the following declaration :
8059 -- X : Typ := F (G (A), G (B));
8061 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8062 -- is expanded into :
8064 -- X : Typ := [ complex Expression-Action ];
8065 -- [Deep_]Finalize (_v1);
8066 -- [Deep_]Finalize (_v2);
8068 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8073 Curr_S
:= Current_Scope
;
8074 Encl_S
:= Scope
(Curr_S
);
8076 -- Insert all actions inluding cleanup generated while analyzing or
8077 -- expanding the transient context back into the tree. Manage the
8078 -- secondary stack when the object declaration appears in a library
8079 -- level package [body]. This is not needed for .NET/JVM as those do
8080 -- not support the secondary stack.
8082 Insert_Actions_In_Scope_Around
8087 and then Uses_Sec_Stack
(Curr_S
)
8088 and then Nkind
(N
) = N_Object_Declaration
8089 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8090 and then Is_Library_Level_Entity
(Encl_S
));
8093 -- Relocate local entities declared within the transient scope to the
8094 -- enclosing scope. This action sets their Is_Public flag accordingly.
8096 Transfer_Entities
(Curr_S
, Encl_S
);
8098 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8099 -- is properly released upon exiting the said scope. This is not needed
8100 -- for .NET/JVM as those do not support the secondary stack.
8102 if VM_Target
= No_VM
and then Uses_Sec_Stack
(Curr_S
) then
8103 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8105 -- Do not mark a function that returns on the secondary stack as the
8106 -- reclamation is done by the caller.
8108 if Ekind
(Curr_S
) = E_Function
8109 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8113 -- Otherwise mark the enclosing dynamic scope
8116 Set_Uses_Sec_Stack
(Curr_S
);
8117 Check_Restriction
(No_Secondary_Stack
, N
);
8120 end Wrap_Transient_Declaration
;
8122 -------------------------------
8123 -- Wrap_Transient_Expression --
8124 -------------------------------
8126 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8127 Loc
: constant Source_Ptr
:= Sloc
(N
);
8128 Expr
: Node_Id
:= Relocate_Node
(N
);
8129 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8130 Typ
: constant Entity_Id
:= Etype
(N
);
8137 -- M : constant Mark_Id := SS_Mark;
8138 -- procedure Finalizer is ... (See Build_Finalizer)
8141 -- Temp := <Expr>; -- general case
8142 -- Temp := (if <Expr> then True else False); -- boolean case
8148 -- A special case is made for Boolean expressions so that the back-end
8149 -- knows to generate a conditional branch instruction, if running with
8150 -- -fpreserve-control-flow. This ensures that a control flow change
8151 -- signalling the decision outcome occurs before the cleanup actions.
8153 if Opt
.Suppress_Control_Flow_Optimizations
8154 and then Is_Boolean_Type
(Typ
)
8157 Make_If_Expression
(Loc
,
8158 Expressions
=> New_List
(
8160 New_Occurrence_Of
(Standard_True
, Loc
),
8161 New_Occurrence_Of
(Standard_False
, Loc
)));
8164 Insert_Actions
(N
, New_List
(
8165 Make_Object_Declaration
(Loc
,
8166 Defining_Identifier
=> Temp
,
8167 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8169 Make_Transient_Block
(Loc
,
8171 Make_Assignment_Statement
(Loc
,
8172 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8173 Expression
=> Expr
),
8174 Par
=> Parent
(N
))));
8176 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8177 Analyze_And_Resolve
(N
, Typ
);
8178 end Wrap_Transient_Expression
;
8180 ------------------------------
8181 -- Wrap_Transient_Statement --
8182 ------------------------------
8184 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8185 Loc
: constant Source_Ptr
:= Sloc
(N
);
8186 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8191 -- M : constant Mark_Id := SS_Mark;
8192 -- procedure Finalizer is ... (See Build_Finalizer)
8202 Make_Transient_Block
(Loc
,
8204 Par
=> Parent
(N
)));
8206 -- With the scope stack back to normal, we can call analyze on the
8207 -- resulting block. At this point, the transient scope is being
8208 -- treated like a perfectly normal scope, so there is nothing
8209 -- special about it.
8211 -- Note: Wrap_Transient_Statement is called with the node already
8212 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8213 -- otherwise we would get a recursive processing of the node when
8214 -- we do this Analyze call.
8217 end Wrap_Transient_Statement
;