1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
;
45 with Ghost
; use Ghost
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
54 with Sinfo
; use Sinfo
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch7
; use Sem_Ch7
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Targparm
; use Targparm
;
65 with Tbuild
; use Tbuild
;
66 with Ttypes
; use Ttypes
;
67 with Uintp
; use Uintp
;
69 package body Exp_Ch7
is
71 --------------------------------
72 -- Transient Scope Management --
73 --------------------------------
75 -- A transient scope is created when temporary objects are created by the
76 -- compiler. These temporary objects are allocated on the secondary stack
77 -- and the transient scope is responsible for finalizing the object when
78 -- appropriate and reclaiming the memory at the right time. The temporary
79 -- objects are generally the objects allocated to store the result of a
80 -- function returning an unconstrained or a tagged value. Expressions
81 -- needing to be wrapped in a transient scope (functions calls returning
82 -- unconstrained or tagged values) may appear in 3 different contexts which
83 -- lead to 3 different kinds of transient scope expansion:
85 -- 1. In a simple statement (procedure call, assignment, ...). In this
86 -- case the instruction is wrapped into a transient block. See
87 -- Wrap_Transient_Statement for details.
89 -- 2. In an expression of a control structure (test in a IF statement,
90 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
93 -- 3. In a expression of an object_declaration. No wrapping is possible
94 -- here, so the finalization actions, if any, are done right after the
95 -- declaration and the secondary stack deallocation is done in the
96 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
98 -- Note about functions returning tagged types: it has been decided to
99 -- always allocate their result in the secondary stack, even though is not
100 -- absolutely mandatory when the tagged type is constrained because the
101 -- caller knows the size of the returned object and thus could allocate the
102 -- result in the primary stack. An exception to this is when the function
103 -- builds its result in place, as is done for functions with inherently
104 -- limited result types for Ada 2005. In that case, certain callers may
105 -- pass the address of a constrained object as the target object for the
108 -- By allocating tagged results in the secondary stack a number of
109 -- implementation difficulties are avoided:
111 -- - If it is a dispatching function call, the computation of the size of
112 -- the result is possible but complex from the outside.
114 -- - If the returned type is controlled, the assignment of the returned
115 -- value to the anonymous object involves an Adjust, and we have no
116 -- easy way to access the anonymous object created by the back end.
118 -- - If the returned type is class-wide, this is an unconstrained type
121 -- Furthermore, the small loss in efficiency which is the result of this
122 -- decision is not such a big deal because functions returning tagged types
123 -- are not as common in practice compared to functions returning access to
126 --------------------------------------------------
127 -- Transient Blocks and Finalization Management --
128 --------------------------------------------------
130 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
131 -- N is a node which may generate a transient scope. Loop over the parent
132 -- pointers of N until we find the appropriate node to wrap. If it returns
133 -- Empty, it means that no transient scope is needed in this context.
135 procedure Insert_Actions_In_Scope_Around
138 Manage_SS
: Boolean);
139 -- Insert the before-actions kept in the scope stack before N, and the
140 -- after-actions after N, which must be a member of a list. If flag Clean
141 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
142 -- calls to mark and release the secondary stack.
144 function Make_Transient_Block
147 Par
: Node_Id
) return Node_Id
;
148 -- Action is a single statement or object declaration. Par is the proper
149 -- parent of the generated block. Create a transient block whose name is
150 -- the current scope and the only handled statement is Action. If Action
151 -- involves controlled objects or secondary stack usage, the corresponding
152 -- cleanup actions are performed at the end of the block.
154 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
155 -- Set the field Node_To_Be_Wrapped of the current scope
157 -- ??? The entire comment needs to be rewritten
158 -- ??? which entire comment?
160 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
161 -- Shared processing for Store_xxx_Actions_In_Scope
163 -----------------------------
164 -- Finalization Management --
165 -----------------------------
167 -- This part describe how Initialization/Adjustment/Finalization procedures
168 -- are generated and called. Two cases must be considered, types that are
169 -- Controlled (Is_Controlled flag set) and composite types that contain
170 -- controlled components (Has_Controlled_Component flag set). In the first
171 -- case the procedures to call are the user-defined primitive operations
172 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
173 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
174 -- of calling the former procedures on the controlled components.
176 -- For records with Has_Controlled_Component set, a hidden "controller"
177 -- component is inserted. This controller component contains its own
178 -- finalization list on which all controlled components are attached
179 -- creating an indirection on the upper-level Finalization list. This
180 -- technique facilitates the management of objects whose number of
181 -- controlled components changes during execution. This controller
182 -- component is itself controlled and is attached to the upper-level
183 -- finalization chain. Its adjust primitive is in charge of calling adjust
184 -- on the components and adjusting the finalization pointer to match their
185 -- new location (see a-finali.adb).
187 -- It is not possible to use a similar technique for arrays that have
188 -- Has_Controlled_Component set. In this case, deep procedures are
189 -- generated that call initialize/adjust/finalize + attachment or
190 -- detachment on the finalization list for all component.
192 -- Initialize calls: they are generated for declarations or dynamic
193 -- allocations of Controlled objects with no initial value. They are always
194 -- followed by an attachment to the current Finalization Chain. For the
195 -- dynamic allocation case this the chain attached to the scope of the
196 -- access type definition otherwise, this is the chain of the current
199 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
200 -- or dynamic allocations of Controlled objects with an initial value.
201 -- (2) after an assignment. In the first case they are followed by an
202 -- attachment to the final chain, in the second case they are not.
204 -- Finalization Calls: They are generated on (1) scope exit, (2)
205 -- assignments, (3) unchecked deallocations. In case (3) they have to
206 -- be detached from the final chain, in case (2) they must not and in
207 -- case (1) this is not important since we are exiting the scope anyway.
211 -- Type extensions will have a new record controller at each derivation
212 -- level containing controlled components. The record controller for
213 -- the parent/ancestor is attached to the finalization list of the
214 -- extension's record controller (i.e. the parent is like a component
215 -- of the extension).
217 -- For types that are both Is_Controlled and Has_Controlled_Components,
218 -- the record controller and the object itself are handled separately.
219 -- It could seem simpler to attach the object at the end of its record
220 -- controller but this would not tackle view conversions properly.
222 -- A classwide type can always potentially have controlled components
223 -- but the record controller of the corresponding actual type may not
224 -- be known at compile time so the dispatch table contains a special
225 -- field that allows computation of the offset of the record controller
226 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
228 -- Here is a simple example of the expansion of a controlled block :
232 -- Y : Controlled := Init;
238 -- Z : R := (C => X);
248 -- _L : System.FI.Finalizable_Ptr;
250 -- procedure _Clean is
253 -- System.FI.Finalize_List (_L);
261 -- Attach_To_Final_List (_L, Finalizable (X), 1);
262 -- at end: Abort_Undefer;
263 -- Y : Controlled := Init;
265 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
273 -- Deep_Initialize (W, _L, 1);
274 -- at end: Abort_Under;
275 -- Z : R := (C => X);
276 -- Deep_Adjust (Z, _L, 1);
280 -- Deep_Finalize (W, False);
281 -- <save W's final pointers>
283 -- <restore W's final pointers>
284 -- Deep_Adjust (W, _L, 0);
289 type Final_Primitives
is
290 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
291 -- This enumeration type is defined in order to ease sharing code for
292 -- building finalization procedures for composite types.
294 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
295 (Initialize_Case
=> Name_Initialize
,
296 Adjust_Case
=> Name_Adjust
,
297 Finalize_Case
=> Name_Finalize
,
298 Address_Case
=> Name_Finalize_Address
);
299 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
300 (Initialize_Case
=> TSS_Deep_Initialize
,
301 Adjust_Case
=> TSS_Deep_Adjust
,
302 Finalize_Case
=> TSS_Deep_Finalize
,
303 Address_Case
=> TSS_Finalize_Address
);
305 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
306 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
307 -- Has_Controlled_Component set and store them using the TSS mechanism.
309 function Build_Cleanup_Statements
311 Additional_Cleanup
: List_Id
) return List_Id
;
312 -- Create the clean up calls for an asynchronous call block, task master,
313 -- protected subprogram body, task allocation block or task body, or
314 -- additional cleanup actions parked on a transient block. If the context
315 -- does not contain the above constructs, the routine returns an empty
318 procedure Build_Finalizer
320 Clean_Stmts
: List_Id
;
323 Defer_Abort
: Boolean;
324 Fin_Id
: out Entity_Id
);
325 -- N may denote an accept statement, block, entry body, package body,
326 -- package spec, protected body, subprogram body, or a task body. Create
327 -- a procedure which contains finalization calls for all controlled objects
328 -- declared in the declarative or statement region of N. The calls are
329 -- built in reverse order relative to the original declarations. In the
330 -- case of a task body, the routine delays the creation of the finalizer
331 -- until all statements have been moved to the task body procedure.
332 -- Clean_Stmts may contain additional context-dependent code used to abort
333 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
334 -- Mark_Id is the secondary stack used in the current context or Empty if
335 -- missing. Top_Decls is the list on which the declaration of the finalizer
336 -- is attached in the non-package case. Defer_Abort indicates that the
337 -- statements passed in perform actions that require abort to be deferred,
338 -- such as for task termination. Fin_Id is the finalizer declaration
341 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
342 -- N is a construct which contains a handled sequence of statements, Fin_Id
343 -- is the entity of a finalizer. Create an At_End handler which covers the
344 -- statements of N and calls Fin_Id. If the handled statement sequence has
345 -- an exception handler, the statements will be wrapped in a block to avoid
346 -- unwanted interaction with the new At_End handler.
348 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
349 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
350 -- Has_Component_Component set and store them using the TSS mechanism.
352 procedure Check_Visibly_Controlled
353 (Prim
: Final_Primitives
;
355 E
: in out Entity_Id
;
356 Cref
: in out Node_Id
);
357 -- The controlled operation declared for a derived type may not be
358 -- overriding, if the controlled operations of the parent type are hidden,
359 -- for example when the parent is a private type whose full view is
360 -- controlled. For other primitive operations we modify the name of the
361 -- operation to indicate that it is not overriding, but this is not
362 -- possible for Initialize, etc. because they have to be retrievable by
363 -- name. Before generating the proper call to one of these operations we
364 -- check whether Typ is known to be controlled at the point of definition.
365 -- If it is not then we must retrieve the hidden operation of the parent
366 -- and use it instead. This is one case that might be solved more cleanly
367 -- once Overriding pragmas or declarations are in place.
369 function Convert_View
372 Ind
: Pos
:= 1) return Node_Id
;
373 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
374 -- argument being passed to it. Ind indicates which formal of procedure
375 -- Proc we are trying to match. This function will, if necessary, generate
376 -- a conversion between the partial and full view of Arg to match the type
377 -- of the formal of Proc, or force a conversion to the class-wide type in
378 -- the case where the operation is abstract.
380 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
381 -- Given an arbitrary entity, traverse the scope chain looking for the
382 -- first enclosing function. Return Empty if no function was found.
388 Skip_Self
: Boolean := False) return Node_Id
;
389 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
390 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
391 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
392 -- action has an effect on the components only (if any).
394 function Make_Deep_Proc
395 (Prim
: Final_Primitives
;
397 Stmts
: List_Id
) return Node_Id
;
398 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
399 -- Deep_Finalize procedures according to the first parameter, these
400 -- procedures operate on the type Typ. The Stmts parameter gives the body
403 function Make_Deep_Array_Body
404 (Prim
: Final_Primitives
;
405 Typ
: Entity_Id
) return List_Id
;
406 -- This function generates the list of statements for implementing
407 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
408 -- the first parameter, these procedures operate on the array type Typ.
410 function Make_Deep_Record_Body
411 (Prim
: Final_Primitives
;
413 Is_Local
: Boolean := False) return List_Id
;
414 -- This function generates the list of statements for implementing
415 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
416 -- the first parameter, these procedures operate on the record type Typ.
417 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
418 -- whether the inner logic should be dictated by state counters.
420 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
421 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
422 -- Make_Deep_Record_Body. Generate the following statements:
425 -- type Acc_Typ is access all Typ;
426 -- for Acc_Typ'Storage_Size use 0;
428 -- [Deep_]Finalize (Acc_Typ (V).all);
431 ----------------------------
432 -- Build_Array_Deep_Procs --
433 ----------------------------
435 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
439 (Prim
=> Initialize_Case
,
441 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
443 if not Is_Limited_View
(Typ
) then
446 (Prim
=> Adjust_Case
,
448 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
451 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
452 -- suppressed since these routine will not be used.
454 if not Restriction_Active
(No_Finalization
) then
457 (Prim
=> Finalize_Case
,
459 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
461 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
462 -- .NET do not support address arithmetic and unchecked conversions.
464 if VM_Target
= No_VM
then
467 (Prim
=> Address_Case
,
469 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
472 end Build_Array_Deep_Procs
;
474 ------------------------------
475 -- Build_Cleanup_Statements --
476 ------------------------------
478 function Build_Cleanup_Statements
480 Additional_Cleanup
: List_Id
) return List_Id
482 Is_Asynchronous_Call
: constant Boolean :=
483 Nkind
(N
) = N_Block_Statement
484 and then Is_Asynchronous_Call_Block
(N
);
485 Is_Master
: constant Boolean :=
486 Nkind
(N
) /= N_Entry_Body
487 and then Is_Task_Master
(N
);
488 Is_Protected_Body
: constant Boolean :=
489 Nkind
(N
) = N_Subprogram_Body
490 and then Is_Protected_Subprogram_Body
(N
);
491 Is_Task_Allocation
: constant Boolean :=
492 Nkind
(N
) = N_Block_Statement
493 and then Is_Task_Allocation_Block
(N
);
494 Is_Task_Body
: constant Boolean :=
495 Nkind
(Original_Node
(N
)) = N_Task_Body
;
497 Loc
: constant Source_Ptr
:= Sloc
(N
);
498 Stmts
: constant List_Id
:= New_List
;
502 if Restricted_Profile
then
504 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
506 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
510 if Restriction_Active
(No_Task_Hierarchy
) = False then
511 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
514 -- Add statements to unlock the protected object parameter and to
515 -- undefer abort. If the context is a protected procedure and the object
516 -- has entries, call the entry service routine.
518 -- NOTE: The generated code references _object, a parameter to the
521 elsif Is_Protected_Body
then
523 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
524 Conc_Typ
: Entity_Id
;
526 Param_Typ
: Entity_Id
;
529 -- Find the _object parameter representing the protected object
531 Param
:= First
(Parameter_Specifications
(Spec
));
533 Param_Typ
:= Etype
(Parameter_Type
(Param
));
535 if Ekind
(Param_Typ
) = E_Record_Type
then
536 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
539 exit when No
(Param
) or else Present
(Conc_Typ
);
543 pragma Assert
(Present
(Param
));
545 -- Historical note: In earlier versions of GNAT, there was code
546 -- at this point to generate stuff to service entry queues. It is
547 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
549 Build_Protected_Subprogram_Call_Cleanup
550 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
553 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
554 -- tasks. Other unactivated tasks are completed by Complete_Task or
557 -- NOTE: The generated code references _chain, a local object
559 elsif Is_Task_Allocation
then
562 -- Expunge_Unactivated_Tasks (_chain);
564 -- where _chain is the list of tasks created by the allocator but not
565 -- yet activated. This list will be empty unless the block completes
569 Make_Procedure_Call_Statement
(Loc
,
572 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
573 Parameter_Associations
=> New_List
(
574 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
576 -- Attempt to cancel an asynchronous entry call whenever the block which
577 -- contains the abortable part is exited.
579 -- NOTE: The generated code references Cnn, a local object
581 elsif Is_Asynchronous_Call
then
583 Cancel_Param
: constant Entity_Id
:=
584 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
587 -- If it is of type Communication_Block, this must be a protected
588 -- entry call. Generate:
590 -- if Enqueued (Cancel_Param) then
591 -- Cancel_Protected_Entry_Call (Cancel_Param);
594 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
596 Make_If_Statement
(Loc
,
598 Make_Function_Call
(Loc
,
600 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
601 Parameter_Associations
=> New_List
(
602 New_Occurrence_Of
(Cancel_Param
, Loc
))),
604 Then_Statements
=> New_List
(
605 Make_Procedure_Call_Statement
(Loc
,
608 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
609 Parameter_Associations
=> New_List
(
610 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
612 -- Asynchronous delay, generate:
613 -- Cancel_Async_Delay (Cancel_Param);
615 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
617 Make_Procedure_Call_Statement
(Loc
,
619 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
620 Parameter_Associations
=> New_List
(
621 Make_Attribute_Reference
(Loc
,
623 New_Occurrence_Of
(Cancel_Param
, Loc
),
624 Attribute_Name
=> Name_Unchecked_Access
))));
626 -- Task entry call, generate:
627 -- Cancel_Task_Entry_Call (Cancel_Param);
631 Make_Procedure_Call_Statement
(Loc
,
633 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
634 Parameter_Associations
=> New_List
(
635 New_Occurrence_Of
(Cancel_Param
, Loc
))));
640 Append_List_To
(Stmts
, Additional_Cleanup
);
642 end Build_Cleanup_Statements
;
644 -----------------------------
645 -- Build_Controlling_Procs --
646 -----------------------------
648 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
650 if Is_Array_Type
(Typ
) then
651 Build_Array_Deep_Procs
(Typ
);
652 else pragma Assert
(Is_Record_Type
(Typ
));
653 Build_Record_Deep_Procs
(Typ
);
655 end Build_Controlling_Procs
;
657 -----------------------------
658 -- Build_Exception_Handler --
659 -----------------------------
661 function Build_Exception_Handler
662 (Data
: Finalization_Exception_Data
;
663 For_Library
: Boolean := False) return Node_Id
666 Proc_To_Call
: Entity_Id
;
671 pragma Assert
(Present
(Data
.Raised_Id
));
673 if Exception_Extra_Info
674 or else (For_Library
and not Restricted_Profile
)
676 if Exception_Extra_Info
then
680 -- Get_Current_Excep.all
683 Make_Function_Call
(Data
.Loc
,
685 Make_Explicit_Dereference
(Data
.Loc
,
688 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
695 Except
:= Make_Null
(Data
.Loc
);
698 if For_Library
and then not Restricted_Profile
then
699 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
700 Actuals
:= New_List
(Except
);
703 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
705 -- The dereference occurs only when Exception_Extra_Info is true,
706 -- and therefore Except is not null.
710 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
711 Make_Explicit_Dereference
(Data
.Loc
, Except
));
717 -- if not Raised_Id then
718 -- Raised_Id := True;
720 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
722 -- Save_Library_Occurrence (Get_Current_Excep.all);
727 Make_If_Statement
(Data
.Loc
,
729 Make_Op_Not
(Data
.Loc
,
730 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
732 Then_Statements
=> New_List
(
733 Make_Assignment_Statement
(Data
.Loc
,
734 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
735 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
737 Make_Procedure_Call_Statement
(Data
.Loc
,
739 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
740 Parameter_Associations
=> Actuals
))));
745 -- Raised_Id := True;
748 Make_Assignment_Statement
(Data
.Loc
,
749 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
750 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
758 Make_Exception_Handler
(Data
.Loc
,
759 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
760 Statements
=> Stmts
);
761 end Build_Exception_Handler
;
763 -------------------------------
764 -- Build_Finalization_Master --
765 -------------------------------
767 procedure Build_Finalization_Master
769 For_Anonymous
: Boolean := False;
770 For_Private
: Boolean := False;
771 Context_Scope
: Entity_Id
:= Empty
;
772 Insertion_Node
: Node_Id
:= Empty
)
774 procedure Add_Pending_Access_Type
776 Ptr_Typ
: Entity_Id
);
777 -- Add access type Ptr_Typ to the pending access type list for type Typ
779 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
780 -- Determine whether entity E is inside a wrapper package created for
781 -- an instance of Ada.Unchecked_Deallocation.
783 -----------------------------
784 -- Add_Pending_Access_Type --
785 -----------------------------
787 procedure Add_Pending_Access_Type
794 if Present
(Pending_Access_Types
(Typ
)) then
795 List
:= Pending_Access_Types
(Typ
);
797 List
:= New_Elmt_List
;
798 Set_Pending_Access_Types
(Typ
, List
);
801 Prepend_Elmt
(Ptr_Typ
, List
);
802 end Add_Pending_Access_Type
;
804 ------------------------------
805 -- In_Deallocation_Instance --
806 ------------------------------
808 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
809 Pkg
: constant Entity_Id
:= Scope
(E
);
810 Par
: Node_Id
:= Empty
;
813 if Ekind
(Pkg
) = E_Package
814 and then Present
(Related_Instance
(Pkg
))
815 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
817 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
821 and then Chars
(Par
) = Name_Unchecked_Deallocation
822 and then Chars
(Scope
(Par
)) = Name_Ada
823 and then Scope
(Scope
(Par
)) = Standard_Standard
;
827 end In_Deallocation_Instance
;
831 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
833 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
834 -- A finalization master created for a named access type is associated
835 -- with the full view (if applicable) as a consequence of freezing. The
836 -- full view criteria does not apply to anonymous access types because
837 -- those cannot have a private and a full view.
839 -- Start of processing for Build_Finalization_Master
842 -- Certain run-time configurations and targets do not provide support
843 -- for controlled types.
845 if Restriction_Active
(No_Finalization
) then
848 -- Do not process C, C++, CIL and Java types since it is assumend that
849 -- the non-Ada side will handle their clean up.
851 elsif Convention
(Desig_Typ
) = Convention_C
852 or else Convention
(Desig_Typ
) = Convention_CIL
853 or else Convention
(Desig_Typ
) = Convention_CPP
854 or else Convention
(Desig_Typ
) = Convention_Java
858 -- Various machinery such as freezing may have already created a
859 -- finalization master.
861 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
864 -- Do not process types that return on the secondary stack
866 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
867 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
871 -- Do not process types which may never allocate an object
873 elsif No_Pool_Assigned
(Ptr_Typ
) then
876 -- Do not process access types coming from Ada.Unchecked_Deallocation
877 -- instances. Even though the designated type may be controlled, the
878 -- access type will never participate in allocation.
880 elsif In_Deallocation_Instance
(Ptr_Typ
) then
883 -- Ignore the general use of anonymous access types unless the context
884 -- requires a finalization master.
886 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
887 and then not For_Anonymous
891 -- Do not process non-library access types when restriction No_Nested_
892 -- Finalization is in effect since masters are controlled objects.
894 elsif Restriction_Active
(No_Nested_Finalization
)
895 and then not Is_Library_Level_Entity
(Ptr_Typ
)
899 -- For .NET/JVM targets, allow the processing of access-to-controlled
900 -- types where the designated type is explicitly derived from [Limited_]
903 elsif VM_Target
/= No_VM
and then not Is_Controlled
(Desig_Typ
) then
906 -- Do not create finalization masters in GNATprove mode because this
907 -- unwanted extra expansion. A compilation in this mode keeps the tree
908 -- as close as possible to the original sources.
910 elsif GNATprove_Mode
then
915 Actions
: constant List_Id
:= New_List
;
916 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
917 Fin_Mas_Id
: Entity_Id
;
921 -- Source access types use fixed master names since the master is
922 -- inserted in the same source unit only once. The only exception to
923 -- this are instances using the same access type as generic actual.
925 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
927 Make_Defining_Identifier
(Loc
,
928 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
930 -- Internally generated access types use temporaries as their names
931 -- due to possible collision with identical names coming from other
935 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
938 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
941 -- <Ptr_Typ>FM : aliased Finalization_Master;
944 Make_Object_Declaration
(Loc
,
945 Defining_Identifier
=> Fin_Mas_Id
,
946 Aliased_Present
=> True,
948 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
950 -- Set the associated pool and primitive Finalize_Address of the new
951 -- finalization master. This step is skipped on .NET/JVM because the
952 -- target does not support storage pools or address arithmetic.
954 if VM_Target
= No_VM
then
956 -- The access type has a user-defined storage pool, use it
958 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
959 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
961 -- Otherwise the default choice is the global storage pool
964 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
965 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
969 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
972 Make_Procedure_Call_Statement
(Loc
,
974 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
975 Parameter_Associations
=> New_List
(
976 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
977 Make_Attribute_Reference
(Loc
,
978 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
979 Attribute_Name
=> Name_Unrestricted_Access
))));
981 -- Finalize_Address is not generated in CodePeer mode because the
982 -- body contains address arithmetic. Skip this step.
984 if CodePeer_Mode
then
987 -- Associate the Finalize_Address primitive of the designated type
988 -- with the finalization master of the access type. The designated
989 -- type must be forzen as Finalize_Address is generated when the
990 -- freeze node is expanded.
992 elsif Is_Frozen
(Desig_Typ
)
993 and then Present
(Finalize_Address
(Desig_Typ
))
995 -- The finalization master of an anonymous access type may need
996 -- to be inserted in a specific place in the tree. For instance:
1000 -- <finalization master of "access Comp_Typ">
1002 -- type Rec_Typ is record
1003 -- Comp : access Comp_Typ;
1006 -- <freeze node for Comp_Typ>
1007 -- <freeze node for Rec_Typ>
1009 -- Due to this oddity, the anonymous access type is stored for
1010 -- later processing (see below).
1012 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1015 -- Set_Finalize_Address
1016 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1019 Make_Set_Finalize_Address_Call
1021 Ptr_Typ
=> Ptr_Typ
));
1023 -- Otherwise the designated type is either anonymous access or a
1024 -- Taft-amendment type and has not been frozen. Store the access
1025 -- type for later processing (see Freeze_Type).
1028 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1032 -- A finalization master created for an anonymous access type or an
1033 -- access designating a type with private components must be inserted
1034 -- before a context-dependent node.
1036 if For_Anonymous
or For_Private
then
1038 -- At this point both the scope of the context and the insertion
1039 -- mode must be known.
1041 pragma Assert
(Present
(Context_Scope
));
1042 pragma Assert
(Present
(Insertion_Node
));
1044 Push_Scope
(Context_Scope
);
1046 -- Treat use clauses as declarations and insert directly in front
1049 if Nkind_In
(Insertion_Node
, N_Use_Package_Clause
,
1052 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1054 Insert_Actions
(Insertion_Node
, Actions
);
1059 -- Otherwise the finalization master and its initialization become a
1060 -- part of the freeze node.
1063 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1066 end Build_Finalization_Master
;
1068 ---------------------
1069 -- Build_Finalizer --
1070 ---------------------
1072 procedure Build_Finalizer
1074 Clean_Stmts
: List_Id
;
1075 Mark_Id
: Entity_Id
;
1076 Top_Decls
: List_Id
;
1077 Defer_Abort
: Boolean;
1078 Fin_Id
: out Entity_Id
)
1080 Acts_As_Clean
: constant Boolean :=
1083 (Present
(Clean_Stmts
)
1084 and then Is_Non_Empty_List
(Clean_Stmts
));
1085 Exceptions_OK
: constant Boolean :=
1086 not Restriction_Active
(No_Exception_Propagation
);
1087 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1088 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1089 For_Package
: constant Boolean :=
1090 For_Package_Body
or else For_Package_Spec
;
1091 Loc
: constant Source_Ptr
:= Sloc
(N
);
1093 -- NOTE: Local variable declarations are conservative and do not create
1094 -- structures right from the start. Entities and lists are created once
1095 -- it has been established that N has at least one controlled object.
1097 Components_Built
: Boolean := False;
1098 -- A flag used to avoid double initialization of entities and lists. If
1099 -- the flag is set then the following variables have been initialized:
1105 Counter_Id
: Entity_Id
:= Empty
;
1106 Counter_Val
: Int
:= 0;
1107 -- Name and value of the state counter
1109 Decls
: List_Id
:= No_List
;
1110 -- Declarative region of N (if available). If N is a package declaration
1111 -- Decls denotes the visible declarations.
1113 Finalizer_Data
: Finalization_Exception_Data
;
1114 -- Data for the exception
1116 Finalizer_Decls
: List_Id
:= No_List
;
1117 -- Local variable declarations. This list holds the label declarations
1118 -- of all jump block alternatives as well as the declaration of the
1119 -- local exception occurence and the raised flag:
1120 -- E : Exception_Occurrence;
1121 -- Raised : Boolean := False;
1122 -- L<counter value> : label;
1124 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1125 -- Insertion point for the finalizer body. Depending on the context
1126 -- (Nkind of N) and the individual grouping of controlled objects, this
1127 -- node may denote a package declaration or body, package instantiation,
1128 -- block statement or a counter update statement.
1130 Finalizer_Stmts
: List_Id
:= No_List
;
1131 -- The statement list of the finalizer body. It contains the following:
1133 -- Abort_Defer; -- Added if abort is allowed
1134 -- <call to Prev_At_End> -- Added if exists
1135 -- <cleanup statements> -- Added if Acts_As_Clean
1136 -- <jump block> -- Added if Has_Ctrl_Objs
1137 -- <finalization statements> -- Added if Has_Ctrl_Objs
1138 -- <stack release> -- Added if Mark_Id exists
1139 -- Abort_Undefer; -- Added if abort is allowed
1141 Has_Ctrl_Objs
: Boolean := False;
1142 -- A general flag which denotes whether N has at least one controlled
1145 Has_Tagged_Types
: Boolean := False;
1146 -- A general flag which indicates whether N has at least one library-
1147 -- level tagged type declaration.
1149 HSS
: Node_Id
:= Empty
;
1150 -- The sequence of statements of N (if available)
1152 Jump_Alts
: List_Id
:= No_List
;
1153 -- Jump block alternatives. Depending on the value of the state counter,
1154 -- the control flow jumps to a sequence of finalization statements. This
1155 -- list contains the following:
1157 -- when <counter value> =>
1158 -- goto L<counter value>;
1160 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1161 -- Specific point in the finalizer statements where the jump block is
1164 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1165 -- The last controlled construct encountered when processing the top
1166 -- level lists of N. This can be a nested package, an instantiation or
1167 -- an object declaration.
1169 Prev_At_End
: Entity_Id
:= Empty
;
1170 -- The previous at end procedure of the handled statements block of N
1172 Priv_Decls
: List_Id
:= No_List
;
1173 -- The private declarations of N if N is a package declaration
1175 Spec_Id
: Entity_Id
:= Empty
;
1176 Spec_Decls
: List_Id
:= Top_Decls
;
1177 Stmts
: List_Id
:= No_List
;
1179 Tagged_Type_Stmts
: List_Id
:= No_List
;
1180 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1181 -- tagged types found in N.
1183 -----------------------
1184 -- Local subprograms --
1185 -----------------------
1187 procedure Build_Components
;
1188 -- Create all entites and initialize all lists used in the creation of
1191 procedure Create_Finalizer
;
1192 -- Create the spec and body of the finalizer and insert them in the
1193 -- proper place in the tree depending on the context.
1195 procedure Process_Declarations
1197 Preprocess
: Boolean := False;
1198 Top_Level
: Boolean := False);
1199 -- Inspect a list of declarations or statements which may contain
1200 -- objects that need finalization. When flag Preprocess is set, the
1201 -- routine will simply count the total number of controlled objects in
1202 -- Decls. Flag Top_Level denotes whether the processing is done for
1203 -- objects in nested package declarations or instances.
1205 procedure Process_Object_Declaration
1207 Has_No_Init
: Boolean := False;
1208 Is_Protected
: Boolean := False);
1209 -- Generate all the machinery associated with the finalization of a
1210 -- single object. Flag Has_No_Init is used to denote certain contexts
1211 -- where Decl does not have initialization call(s). Flag Is_Protected
1212 -- is set when Decl denotes a simple protected object.
1214 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1215 -- Generate all the code necessary to unregister the external tag of a
1218 ----------------------
1219 -- Build_Components --
1220 ----------------------
1222 procedure Build_Components
is
1223 Counter_Decl
: Node_Id
;
1224 Counter_Typ
: Entity_Id
;
1225 Counter_Typ_Decl
: Node_Id
;
1228 pragma Assert
(Present
(Decls
));
1230 -- This routine might be invoked several times when dealing with
1231 -- constructs that have two lists (either two declarative regions
1232 -- or declarations and statements). Avoid double initialization.
1234 if Components_Built
then
1238 Components_Built
:= True;
1240 if Has_Ctrl_Objs
then
1242 -- Create entities for the counter, its type, the local exception
1243 -- and the raised flag.
1245 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1246 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1248 Finalizer_Decls
:= New_List
;
1250 Build_Object_Declarations
1251 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1253 -- Since the total number of controlled objects is always known,
1254 -- build a subtype of Natural with precise bounds. This allows
1255 -- the backend to optimize the case statement. Generate:
1257 -- subtype Tnn is Natural range 0 .. Counter_Val;
1260 Make_Subtype_Declaration
(Loc
,
1261 Defining_Identifier
=> Counter_Typ
,
1262 Subtype_Indication
=>
1263 Make_Subtype_Indication
(Loc
,
1264 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1266 Make_Range_Constraint
(Loc
,
1270 Make_Integer_Literal
(Loc
, Uint_0
),
1272 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1274 -- Generate the declaration of the counter itself:
1276 -- Counter : Integer := 0;
1279 Make_Object_Declaration
(Loc
,
1280 Defining_Identifier
=> Counter_Id
,
1281 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1282 Expression
=> Make_Integer_Literal
(Loc
, 0));
1284 -- Set the type of the counter explicitly to prevent errors when
1285 -- examining object declarations later on.
1287 Set_Etype
(Counter_Id
, Counter_Typ
);
1289 -- The counter and its type are inserted before the source
1290 -- declarations of N.
1292 Prepend_To
(Decls
, Counter_Decl
);
1293 Prepend_To
(Decls
, Counter_Typ_Decl
);
1295 -- The counter and its associated type must be manually analized
1296 -- since N has already been analyzed. Use the scope of the spec
1297 -- when inserting in a package.
1300 Push_Scope
(Spec_Id
);
1301 Analyze
(Counter_Typ_Decl
);
1302 Analyze
(Counter_Decl
);
1306 Analyze
(Counter_Typ_Decl
);
1307 Analyze
(Counter_Decl
);
1310 Jump_Alts
:= New_List
;
1313 -- If the context requires additional clean up, the finalization
1314 -- machinery is added after the clean up code.
1316 if Acts_As_Clean
then
1317 Finalizer_Stmts
:= Clean_Stmts
;
1318 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1320 Finalizer_Stmts
:= New_List
;
1323 if Has_Tagged_Types
then
1324 Tagged_Type_Stmts
:= New_List
;
1326 end Build_Components
;
1328 ----------------------
1329 -- Create_Finalizer --
1330 ----------------------
1332 procedure Create_Finalizer
is
1333 Body_Id
: Entity_Id
;
1336 Jump_Block
: Node_Id
;
1338 Label_Id
: Entity_Id
;
1340 function New_Finalizer_Name
return Name_Id
;
1341 -- Create a fully qualified name of a package spec or body finalizer.
1342 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1344 ------------------------
1345 -- New_Finalizer_Name --
1346 ------------------------
1348 function New_Finalizer_Name
return Name_Id
is
1349 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1350 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1351 -- has a non-standard scope, process the scope first.
1353 ------------------------
1354 -- New_Finalizer_Name --
1355 ------------------------
1357 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1359 if Scope
(Id
) = Standard_Standard
then
1360 Get_Name_String
(Chars
(Id
));
1363 New_Finalizer_Name
(Scope
(Id
));
1364 Add_Str_To_Name_Buffer
("__");
1365 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1367 end New_Finalizer_Name
;
1369 -- Start of processing for New_Finalizer_Name
1372 -- Create the fully qualified name of the enclosing scope
1374 New_Finalizer_Name
(Spec_Id
);
1377 -- __finalize_[spec|body]
1379 Add_Str_To_Name_Buffer
("__finalize_");
1381 if For_Package_Spec
then
1382 Add_Str_To_Name_Buffer
("spec");
1384 Add_Str_To_Name_Buffer
("body");
1388 end New_Finalizer_Name
;
1390 -- Start of processing for Create_Finalizer
1393 -- Step 1: Creation of the finalizer name
1395 -- Packages must use a distinct name for their finalizers since the
1396 -- binder will have to generate calls to them by name. The name is
1397 -- of the following form:
1399 -- xx__yy__finalize_[spec|body]
1402 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1403 Set_Has_Qualified_Name
(Fin_Id
);
1404 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1406 -- The default name is _finalizer
1410 Make_Defining_Identifier
(Loc
,
1411 Chars
=> New_External_Name
(Name_uFinalizer
));
1413 -- The visibility semantics of AT_END handlers force a strange
1414 -- separation of spec and body for stack-related finalizers:
1416 -- declare : Enclosing_Scope
1417 -- procedure _finalizer;
1419 -- <controlled objects>
1420 -- procedure _finalizer is
1426 -- Both spec and body are within the same construct and scope, but
1427 -- the body is part of the handled sequence of statements. This
1428 -- placement confuses the elaboration mechanism on targets where
1429 -- AT_END handlers are expanded into "when all others" handlers:
1432 -- when all others =>
1433 -- _finalizer; -- appears to require elab checks
1438 -- Since the compiler guarantees that the body of a _finalizer is
1439 -- always inserted in the same construct where the AT_END handler
1440 -- resides, there is no need for elaboration checks.
1442 Set_Kill_Elaboration_Checks
(Fin_Id
);
1444 -- Inlining the finalizer produces a substantial speedup at -O2.
1445 -- It is inlined by default at -O3. Either way, it is called
1446 -- exactly twice (once on the normal path, and once for
1447 -- exceptions/abort), so this won't bloat the code too much.
1449 Set_Is_Inlined
(Fin_Id
);
1452 -- Step 2: Creation of the finalizer specification
1455 -- procedure Fin_Id;
1458 Make_Subprogram_Declaration
(Loc
,
1460 Make_Procedure_Specification
(Loc
,
1461 Defining_Unit_Name
=> Fin_Id
));
1463 -- Step 3: Creation of the finalizer body
1465 if Has_Ctrl_Objs
then
1467 -- Add L0, the default destination to the jump block
1469 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1470 Set_Entity
(Label_Id
,
1471 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1472 Label
:= Make_Label
(Loc
, Label_Id
);
1477 Prepend_To
(Finalizer_Decls
,
1478 Make_Implicit_Label_Declaration
(Loc
,
1479 Defining_Identifier
=> Entity
(Label_Id
),
1480 Label_Construct
=> Label
));
1486 Append_To
(Jump_Alts
,
1487 Make_Case_Statement_Alternative
(Loc
,
1488 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1489 Statements
=> New_List
(
1490 Make_Goto_Statement
(Loc
,
1491 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1496 Append_To
(Finalizer_Stmts
, Label
);
1498 -- Create the jump block which controls the finalization flow
1499 -- depending on the value of the state counter.
1502 Make_Case_Statement
(Loc
,
1503 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1504 Alternatives
=> Jump_Alts
);
1506 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1507 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1509 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1513 -- Add the library-level tagged type unregistration machinery before
1514 -- the jump block circuitry. This ensures that external tags will be
1515 -- removed even if a finalization exception occurs at some point.
1517 if Has_Tagged_Types
then
1518 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1521 -- Add a call to the previous At_End handler if it exists. The call
1522 -- must always precede the jump block.
1524 if Present
(Prev_At_End
) then
1525 Prepend_To
(Finalizer_Stmts
,
1526 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1528 -- Clear the At_End handler since we have already generated the
1529 -- proper replacement call for it.
1531 Set_At_End_Proc
(HSS
, Empty
);
1534 -- Release the secondary stack mark
1536 if Present
(Mark_Id
) then
1537 Append_To
(Finalizer_Stmts
, Build_SS_Release_Call
(Loc
, Mark_Id
));
1540 -- Protect the statements with abort defer/undefer. This is only when
1541 -- aborts are allowed and the clean up statements require deferral or
1542 -- there are controlled objects to be finalized.
1544 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1545 Prepend_To
(Finalizer_Stmts
,
1546 Make_Procedure_Call_Statement
(Loc
,
1547 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Defer
), Loc
)));
1549 Append_To
(Finalizer_Stmts
,
1550 Make_Procedure_Call_Statement
(Loc
,
1551 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Undefer
), Loc
)));
1554 -- The local exception does not need to be reraised for library-level
1555 -- finalizers. Note that this action must be carried out after object
1556 -- clean up, secondary stack release and abort undeferral. Generate:
1558 -- if Raised and then not Abort then
1559 -- Raise_From_Controlled_Operation (E);
1562 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1563 Append_To
(Finalizer_Stmts
,
1564 Build_Raise_Statement
(Finalizer_Data
));
1568 -- procedure Fin_Id is
1569 -- Abort : constant Boolean := Triggered_By_Abort;
1571 -- Abort : constant Boolean := False; -- no abort
1573 -- E : Exception_Occurrence; -- All added if flag
1574 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1580 -- Abort_Defer; -- Added if abort is allowed
1581 -- <call to Prev_At_End> -- Added if exists
1582 -- <cleanup statements> -- Added if Acts_As_Clean
1583 -- <jump block> -- Added if Has_Ctrl_Objs
1584 -- <finalization statements> -- Added if Has_Ctrl_Objs
1585 -- <stack release> -- Added if Mark_Id exists
1586 -- Abort_Undefer; -- Added if abort is allowed
1587 -- <exception propagation> -- Added if Has_Ctrl_Objs
1590 -- Create the body of the finalizer
1592 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1595 Set_Has_Qualified_Name
(Body_Id
);
1596 Set_Has_Fully_Qualified_Name
(Body_Id
);
1600 Make_Subprogram_Body
(Loc
,
1602 Make_Procedure_Specification
(Loc
,
1603 Defining_Unit_Name
=> Body_Id
),
1604 Declarations
=> Finalizer_Decls
,
1605 Handled_Statement_Sequence
=>
1606 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1608 -- Step 4: Spec and body insertion, analysis
1612 -- If the package spec has private declarations, the finalizer
1613 -- body must be added to the end of the list in order to have
1614 -- visibility of all private controlled objects.
1616 if For_Package_Spec
then
1617 if Present
(Priv_Decls
) then
1618 Append_To
(Priv_Decls
, Fin_Spec
);
1619 Append_To
(Priv_Decls
, Fin_Body
);
1621 Append_To
(Decls
, Fin_Spec
);
1622 Append_To
(Decls
, Fin_Body
);
1625 -- For package bodies, both the finalizer spec and body are
1626 -- inserted at the end of the package declarations.
1629 Append_To
(Decls
, Fin_Spec
);
1630 Append_To
(Decls
, Fin_Body
);
1633 -- Push the name of the package
1635 Push_Scope
(Spec_Id
);
1643 -- Create the spec for the finalizer. The At_End handler must be
1644 -- able to call the body which resides in a nested structure.
1648 -- procedure Fin_Id; -- Spec
1650 -- <objects and possibly statements>
1651 -- procedure Fin_Id is ... -- Body
1654 -- Fin_Id; -- At_End handler
1657 pragma Assert
(Present
(Spec_Decls
));
1659 Append_To
(Spec_Decls
, Fin_Spec
);
1662 -- When the finalizer acts solely as a clean up routine, the body
1663 -- is inserted right after the spec.
1665 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1666 Insert_After
(Fin_Spec
, Fin_Body
);
1668 -- In all other cases the body is inserted after either:
1670 -- 1) The counter update statement of the last controlled object
1671 -- 2) The last top level nested controlled package
1672 -- 3) The last top level controlled instantiation
1675 -- Manually freeze the spec. This is somewhat of a hack because
1676 -- a subprogram is frozen when its body is seen and the freeze
1677 -- node appears right before the body. However, in this case,
1678 -- the spec must be frozen earlier since the At_End handler
1679 -- must be able to call it.
1682 -- procedure Fin_Id; -- Spec
1683 -- [Fin_Id] -- Freeze node
1687 -- Fin_Id; -- At_End handler
1690 Ensure_Freeze_Node
(Fin_Id
);
1691 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1692 Set_Is_Frozen
(Fin_Id
);
1694 -- In the case where the last construct to contain a controlled
1695 -- object is either a nested package, an instantiation or a
1696 -- freeze node, the body must be inserted directly after the
1699 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1701 N_Package_Declaration
,
1704 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1707 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1712 end Create_Finalizer
;
1714 --------------------------
1715 -- Process_Declarations --
1716 --------------------------
1718 procedure Process_Declarations
1720 Preprocess
: Boolean := False;
1721 Top_Level
: Boolean := False)
1726 Obj_Typ
: Entity_Id
;
1727 Pack_Id
: Entity_Id
;
1731 Old_Counter_Val
: Int
;
1732 -- This variable is used to determine whether a nested package or
1733 -- instance contains at least one controlled object.
1735 procedure Processing_Actions
1736 (Has_No_Init
: Boolean := False;
1737 Is_Protected
: Boolean := False);
1738 -- Depending on the mode of operation of Process_Declarations, either
1739 -- increment the controlled object counter, set the controlled object
1740 -- flag and store the last top level construct or process the current
1741 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1742 -- the current declaration may not have initialization proc(s). Flag
1743 -- Is_Protected should be set when the current declaration denotes a
1744 -- simple protected object.
1746 ------------------------
1747 -- Processing_Actions --
1748 ------------------------
1750 procedure Processing_Actions
1751 (Has_No_Init
: Boolean := False;
1752 Is_Protected
: Boolean := False)
1755 -- Library-level tagged type
1757 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1759 Has_Tagged_Types
:= True;
1761 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1762 Last_Top_Level_Ctrl_Construct
:= Decl
;
1766 Process_Tagged_Type_Declaration
(Decl
);
1769 -- Controlled object declaration
1773 Counter_Val
:= Counter_Val
+ 1;
1774 Has_Ctrl_Objs
:= True;
1776 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1777 Last_Top_Level_Ctrl_Construct
:= Decl
;
1781 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1784 end Processing_Actions
;
1786 -- Start of processing for Process_Declarations
1789 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1793 -- Process all declarations in reverse order
1795 Decl
:= Last_Non_Pragma
(Decls
);
1796 while Present
(Decl
) loop
1798 -- Library-level tagged types
1800 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1801 Typ
:= Defining_Identifier
(Decl
);
1803 -- Ignored Ghost types do not need any cleanup actions because
1804 -- they will not appear in the final tree.
1806 if Is_Ignored_Ghost_Entity
(Typ
) then
1809 elsif Is_Tagged_Type
(Typ
)
1810 and then Is_Library_Level_Entity
(Typ
)
1811 and then Convention
(Typ
) = Convention_Ada
1812 and then Present
(Access_Disp_Table
(Typ
))
1813 and then RTE_Available
(RE_Register_Tag
)
1814 and then not Is_Abstract_Type
(Typ
)
1815 and then not No_Run_Time_Mode
1820 -- Regular object declarations
1822 elsif Nkind
(Decl
) = N_Object_Declaration
then
1823 Obj_Id
:= Defining_Identifier
(Decl
);
1824 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1825 Expr
:= Expression
(Decl
);
1827 -- Bypass any form of processing for objects which have their
1828 -- finalization disabled. This applies only to objects at the
1831 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1834 -- Transient variables are treated separately in order to
1835 -- minimize the size of the generated code. For details, see
1836 -- Process_Transient_Objects.
1838 elsif Is_Processed_Transient
(Obj_Id
) then
1841 -- Ignored Ghost objects do not need any cleanup actions
1842 -- because they will not appear in the final tree.
1844 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
1847 -- The object is of the form:
1848 -- Obj : Typ [:= Expr];
1850 -- Do not process the incomplete view of a deferred constant.
1851 -- Do not consider tag-to-class-wide conversions.
1853 elsif not Is_Imported
(Obj_Id
)
1854 and then Needs_Finalization
(Obj_Typ
)
1855 and then not (Ekind
(Obj_Id
) = E_Constant
1856 and then not Has_Completion
(Obj_Id
))
1857 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1861 -- The object is of the form:
1862 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1864 -- Obj : Access_Typ :=
1865 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1867 elsif Is_Access_Type
(Obj_Typ
)
1868 and then Needs_Finalization
1869 (Available_View
(Designated_Type
(Obj_Typ
)))
1870 and then Present
(Expr
)
1872 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1874 (Is_Non_BIP_Func_Call
(Expr
)
1875 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1877 Processing_Actions
(Has_No_Init
=> True);
1879 -- Processing for "hook" objects generated for controlled
1880 -- transients declared inside an Expression_With_Actions.
1882 elsif Is_Access_Type
(Obj_Typ
)
1883 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1884 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1885 N_Object_Declaration
1887 Processing_Actions
(Has_No_Init
=> True);
1889 -- Process intermediate results of an if expression with one
1890 -- of the alternatives using a controlled function call.
1892 elsif Is_Access_Type
(Obj_Typ
)
1893 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1894 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1895 N_Defining_Identifier
1896 and then Present
(Expr
)
1897 and then Nkind
(Expr
) = N_Null
1899 Processing_Actions
(Has_No_Init
=> True);
1901 -- Simple protected objects which use type System.Tasking.
1902 -- Protected_Objects.Protection to manage their locks should
1903 -- be treated as controlled since they require manual cleanup.
1904 -- The only exception is illustrated in the following example:
1907 -- type Ctrl is new Controlled ...
1908 -- procedure Finalize (Obj : in out Ctrl);
1912 -- package body Pkg is
1913 -- protected Prot is
1914 -- procedure Do_Something (Obj : in out Ctrl);
1917 -- protected body Prot is
1918 -- procedure Do_Something (Obj : in out Ctrl) is ...
1921 -- procedure Finalize (Obj : in out Ctrl) is
1923 -- Prot.Do_Something (Obj);
1927 -- Since for the most part entities in package bodies depend on
1928 -- those in package specs, Prot's lock should be cleaned up
1929 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1930 -- This act however attempts to invoke Do_Something and fails
1931 -- because the lock has disappeared.
1933 elsif Ekind
(Obj_Id
) = E_Variable
1934 and then not In_Library_Level_Package_Body
(Obj_Id
)
1935 and then (Is_Simple_Protected_Type
(Obj_Typ
)
1936 or else Has_Simple_Protected_Object
(Obj_Typ
))
1938 Processing_Actions
(Is_Protected
=> True);
1941 -- Specific cases of object renamings
1943 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1944 Obj_Id
:= Defining_Identifier
(Decl
);
1945 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1947 -- Bypass any form of processing for objects which have their
1948 -- finalization disabled. This applies only to objects at the
1951 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1954 -- Ignored Ghost object renamings do not need any cleanup
1955 -- actions because they will not appear in the final tree.
1957 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
1960 -- Return object of a build-in-place function. This case is
1961 -- recognized and marked by the expansion of an extended return
1962 -- statement (see Expand_N_Extended_Return_Statement).
1964 elsif Needs_Finalization
(Obj_Typ
)
1965 and then Is_Return_Object
(Obj_Id
)
1966 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1968 Processing_Actions
(Has_No_Init
=> True);
1970 -- Detect a case where a source object has been initialized by
1971 -- a controlled function call or another object which was later
1972 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1974 -- Obj1 : CW_Type := Src_Obj;
1975 -- Obj2 : CW_Type := Function_Call (...);
1977 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1978 -- Tmp : ... := Function_Call (...)'reference;
1979 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1981 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1982 Processing_Actions
(Has_No_Init
=> True);
1985 -- Inspect the freeze node of an access-to-controlled type and
1986 -- look for a delayed finalization master. This case arises when
1987 -- the freeze actions are inserted at a later time than the
1988 -- expansion of the context. Since Build_Finalizer is never called
1989 -- on a single construct twice, the master will be ultimately
1990 -- left out and never finalized. This is also needed for freeze
1991 -- actions of designated types themselves, since in some cases the
1992 -- finalization master is associated with a designated type's
1993 -- freeze node rather than that of the access type (see handling
1994 -- for freeze actions in Build_Finalization_Master).
1996 elsif Nkind
(Decl
) = N_Freeze_Entity
1997 and then Present
(Actions
(Decl
))
1999 Typ
:= Entity
(Decl
);
2001 -- Freeze nodes for ignored Ghost types do not need cleanup
2002 -- actions because they will never appear in the final tree.
2004 if Is_Ignored_Ghost_Entity
(Typ
) then
2007 elsif (Is_Access_Type
(Typ
)
2008 and then not Is_Access_Subprogram_Type
(Typ
)
2009 and then Needs_Finalization
2010 (Available_View
(Designated_Type
(Typ
))))
2011 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2013 Old_Counter_Val
:= Counter_Val
;
2015 -- Freeze nodes are considered to be identical to packages
2016 -- and blocks in terms of nesting. The difference is that
2017 -- a finalization master created inside the freeze node is
2018 -- at the same nesting level as the node itself.
2020 Process_Declarations
(Actions
(Decl
), Preprocess
);
2022 -- The freeze node contains a finalization master
2026 and then No
(Last_Top_Level_Ctrl_Construct
)
2027 and then Counter_Val
> Old_Counter_Val
2029 Last_Top_Level_Ctrl_Construct
:= Decl
;
2033 -- Nested package declarations, avoid generics
2035 elsif Nkind
(Decl
) = N_Package_Declaration
then
2036 Pack_Id
:= Defining_Entity
(Decl
);
2037 Spec
:= Specification
(Decl
);
2039 -- Do not inspect an ignored Ghost package because all code
2040 -- found within will not appear in the final tree.
2042 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2045 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2046 Old_Counter_Val
:= Counter_Val
;
2047 Process_Declarations
2048 (Private_Declarations
(Spec
), Preprocess
);
2049 Process_Declarations
2050 (Visible_Declarations
(Spec
), Preprocess
);
2052 -- Either the visible or the private declarations contain a
2053 -- controlled object. The nested package declaration is the
2054 -- last such construct.
2058 and then No
(Last_Top_Level_Ctrl_Construct
)
2059 and then Counter_Val
> Old_Counter_Val
2061 Last_Top_Level_Ctrl_Construct
:= Decl
;
2065 -- Nested package bodies, avoid generics
2067 elsif Nkind
(Decl
) = N_Package_Body
then
2069 -- Do not inspect an ignored Ghost package body because all
2070 -- code found within will not appear in the final tree.
2072 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2075 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2078 Old_Counter_Val
:= Counter_Val
;
2079 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2081 -- The nested package body is the last construct to contain
2082 -- a controlled object.
2086 and then No
(Last_Top_Level_Ctrl_Construct
)
2087 and then Counter_Val
> Old_Counter_Val
2089 Last_Top_Level_Ctrl_Construct
:= Decl
;
2093 -- Handle a rare case caused by a controlled transient variable
2094 -- created as part of a record init proc. The variable is wrapped
2095 -- in a block, but the block is not associated with a transient
2098 elsif Nkind
(Decl
) = N_Block_Statement
2099 and then Inside_Init_Proc
2101 Old_Counter_Val
:= Counter_Val
;
2103 if Present
(Handled_Statement_Sequence
(Decl
)) then
2104 Process_Declarations
2105 (Statements
(Handled_Statement_Sequence
(Decl
)),
2109 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2111 -- Either the declaration or statement list of the block has a
2112 -- controlled object.
2116 and then No
(Last_Top_Level_Ctrl_Construct
)
2117 and then Counter_Val
> Old_Counter_Val
2119 Last_Top_Level_Ctrl_Construct
:= Decl
;
2122 -- Handle the case where the original context has been wrapped in
2123 -- a block to avoid interference between exception handlers and
2124 -- At_End handlers. Treat the block as transparent and process its
2127 elsif Nkind
(Decl
) = N_Block_Statement
2128 and then Is_Finalization_Wrapper
(Decl
)
2130 if Present
(Handled_Statement_Sequence
(Decl
)) then
2131 Process_Declarations
2132 (Statements
(Handled_Statement_Sequence
(Decl
)),
2136 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2139 Prev_Non_Pragma
(Decl
);
2141 end Process_Declarations
;
2143 --------------------------------
2144 -- Process_Object_Declaration --
2145 --------------------------------
2147 procedure Process_Object_Declaration
2149 Has_No_Init
: Boolean := False;
2150 Is_Protected
: Boolean := False)
2152 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2153 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2155 Init_Typ
: Entity_Id
;
2156 -- The initialization type of the related object declaration. Note
2157 -- that this is not necessarely the same type as Obj_Typ because of
2158 -- possible type derivations.
2160 Obj_Typ
: Entity_Id
;
2161 -- The type of the related object declaration
2163 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2164 -- Func_Id denotes a build-in-place function. Generate the following
2167 -- if BIPallocfrom > Secondary_Stack'Pos
2168 -- and then BIPfinalizationmaster /= null
2171 -- type Ptr_Typ is access Obj_Typ;
2172 -- for Ptr_Typ'Storage_Pool
2173 -- use Base_Pool (BIPfinalizationmaster);
2175 -- Free (Ptr_Typ (Temp));
2179 -- Obj_Typ is the type of the current object, Temp is the original
2180 -- allocation which Obj_Id renames.
2182 procedure Find_Last_Init
2183 (Last_Init
: out Node_Id
;
2184 Body_Insert
: out Node_Id
);
2185 -- Find the last initialization call related to object declaration
2186 -- Decl. Last_Init denotes the last initialization call which follows
2187 -- Decl. Body_Insert denotes a node where the finalizer body could be
2188 -- potentially inserted after (if blocks are involved).
2190 -----------------------------
2191 -- Build_BIP_Cleanup_Stmts --
2192 -----------------------------
2194 function Build_BIP_Cleanup_Stmts
2195 (Func_Id
: Entity_Id
) return Node_Id
2197 Decls
: constant List_Id
:= New_List
;
2198 Fin_Mas_Id
: constant Entity_Id
:=
2199 Build_In_Place_Formal
2200 (Func_Id
, BIP_Finalization_Master
);
2201 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2202 Temp_Id
: constant Entity_Id
:=
2203 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2207 Free_Stmt
: Node_Id
;
2208 Pool_Id
: Entity_Id
;
2209 Ptr_Typ
: Entity_Id
;
2213 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2215 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2218 Make_Object_Renaming_Declaration
(Loc
,
2219 Defining_Identifier
=> Pool_Id
,
2221 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2223 Make_Explicit_Dereference
(Loc
,
2225 Make_Function_Call
(Loc
,
2227 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2228 Parameter_Associations
=> New_List
(
2229 Make_Explicit_Dereference
(Loc
,
2231 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2233 -- Create an access type which uses the storage pool of the
2234 -- caller's finalization master.
2237 -- type Ptr_Typ is access Func_Typ;
2239 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2242 Make_Full_Type_Declaration
(Loc
,
2243 Defining_Identifier
=> Ptr_Typ
,
2245 Make_Access_To_Object_Definition
(Loc
,
2246 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2248 -- Perform minor decoration in order to set the master and the
2249 -- storage pool attributes.
2251 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2252 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2253 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2255 -- Create an explicit free statement. Note that the free uses the
2256 -- caller's pool expressed as a renaming.
2259 Make_Free_Statement
(Loc
,
2261 Unchecked_Convert_To
(Ptr_Typ
,
2262 New_Occurrence_Of
(Temp_Id
, Loc
)));
2264 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2266 -- Create a block to house the dummy type and the instantiation as
2267 -- well as to perform the cleanup the temporary.
2273 -- Free (Ptr_Typ (Temp_Id));
2277 Make_Block_Statement
(Loc
,
2278 Declarations
=> Decls
,
2279 Handled_Statement_Sequence
=>
2280 Make_Handled_Sequence_Of_Statements
(Loc
,
2281 Statements
=> New_List
(Free_Stmt
)));
2284 -- if BIPfinalizationmaster /= null then
2288 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2289 Right_Opnd
=> Make_Null
(Loc
));
2291 -- For constrained or tagged results escalate the condition to
2292 -- include the allocation format. Generate:
2294 -- if BIPallocform > Secondary_Stack'Pos
2295 -- and then BIPfinalizationmaster /= null
2298 if not Is_Constrained
(Func_Typ
)
2299 or else Is_Tagged_Type
(Func_Typ
)
2302 Alloc
: constant Entity_Id
:=
2303 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2309 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2311 Make_Integer_Literal
(Loc
,
2313 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2315 Right_Opnd
=> Cond
);
2325 Make_If_Statement
(Loc
,
2327 Then_Statements
=> New_List
(Free_Blk
));
2328 end Build_BIP_Cleanup_Stmts
;
2330 --------------------
2331 -- Find_Last_Init --
2332 --------------------
2334 procedure Find_Last_Init
2335 (Last_Init
: out Node_Id
;
2336 Body_Insert
: out Node_Id
)
2338 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2339 -- Find the last initialization call within the statements of
2342 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2343 -- Determine whether node N denotes one of the initialization
2344 -- procedures of types Init_Typ or Obj_Typ.
2346 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2347 -- Given a statement which is part of a list, return the next
2348 -- statement while skipping over dynamic elab checks.
2350 -----------------------------
2351 -- Find_Last_Init_In_Block --
2352 -----------------------------
2354 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2355 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2359 -- Examine the individual statements of the block in reverse to
2360 -- locate the last initialization call.
2362 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2363 Stmt
:= Last
(Statements
(HSS
));
2364 while Present
(Stmt
) loop
2366 -- Peek inside nested blocks in case aborts are allowed
2368 if Nkind
(Stmt
) = N_Block_Statement
then
2369 return Find_Last_Init_In_Block
(Stmt
);
2371 elsif Is_Init_Call
(Stmt
) then
2380 end Find_Last_Init_In_Block
;
2386 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2387 function Is_Init_Proc_Of
2388 (Subp_Id
: Entity_Id
;
2389 Typ
: Entity_Id
) return Boolean;
2390 -- Determine whether subprogram Subp_Id is a valid init proc of
2393 ---------------------
2394 -- Is_Init_Proc_Of --
2395 ---------------------
2397 function Is_Init_Proc_Of
2398 (Subp_Id
: Entity_Id
;
2399 Typ
: Entity_Id
) return Boolean
2401 Deep_Init
: Entity_Id
:= Empty
;
2402 Prim_Init
: Entity_Id
:= Empty
;
2403 Type_Init
: Entity_Id
:= Empty
;
2406 -- Obtain all possible initialization routines of the
2407 -- related type and try to match the subprogram entity
2408 -- against one of them.
2412 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2414 -- Primitive Initialize
2416 if Is_Controlled
(Typ
) then
2417 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2419 if Present
(Prim_Init
) then
2420 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2424 -- Type initialization routine
2426 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2427 Type_Init
:= Base_Init_Proc
(Typ
);
2431 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2433 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2435 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2436 end Is_Init_Proc_Of
;
2440 Call_Id
: Entity_Id
;
2442 -- Start of processing for Is_Init_Call
2445 if Nkind
(N
) = N_Procedure_Call_Statement
2446 and then Nkind
(Name
(N
)) = N_Identifier
2448 Call_Id
:= Entity
(Name
(N
));
2450 -- Consider both the type of the object declaration and its
2451 -- related initialization type.
2454 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2456 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2462 -----------------------------
2463 -- Next_Suitable_Statement --
2464 -----------------------------
2466 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2467 Result
: Node_Id
:= Next
(Stmt
);
2470 -- Skip over access-before-elaboration checks
2472 if Dynamic_Elaboration_Checks
2473 and then Nkind
(Result
) = N_Raise_Program_Error
2475 Result
:= Next
(Result
);
2479 end Next_Suitable_Statement
;
2487 Deep_Init_Found
: Boolean := False;
2488 -- A flag set when a call to [Deep_]Initialize has been found
2490 -- Start of processing for Find_Last_Init
2494 Body_Insert
:= Empty
;
2496 -- Object renamings and objects associated with controlled
2497 -- function results do not require initialization.
2503 Stmt
:= Next_Suitable_Statement
(Decl
);
2505 -- A limited controlled object initialized by a function call uses
2506 -- the build-in-place machinery to obtain its value.
2508 -- Obj : Lim_Controlled_Type := Func_Call;
2512 -- Obj : Lim_Controlled_Type;
2513 -- type Ptr_Typ is access Lim_Controlled_Type;
2514 -- Temp : constant Ptr_Typ :=
2517 -- BIPaccess => Obj'Unrestricted_Access)'reference;
2519 -- In this scenario the declaration of the temporary acts as the
2520 -- last initialization statement.
2522 if Is_Limited_Type
(Obj_Typ
)
2523 and then Has_Init_Expression
(Decl
)
2524 and then No
(Expression
(Decl
))
2526 while Present
(Stmt
) loop
2527 if Nkind
(Stmt
) = N_Object_Declaration
2528 and then Present
(Expression
(Stmt
))
2529 and then Is_Object_Access_BIP_Func_Call
2530 (Expr
=> Expression
(Stmt
),
2540 -- Nothing to do for an object with supporessed initialization.
2541 -- Note that this check is not performed at the beginning of the
2542 -- routine because a declaration marked with No_Initialization
2543 -- may still be initialized by a build-in-place call (the case
2546 elsif No_Initialization
(Decl
) then
2549 -- In all other cases the initialization calls follow the related
2550 -- object. The general structure of object initialization built by
2551 -- routine Default_Initialize_Object is as follows:
2553 -- [begin -- aborts allowed
2555 -- Type_Init_Proc (Obj);
2556 -- [begin] -- exceptions allowed
2557 -- Deep_Initialize (Obj);
2558 -- [exception -- exceptions allowed
2560 -- Deep_Finalize (Obj, Self => False);
2563 -- [at end -- aborts allowed
2567 -- When aborts are allowed, the initialization calls are housed
2570 elsif Nkind
(Stmt
) = N_Block_Statement
then
2571 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2572 Body_Insert
:= Stmt
;
2574 -- Otherwise the initialization calls follow the related object
2577 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2579 -- Check for an optional call to Deep_Initialize which may
2580 -- appear within a block depending on whether the object has
2581 -- controlled components.
2583 if Present
(Stmt_2
) then
2584 if Nkind
(Stmt_2
) = N_Block_Statement
then
2585 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2587 if Present
(Call
) then
2588 Deep_Init_Found
:= True;
2590 Body_Insert
:= Stmt_2
;
2593 elsif Is_Init_Call
(Stmt_2
) then
2594 Deep_Init_Found
:= True;
2595 Last_Init
:= Stmt_2
;
2596 Body_Insert
:= Last_Init
;
2600 -- If the object lacks a call to Deep_Initialize, then it must
2601 -- have a call to its related type init proc.
2603 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2605 Body_Insert
:= Last_Init
;
2613 Count_Ins
: Node_Id
;
2615 Fin_Stmts
: List_Id
;
2618 Label_Id
: Entity_Id
;
2621 -- Start of processing for Process_Object_Declaration
2624 -- Handle the object type and the reference to the object
2626 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2627 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2630 if Is_Access_Type
(Obj_Typ
) then
2631 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2632 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2634 elsif Is_Concurrent_Type
(Obj_Typ
)
2635 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2637 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2638 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2640 elsif Is_Private_Type
(Obj_Typ
)
2641 and then Present
(Full_View
(Obj_Typ
))
2643 Obj_Typ
:= Full_View
(Obj_Typ
);
2644 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2646 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2647 Obj_Typ
:= Base_Type
(Obj_Typ
);
2648 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2655 Set_Etype
(Obj_Ref
, Obj_Typ
);
2657 -- Handle the initialization type of the object declaration
2659 Init_Typ
:= Obj_Typ
;
2661 if Is_Private_Type
(Init_Typ
)
2662 and then Present
(Full_View
(Init_Typ
))
2664 Init_Typ
:= Full_View
(Init_Typ
);
2666 elsif Is_Untagged_Derivation
(Init_Typ
) then
2667 Init_Typ
:= Root_Type
(Init_Typ
);
2674 -- Set a new value for the state counter and insert the statement
2675 -- after the object declaration. Generate:
2677 -- Counter := <value>;
2680 Make_Assignment_Statement
(Loc
,
2681 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2682 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2684 -- Insert the counter after all initialization has been done. The
2685 -- place of insertion depends on the context. If an object is being
2686 -- initialized via an aggregate, then the counter must be inserted
2687 -- after the last aggregate assignment.
2689 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2690 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
2692 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2695 -- In all other cases the counter is inserted after the last call to
2696 -- either [Deep_]Initialize or the type specific init proc.
2699 Find_Last_Init
(Count_Ins
, Body_Ins
);
2702 Insert_After
(Count_Ins
, Inc_Decl
);
2705 -- If the current declaration is the last in the list, the finalizer
2706 -- body needs to be inserted after the set counter statement for the
2707 -- current object declaration. This is complicated by the fact that
2708 -- the set counter statement may appear in abort deferred block. In
2709 -- that case, the proper insertion place is after the block.
2711 if No
(Finalizer_Insert_Nod
) then
2713 -- Insertion after an abort deffered block
2715 if Present
(Body_Ins
) then
2716 Finalizer_Insert_Nod
:= Body_Ins
;
2718 Finalizer_Insert_Nod
:= Inc_Decl
;
2722 -- Create the associated label with this object, generate:
2724 -- L<counter> : label;
2727 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2729 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2730 Label
:= Make_Label
(Loc
, Label_Id
);
2732 Prepend_To
(Finalizer_Decls
,
2733 Make_Implicit_Label_Declaration
(Loc
,
2734 Defining_Identifier
=> Entity
(Label_Id
),
2735 Label_Construct
=> Label
));
2737 -- Create the associated jump with this object, generate:
2739 -- when <counter> =>
2742 Prepend_To
(Jump_Alts
,
2743 Make_Case_Statement_Alternative
(Loc
,
2744 Discrete_Choices
=> New_List
(
2745 Make_Integer_Literal
(Loc
, Counter_Val
)),
2746 Statements
=> New_List
(
2747 Make_Goto_Statement
(Loc
,
2748 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
2750 -- Insert the jump destination, generate:
2754 Append_To
(Finalizer_Stmts
, Label
);
2756 -- Processing for simple protected objects. Such objects require
2757 -- manual finalization of their lock managers.
2759 if Is_Protected
then
2760 Fin_Stmts
:= No_List
;
2762 if Is_Simple_Protected_Type
(Obj_Typ
) then
2763 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2765 if Present
(Fin_Call
) then
2766 Fin_Stmts
:= New_List
(Fin_Call
);
2769 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2770 if Is_Record_Type
(Obj_Typ
) then
2771 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2772 elsif Is_Array_Type
(Obj_Typ
) then
2773 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2779 -- System.Tasking.Protected_Objects.Finalize_Protection
2787 if Present
(Fin_Stmts
) then
2788 Append_To
(Finalizer_Stmts
,
2789 Make_Block_Statement
(Loc
,
2790 Handled_Statement_Sequence
=>
2791 Make_Handled_Sequence_Of_Statements
(Loc
,
2792 Statements
=> Fin_Stmts
,
2794 Exception_Handlers
=> New_List
(
2795 Make_Exception_Handler
(Loc
,
2796 Exception_Choices
=> New_List
(
2797 Make_Others_Choice
(Loc
)),
2799 Statements
=> New_List
(
2800 Make_Null_Statement
(Loc
)))))));
2803 -- Processing for regular controlled objects
2807 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2809 -- begin -- Exception handlers allowed
2810 -- [Deep_]Finalize (Obj);
2813 -- when Id : others =>
2814 -- if not Raised then
2816 -- Save_Occurrence (E, Id);
2825 -- For CodePeer, the exception handlers normally generated here
2826 -- generate complex flowgraphs which result in capacity problems.
2827 -- Omitting these handlers for CodePeer is justified as follows:
2829 -- If a handler is dead, then omitting it is surely ok
2831 -- If a handler is live, then CodePeer should flag the
2832 -- potentially-exception-raising construct that causes it
2833 -- to be live. That is what we are interested in, not what
2834 -- happens after the exception is raised.
2836 if Exceptions_OK
and not CodePeer_Mode
then
2837 Fin_Stmts
:= New_List
(
2838 Make_Block_Statement
(Loc
,
2839 Handled_Statement_Sequence
=>
2840 Make_Handled_Sequence_Of_Statements
(Loc
,
2841 Statements
=> New_List
(Fin_Call
),
2843 Exception_Handlers
=> New_List
(
2844 Build_Exception_Handler
2845 (Finalizer_Data
, For_Package
)))));
2847 -- When exception handlers are prohibited, the finalization call
2848 -- appears unprotected. Any exception raised during finalization
2849 -- will bypass the circuitry which ensures the cleanup of all
2850 -- remaining objects.
2853 Fin_Stmts
:= New_List
(Fin_Call
);
2856 -- If we are dealing with a return object of a build-in-place
2857 -- function, generate the following cleanup statements:
2859 -- if BIPallocfrom > Secondary_Stack'Pos
2860 -- and then BIPfinalizationmaster /= null
2863 -- type Ptr_Typ is access Obj_Typ;
2864 -- for Ptr_Typ'Storage_Pool use
2865 -- Base_Pool (BIPfinalizationmaster.all).all;
2867 -- Free (Ptr_Typ (Temp));
2871 -- The generated code effectively detaches the temporary from the
2872 -- caller finalization master and deallocates the object. This is
2873 -- disabled on .NET/JVM because pools are not supported.
2875 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2877 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2879 if Is_Build_In_Place_Function
(Func_Id
)
2880 and then Needs_BIP_Finalization_Master
(Func_Id
)
2882 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2887 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2888 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2890 -- Temporaries created for the purpose of "exporting" a
2891 -- controlled transient out of an Expression_With_Actions (EWA)
2892 -- need guards. The following illustrates the usage of such
2895 -- Access_Typ : access [all] Obj_Typ;
2896 -- Temp : Access_Typ := null;
2897 -- <Counter> := ...;
2900 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2901 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2903 -- Temp := Ctrl_Trans'Unchecked_Access;
2906 -- The finalization machinery does not process EWA nodes as
2907 -- this may lead to premature finalization of expressions. Note
2908 -- that Temp is marked as being properly initialized regardless
2909 -- of whether the initialization of Ctrl_Trans succeeded. Since
2910 -- a failed initialization may leave Temp with a value of null,
2911 -- add a guard to handle this case:
2913 -- if Obj /= null then
2914 -- <object finalization statements>
2917 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2918 N_Object_Declaration
2920 Fin_Stmts
:= New_List
(
2921 Make_If_Statement
(Loc
,
2924 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
2925 Right_Opnd
=> Make_Null
(Loc
)),
2926 Then_Statements
=> Fin_Stmts
));
2928 -- Return objects use a flag to aid in processing their
2929 -- potential finalization when the enclosing function fails
2930 -- to return properly. Generate:
2933 -- <object finalization statements>
2937 Fin_Stmts
:= New_List
(
2938 Make_If_Statement
(Loc
,
2943 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2945 Then_Statements
=> Fin_Stmts
));
2950 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2952 -- Since the declarations are examined in reverse, the state counter
2953 -- must be decremented in order to keep with the true position of
2956 Counter_Val
:= Counter_Val
- 1;
2957 end Process_Object_Declaration
;
2959 -------------------------------------
2960 -- Process_Tagged_Type_Declaration --
2961 -------------------------------------
2963 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2964 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2965 DT_Ptr
: constant Entity_Id
:=
2966 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2969 -- Ada.Tags.Unregister_Tag (<Typ>P);
2971 Append_To
(Tagged_Type_Stmts
,
2972 Make_Procedure_Call_Statement
(Loc
,
2974 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
2975 Parameter_Associations
=> New_List
(
2976 New_Occurrence_Of
(DT_Ptr
, Loc
))));
2977 end Process_Tagged_Type_Declaration
;
2979 -- Start of processing for Build_Finalizer
2984 -- Do not perform this expansion in SPARK mode because it is not
2987 if GNATprove_Mode
then
2991 -- Step 1: Extract all lists which may contain controlled objects or
2992 -- library-level tagged types.
2994 if For_Package_Spec
then
2995 Decls
:= Visible_Declarations
(Specification
(N
));
2996 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2998 -- Retrieve the package spec id
3000 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3002 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3003 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3006 -- Accept statement, block, entry body, package body, protected body,
3007 -- subprogram body or task body.
3010 Decls
:= Declarations
(N
);
3011 HSS
:= Handled_Statement_Sequence
(N
);
3013 if Present
(HSS
) then
3014 if Present
(Statements
(HSS
)) then
3015 Stmts
:= Statements
(HSS
);
3018 if Present
(At_End_Proc
(HSS
)) then
3019 Prev_At_End
:= At_End_Proc
(HSS
);
3023 -- Retrieve the package spec id for package bodies
3025 if For_Package_Body
then
3026 Spec_Id
:= Corresponding_Spec
(N
);
3030 -- Do not process nested packages since those are handled by the
3031 -- enclosing scope's finalizer. Do not process non-expanded package
3032 -- instantiations since those will be re-analyzed and re-expanded.
3036 (not Is_Library_Level_Entity
(Spec_Id
)
3038 -- Nested packages are considered to be library level entities,
3039 -- but do not need to be processed separately. True library level
3040 -- packages have a scope value of 1.
3042 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3043 or else (Is_Generic_Instance
(Spec_Id
)
3044 and then Package_Instantiation
(Spec_Id
) /= N
))
3049 -- Step 2: Object [pre]processing
3053 -- Preprocess the visible declarations now in order to obtain the
3054 -- correct number of controlled object by the time the private
3055 -- declarations are processed.
3057 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3059 -- From all the possible contexts, only package specifications may
3060 -- have private declarations.
3062 if For_Package_Spec
then
3063 Process_Declarations
3064 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3067 -- The current context may lack controlled objects, but require some
3068 -- other form of completion (task termination for instance). In such
3069 -- cases, the finalizer must be created and carry the additional
3072 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3076 -- The preprocessing has determined that the context has controlled
3077 -- objects or library-level tagged types.
3079 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3081 -- Private declarations are processed first in order to preserve
3082 -- possible dependencies between public and private objects.
3084 if For_Package_Spec
then
3085 Process_Declarations
(Priv_Decls
);
3088 Process_Declarations
(Decls
);
3094 -- Preprocess both declarations and statements
3096 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3097 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3099 -- At this point it is known that N has controlled objects. Ensure
3100 -- that N has a declarative list since the finalizer spec will be
3103 if Has_Ctrl_Objs
and then No
(Decls
) then
3104 Set_Declarations
(N
, New_List
);
3105 Decls
:= Declarations
(N
);
3106 Spec_Decls
:= Decls
;
3109 -- The current context may lack controlled objects, but require some
3110 -- other form of completion (task termination for instance). In such
3111 -- cases, the finalizer must be created and carry the additional
3114 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3118 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3119 Process_Declarations
(Stmts
);
3120 Process_Declarations
(Decls
);
3124 -- Step 3: Finalizer creation
3126 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3129 end Build_Finalizer
;
3131 --------------------------
3132 -- Build_Finalizer_Call --
3133 --------------------------
3135 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3136 Is_Prot_Body
: constant Boolean :=
3137 Nkind
(N
) = N_Subprogram_Body
3138 and then Is_Protected_Subprogram_Body
(N
);
3139 -- Determine whether N denotes the protected version of a subprogram
3140 -- which belongs to a protected type.
3142 Loc
: constant Source_Ptr
:= Sloc
(N
);
3146 -- Do not perform this expansion in SPARK mode because we do not create
3147 -- finalizers in the first place.
3149 if GNATprove_Mode
then
3153 -- The At_End handler should have been assimilated by the finalizer
3155 HSS
:= Handled_Statement_Sequence
(N
);
3156 pragma Assert
(No
(At_End_Proc
(HSS
)));
3158 -- If the construct to be cleaned up is a protected subprogram body, the
3159 -- finalizer call needs to be associated with the block which wraps the
3160 -- unprotected version of the subprogram. The following illustrates this
3163 -- procedure Prot_SubpP is
3164 -- procedure finalizer is
3166 -- Service_Entries (Prot_Obj);
3173 -- Prot_SubpN (Prot_Obj);
3179 if Is_Prot_Body
then
3180 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3182 -- An At_End handler and regular exception handlers cannot coexist in
3183 -- the same statement sequence. Wrap the original statements in a block.
3185 elsif Present
(Exception_Handlers
(HSS
)) then
3187 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3192 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3194 Set_Handled_Statement_Sequence
(N
,
3195 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3197 HSS
:= Handled_Statement_Sequence
(N
);
3198 Set_End_Label
(HSS
, End_Lab
);
3202 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3204 Analyze
(At_End_Proc
(HSS
));
3205 Expand_At_End_Handler
(HSS
, Empty
);
3206 end Build_Finalizer_Call
;
3208 ---------------------
3209 -- Build_Late_Proc --
3210 ---------------------
3212 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3214 for Final_Prim
in Name_Of
'Range loop
3215 if Name_Of
(Final_Prim
) = Nam
then
3218 (Prim
=> Final_Prim
,
3220 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3223 end Build_Late_Proc
;
3225 -------------------------------
3226 -- Build_Object_Declarations --
3227 -------------------------------
3229 procedure Build_Object_Declarations
3230 (Data
: out Finalization_Exception_Data
;
3233 For_Package
: Boolean := False)
3238 -- This variable captures an unused dummy internal entity, see the
3239 -- comment associated with its use.
3242 pragma Assert
(Decls
/= No_List
);
3244 -- Always set the proper location as it may be needed even when
3245 -- exception propagation is forbidden.
3249 if Restriction_Active
(No_Exception_Propagation
) then
3250 Data
.Abort_Id
:= Empty
;
3252 Data
.Raised_Id
:= Empty
;
3256 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3258 -- In certain scenarios, finalization can be triggered by an abort. If
3259 -- the finalization itself fails and raises an exception, the resulting
3260 -- Program_Error must be supressed and replaced by an abort signal. In
3261 -- order to detect this scenario, save the state of entry into the
3262 -- finalization code.
3264 -- No need to do this for VM case, since VM version of Ada.Exceptions
3265 -- does not include routine Raise_From_Controlled_Operation which is the
3266 -- the sole user of flag Abort.
3268 -- This is not needed for library-level finalizers as they are called by
3269 -- the environment task and cannot be aborted.
3271 if VM_Target
= No_VM
and then not For_Package
then
3272 if Abort_Allowed
then
3273 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3276 -- Abort_Id : constant Boolean := <A_Expr>;
3279 Make_Object_Declaration
(Loc
,
3280 Defining_Identifier
=> Data
.Abort_Id
,
3281 Constant_Present
=> True,
3282 Object_Definition
=>
3283 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3285 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3287 -- Abort is not required
3290 -- Generate a dummy entity to ensure that the internal symbols are
3291 -- in sync when a unit is compiled with and without aborts.
3293 Dummy
:= Make_Temporary
(Loc
, 'A');
3294 Data
.Abort_Id
:= Empty
;
3297 -- .NET/JVM or library-level finalizers
3300 Data
.Abort_Id
:= Empty
;
3303 if Exception_Extra_Info
then
3304 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3307 -- E_Id : Exception_Occurrence;
3310 Make_Object_Declaration
(Loc
,
3311 Defining_Identifier
=> Data
.E_Id
,
3312 Object_Definition
=>
3313 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3314 Set_No_Initialization
(Decl
);
3316 Append_To
(Decls
, Decl
);
3323 -- Raised_Id : Boolean := False;
3326 Make_Object_Declaration
(Loc
,
3327 Defining_Identifier
=> Data
.Raised_Id
,
3328 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3329 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3330 end Build_Object_Declarations
;
3332 ---------------------------
3333 -- Build_Raise_Statement --
3334 ---------------------------
3336 function Build_Raise_Statement
3337 (Data
: Finalization_Exception_Data
) return Node_Id
3343 -- Standard run-time and .NET/JVM targets use the specialized routine
3344 -- Raise_From_Controlled_Operation.
3346 if Exception_Extra_Info
3347 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3350 Make_Procedure_Call_Statement
(Data
.Loc
,
3353 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3354 Parameter_Associations
=>
3355 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3357 -- Restricted run-time: exception messages are not supported and hence
3358 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3363 Make_Raise_Program_Error
(Data
.Loc
,
3364 Reason
=> PE_Finalize_Raised_Exception
);
3369 -- Raised_Id and then not Abort_Id
3373 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3375 if Present
(Data
.Abort_Id
) then
3376 Expr
:= Make_And_Then
(Data
.Loc
,
3379 Make_Op_Not
(Data
.Loc
,
3380 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3385 -- if Raised_Id and then not Abort_Id then
3386 -- Raise_From_Controlled_Operation (E_Id);
3388 -- raise Program_Error; -- restricted runtime
3392 Make_If_Statement
(Data
.Loc
,
3394 Then_Statements
=> New_List
(Stmt
));
3395 end Build_Raise_Statement
;
3397 -----------------------------
3398 -- Build_Record_Deep_Procs --
3399 -----------------------------
3401 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3405 (Prim
=> Initialize_Case
,
3407 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3409 if not Is_Limited_View
(Typ
) then
3412 (Prim
=> Adjust_Case
,
3414 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3417 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3418 -- suppressed since these routine will not be used.
3420 if not Restriction_Active
(No_Finalization
) then
3423 (Prim
=> Finalize_Case
,
3425 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3427 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3428 -- .NET do not support address arithmetic and unchecked conversions.
3430 if VM_Target
= No_VM
then
3433 (Prim
=> Address_Case
,
3435 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3438 end Build_Record_Deep_Procs
;
3444 function Cleanup_Array
3447 Typ
: Entity_Id
) return List_Id
3449 Loc
: constant Source_Ptr
:= Sloc
(N
);
3450 Index_List
: constant List_Id
:= New_List
;
3452 function Free_Component
return List_Id
;
3453 -- Generate the code to finalize the task or protected subcomponents
3454 -- of a single component of the array.
3456 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3457 -- Generate a loop over one dimension of the array
3459 --------------------
3460 -- Free_Component --
3461 --------------------
3463 function Free_Component
return List_Id
is
3464 Stmts
: List_Id
:= New_List
;
3466 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3469 -- Component type is known to contain tasks or protected objects
3472 Make_Indexed_Component
(Loc
,
3473 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3474 Expressions
=> Index_List
);
3476 Set_Etype
(Tsk
, C_Typ
);
3478 if Is_Task_Type
(C_Typ
) then
3479 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3481 elsif Is_Simple_Protected_Type
(C_Typ
) then
3482 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3484 elsif Is_Record_Type
(C_Typ
) then
3485 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3487 elsif Is_Array_Type
(C_Typ
) then
3488 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3494 ------------------------
3495 -- Free_One_Dimension --
3496 ------------------------
3498 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3502 if Dim
> Number_Dimensions
(Typ
) then
3503 return Free_Component
;
3505 -- Here we generate the required loop
3508 Index
:= Make_Temporary
(Loc
, 'J');
3509 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3512 Make_Implicit_Loop_Statement
(N
,
3513 Identifier
=> Empty
,
3515 Make_Iteration_Scheme
(Loc
,
3516 Loop_Parameter_Specification
=>
3517 Make_Loop_Parameter_Specification
(Loc
,
3518 Defining_Identifier
=> Index
,
3519 Discrete_Subtype_Definition
=>
3520 Make_Attribute_Reference
(Loc
,
3521 Prefix
=> Duplicate_Subexpr
(Obj
),
3522 Attribute_Name
=> Name_Range
,
3523 Expressions
=> New_List
(
3524 Make_Integer_Literal
(Loc
, Dim
))))),
3525 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3527 end Free_One_Dimension
;
3529 -- Start of processing for Cleanup_Array
3532 return Free_One_Dimension
(1);
3535 --------------------
3536 -- Cleanup_Record --
3537 --------------------
3539 function Cleanup_Record
3542 Typ
: Entity_Id
) return List_Id
3544 Loc
: constant Source_Ptr
:= Sloc
(N
);
3547 Stmts
: constant List_Id
:= New_List
;
3548 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3551 if Has_Discriminants
(U_Typ
)
3552 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3553 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3556 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3558 -- For now, do not attempt to free a component that may appear in a
3559 -- variant, and instead issue a warning. Doing this "properly" would
3560 -- require building a case statement and would be quite a mess. Note
3561 -- that the RM only requires that free "work" for the case of a task
3562 -- access value, so already we go way beyond this in that we deal
3563 -- with the array case and non-discriminated record cases.
3566 ("task/protected object in variant record will not be freed??", N
);
3567 return New_List
(Make_Null_Statement
(Loc
));
3570 Comp
:= First_Component
(Typ
);
3571 while Present
(Comp
) loop
3572 if Has_Task
(Etype
(Comp
))
3573 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3576 Make_Selected_Component
(Loc
,
3577 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3578 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3579 Set_Etype
(Tsk
, Etype
(Comp
));
3581 if Is_Task_Type
(Etype
(Comp
)) then
3582 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3584 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3585 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3587 elsif Is_Record_Type
(Etype
(Comp
)) then
3589 -- Recurse, by generating the prefix of the argument to
3590 -- the eventual cleanup call.
3592 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3594 elsif Is_Array_Type
(Etype
(Comp
)) then
3595 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3599 Next_Component
(Comp
);
3605 ------------------------------
3606 -- Cleanup_Protected_Object --
3607 ------------------------------
3609 function Cleanup_Protected_Object
3611 Ref
: Node_Id
) return Node_Id
3613 Loc
: constant Source_Ptr
:= Sloc
(N
);
3616 -- For restricted run-time libraries (Ravenscar), tasks are
3617 -- non-terminating, and protected objects can only appear at library
3618 -- level, so we do not want finalization of protected objects.
3620 if Restricted_Profile
then
3625 Make_Procedure_Call_Statement
(Loc
,
3627 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3628 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3630 end Cleanup_Protected_Object
;
3636 function Cleanup_Task
3638 Ref
: Node_Id
) return Node_Id
3640 Loc
: constant Source_Ptr
:= Sloc
(N
);
3643 -- For restricted run-time libraries (Ravenscar), tasks are
3644 -- non-terminating and they can only appear at library level, so we do
3645 -- not want finalization of task objects.
3647 if Restricted_Profile
then
3652 Make_Procedure_Call_Statement
(Loc
,
3654 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3655 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3659 ------------------------------
3660 -- Check_Visibly_Controlled --
3661 ------------------------------
3663 procedure Check_Visibly_Controlled
3664 (Prim
: Final_Primitives
;
3666 E
: in out Entity_Id
;
3667 Cref
: in out Node_Id
)
3669 Parent_Type
: Entity_Id
;
3673 if Is_Derived_Type
(Typ
)
3674 and then Comes_From_Source
(E
)
3675 and then not Present
(Overridden_Operation
(E
))
3677 -- We know that the explicit operation on the type does not override
3678 -- the inherited operation of the parent, and that the derivation
3679 -- is from a private type that is not visibly controlled.
3681 Parent_Type
:= Etype
(Typ
);
3682 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3684 if Present
(Op
) then
3687 -- Wrap the object to be initialized into the proper
3688 -- unchecked conversion, to be compatible with the operation
3691 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3692 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3694 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3698 end Check_Visibly_Controlled
;
3700 -------------------------------
3701 -- CW_Or_Has_Controlled_Part --
3702 -------------------------------
3704 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3706 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3707 end CW_Or_Has_Controlled_Part
;
3713 function Convert_View
3716 Ind
: Pos
:= 1) return Node_Id
3718 Fent
: Entity_Id
:= First_Entity
(Proc
);
3723 for J
in 2 .. Ind
loop
3727 Ftyp
:= Etype
(Fent
);
3729 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3730 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3732 Atyp
:= Etype
(Arg
);
3735 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3736 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3739 and then Present
(Atyp
)
3740 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3741 and then Base_Type
(Underlying_Type
(Atyp
)) =
3742 Base_Type
(Underlying_Type
(Ftyp
))
3744 return Unchecked_Convert_To
(Ftyp
, Arg
);
3746 -- If the argument is already a conversion, as generated by
3747 -- Make_Init_Call, set the target type to the type of the formal
3748 -- directly, to avoid spurious typing problems.
3750 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3751 and then not Is_Class_Wide_Type
(Atyp
)
3753 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3754 Set_Etype
(Arg
, Ftyp
);
3757 -- Otherwise, introduce a conversion when the designated object
3758 -- has a type derived from the formal of the controlled routine.
3760 elsif Is_Private_Type
(Ftyp
)
3761 and then Present
(Atyp
)
3762 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
3764 return Unchecked_Convert_To
(Ftyp
, Arg
);
3771 ------------------------
3772 -- Enclosing_Function --
3773 ------------------------
3775 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3776 Func_Id
: Entity_Id
;
3780 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
3781 if Ekind
(Func_Id
) = E_Function
then
3785 Func_Id
:= Scope
(Func_Id
);
3789 end Enclosing_Function
;
3791 -------------------------------
3792 -- Establish_Transient_Scope --
3793 -------------------------------
3795 -- This procedure is called each time a transient block has to be inserted
3796 -- that is to say for each call to a function with unconstrained or tagged
3797 -- result. It creates a new scope on the stack scope in order to enclose
3798 -- all transient variables generated.
3800 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3801 Loc
: constant Source_Ptr
:= Sloc
(N
);
3802 Iter_Loop
: Entity_Id
;
3803 Wrap_Node
: Node_Id
;
3806 -- Do not create a transient scope if we are already inside one
3808 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3809 if Scope_Stack
.Table
(S
).Is_Transient
then
3811 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3816 -- If we encounter Standard there are no enclosing transient scopes
3818 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3823 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3825 -- The context does not contain a node that requires a transient scope,
3828 if No
(Wrap_Node
) then
3831 -- If the node to wrap is an iteration_scheme, the expression is one of
3832 -- the bounds, and the expansion will make an explicit declaration for
3833 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3834 -- transformations here. Same for an Ada 2012 iterator specification,
3835 -- where a block is created for the expression that build the container.
3837 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3838 N_Iterator_Specification
)
3842 -- In formal verification mode, if the node to wrap is a pragma check,
3843 -- this node and enclosed expression are not expanded, so do not apply
3844 -- any transformations here.
3846 elsif GNATprove_Mode
3847 and then Nkind
(Wrap_Node
) = N_Pragma
3848 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3852 -- Create a block entity to act as a transient scope. Note that when the
3853 -- node to be wrapped is an expression or a statement, a real physical
3854 -- block is constructed (see routines Wrap_Transient_Expression and
3855 -- Wrap_Transient_Statement) and inserted into the tree.
3858 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3859 Set_Scope_Is_Transient
;
3861 -- The transient scope must also take care of the secondary stack
3865 Set_Uses_Sec_Stack
(Current_Scope
);
3866 Check_Restriction
(No_Secondary_Stack
, N
);
3868 -- The expansion of iterator loops generates references to objects
3869 -- in order to extract elements from a container:
3871 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3872 -- Obj : <object type> renames Ref.all.Element.all;
3874 -- These references are controlled and returned on the secondary
3875 -- stack. A new reference is created at each iteration of the loop
3876 -- and as a result it must be finalized and the space occupied by
3877 -- it on the secondary stack reclaimed at the end of the current
3880 -- When the context that requires a transient scope is a call to
3881 -- routine Reference, the node to be wrapped is the source object:
3883 -- for Obj of Container loop
3885 -- Routine Wrap_Transient_Declaration however does not generate a
3886 -- physical block as wrapping a declaration will kill it too ealy.
3887 -- To handle this peculiar case, mark the related iterator loop as
3888 -- requiring the secondary stack. This signals the finalization
3889 -- machinery to manage the secondary stack (see routine
3890 -- Process_Statements_For_Controlled_Objects).
3892 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
3894 if Present
(Iter_Loop
) then
3895 Set_Uses_Sec_Stack
(Iter_Loop
);
3899 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3900 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3902 if Debug_Flag_W
then
3903 Write_Str
(" <Transient>");
3907 end Establish_Transient_Scope
;
3909 ----------------------------
3910 -- Expand_Cleanup_Actions --
3911 ----------------------------
3913 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3914 Scop
: constant Entity_Id
:= Current_Scope
;
3916 Is_Asynchronous_Call
: constant Boolean :=
3917 Nkind
(N
) = N_Block_Statement
3918 and then Is_Asynchronous_Call_Block
(N
);
3919 Is_Master
: constant Boolean :=
3920 Nkind
(N
) /= N_Entry_Body
3921 and then Is_Task_Master
(N
);
3922 Is_Protected_Body
: constant Boolean :=
3923 Nkind
(N
) = N_Subprogram_Body
3924 and then Is_Protected_Subprogram_Body
(N
);
3925 Is_Task_Allocation
: constant Boolean :=
3926 Nkind
(N
) = N_Block_Statement
3927 and then Is_Task_Allocation_Block
(N
);
3928 Is_Task_Body
: constant Boolean :=
3929 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3930 Needs_Sec_Stack_Mark
: constant Boolean :=
3931 Uses_Sec_Stack
(Scop
)
3933 not Sec_Stack_Needed_For_Return
(Scop
)
3934 and then VM_Target
= No_VM
;
3935 Needs_Custom_Cleanup
: constant Boolean :=
3936 Nkind
(N
) = N_Block_Statement
3937 and then Present
(Cleanup_Actions
(N
));
3939 Actions_Required
: constant Boolean :=
3940 Requires_Cleanup_Actions
(N
, True)
3941 or else Is_Asynchronous_Call
3943 or else Is_Protected_Body
3944 or else Is_Task_Allocation
3945 or else Is_Task_Body
3946 or else Needs_Sec_Stack_Mark
3947 or else Needs_Custom_Cleanup
;
3949 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3953 procedure Wrap_HSS_In_Block
;
3954 -- Move HSS inside a new block along with the original exception
3955 -- handlers. Make the newly generated block the sole statement of HSS.
3957 -----------------------
3958 -- Wrap_HSS_In_Block --
3959 -----------------------
3961 procedure Wrap_HSS_In_Block
is
3963 Block_Id
: Entity_Id
;
3967 -- Preserve end label to provide proper cross-reference information
3969 End_Lab
:= End_Label
(HSS
);
3971 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3973 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
3974 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
3975 Set_Etype
(Block_Id
, Standard_Void_Type
);
3976 Set_Block_Node
(Block_Id
, Identifier
(Block
));
3978 -- Signal the finalization machinery that this particular block
3979 -- contains the original context.
3981 Set_Is_Finalization_Wrapper
(Block
);
3983 Set_Handled_Statement_Sequence
(N
,
3984 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3985 HSS
:= Handled_Statement_Sequence
(N
);
3987 Set_First_Real_Statement
(HSS
, Block
);
3988 Set_End_Label
(HSS
, End_Lab
);
3990 -- Comment needed here, see RH for 1.306 ???
3992 if Nkind
(N
) = N_Subprogram_Body
then
3993 Set_Has_Nested_Block_With_Handler
(Scop
);
3995 end Wrap_HSS_In_Block
;
3997 -- Start of processing for Expand_Cleanup_Actions
4000 -- The current construct does not need any form of servicing
4002 if not Actions_Required
then
4005 -- If the current node is a rewritten task body and the descriptors have
4006 -- not been delayed (due to some nested instantiations), do not generate
4007 -- redundant cleanup actions.
4010 and then Nkind
(N
) = N_Subprogram_Body
4011 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4016 if Needs_Custom_Cleanup
then
4017 Cln
:= Cleanup_Actions
(N
);
4023 Decls
: List_Id
:= Declarations
(N
);
4025 Mark
: Entity_Id
:= Empty
;
4026 New_Decls
: List_Id
;
4030 -- If we are generating expanded code for debugging purposes, use the
4031 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4032 -- be updated subsequently to reference the proper line in .dg files.
4033 -- If we are not debugging generated code, use No_Location instead,
4034 -- so that no debug information is generated for the cleanup code.
4035 -- This makes the behavior of the NEXT command in GDB monotonic, and
4036 -- makes the placement of breakpoints more accurate.
4038 if Debug_Generated_Code
then
4044 -- Set polling off. The finalization and cleanup code is executed
4045 -- with aborts deferred.
4047 Old_Poll
:= Polling_Required
;
4048 Polling_Required
:= False;
4050 -- A task activation call has already been built for a task
4051 -- allocation block.
4053 if not Is_Task_Allocation
then
4054 Build_Task_Activation_Call
(N
);
4058 Establish_Task_Master
(N
);
4061 New_Decls
:= New_List
;
4063 -- If secondary stack is in use, generate:
4065 -- Mnn : constant Mark_Id := SS_Mark;
4067 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
4068 -- secondary stack is never used on a VM.
4070 if Needs_Sec_Stack_Mark
then
4071 Mark
:= Make_Temporary
(Loc
, 'M');
4073 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4074 Set_Uses_Sec_Stack
(Scop
, False);
4077 -- If exception handlers are present, wrap the sequence of statements
4078 -- in a block since it is not possible to have exception handlers and
4079 -- an At_End handler in the same construct.
4081 if Present
(Exception_Handlers
(HSS
)) then
4084 -- Ensure that the First_Real_Statement field is set
4086 elsif No
(First_Real_Statement
(HSS
)) then
4087 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4090 -- Do not move the Activation_Chain declaration in the context of
4091 -- task allocation blocks. Task allocation blocks use _chain in their
4092 -- cleanup handlers and gigi complains if it is declared in the
4093 -- sequence of statements of the scope that declares the handler.
4095 if Is_Task_Allocation
then
4097 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4101 Decl
:= First
(Decls
);
4102 while Nkind
(Decl
) /= N_Object_Declaration
4103 or else Defining_Identifier
(Decl
) /= Chain
4107 -- A task allocation block should always include a _chain
4110 pragma Assert
(Present
(Decl
));
4114 Prepend_To
(New_Decls
, Decl
);
4118 -- Ensure the presence of a declaration list in order to successfully
4119 -- append all original statements to it.
4122 Set_Declarations
(N
, New_List
);
4123 Decls
:= Declarations
(N
);
4126 -- Move the declarations into the sequence of statements in order to
4127 -- have them protected by the At_End handler. It may seem weird to
4128 -- put declarations in the sequence of statement but in fact nothing
4129 -- forbids that at the tree level.
4131 Append_List_To
(Decls
, Statements
(HSS
));
4132 Set_Statements
(HSS
, Decls
);
4134 -- Reset the Sloc of the handled statement sequence to properly
4135 -- reflect the new initial "statement" in the sequence.
4137 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4139 -- The declarations of finalizer spec and auxiliary variables replace
4140 -- the old declarations that have been moved inward.
4142 Set_Declarations
(N
, New_Decls
);
4143 Analyze_Declarations
(New_Decls
);
4145 -- Generate finalization calls for all controlled objects appearing
4146 -- in the statements of N. Add context specific cleanup for various
4151 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4153 Top_Decls
=> New_Decls
,
4154 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4158 if Present
(Fin_Id
) then
4159 Build_Finalizer_Call
(N
, Fin_Id
);
4162 -- Restore saved polling mode
4164 Polling_Required
:= Old_Poll
;
4166 end Expand_Cleanup_Actions
;
4168 ---------------------------
4169 -- Expand_N_Package_Body --
4170 ---------------------------
4172 -- Add call to Activate_Tasks if body is an activator (actual processing
4173 -- is in chapter 9).
4175 -- Generate subprogram descriptor for elaboration routine
4177 -- Encode entity names in package body
4179 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4180 GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4181 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
4185 -- The package body may be subject to pragma Ghost with policy Ignore.
4186 -- Set the mode now to ensure that any nodes generated during expansion
4187 -- are properly flagged as ignored Ghost.
4191 -- This is done only for non-generic packages
4193 if Ekind
(Spec_Ent
) = E_Package
then
4194 Push_Scope
(Corresponding_Spec
(N
));
4196 -- Build dispatch tables of library level tagged types
4198 if Tagged_Type_Expansion
4199 and then Is_Library_Level_Entity
(Spec_Ent
)
4201 Build_Static_Dispatch_Tables
(N
);
4204 Build_Task_Activation_Call
(N
);
4206 -- When the package is subject to pragma Initial_Condition, the
4207 -- assertion expression must be verified at the end of the body
4210 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
4211 Expand_Pragma_Initial_Condition
(N
);
4217 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4218 Set_In_Package_Body
(Spec_Ent
, False);
4220 -- Set to encode entity names in package body before gigi is called
4222 Qualify_Entity_Names
(N
);
4224 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
4227 Clean_Stmts
=> No_List
,
4229 Top_Decls
=> No_List
,
4230 Defer_Abort
=> False,
4233 if Present
(Fin_Id
) then
4235 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4238 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4239 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4242 Set_Finalizer
(Body_Ent
, Fin_Id
);
4247 -- Restore the original Ghost mode once analysis and expansion have
4251 end Expand_N_Package_Body
;
4253 ----------------------------------
4254 -- Expand_N_Package_Declaration --
4255 ----------------------------------
4257 -- Add call to Activate_Tasks if there are tasks declared and the package
4258 -- has no body. Note that in Ada 83 this may result in premature activation
4259 -- of some tasks, given that we cannot tell whether a body will eventually
4262 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4263 GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4264 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4265 Spec
: constant Node_Id
:= Specification
(N
);
4269 No_Body
: Boolean := False;
4270 -- True in the case of a package declaration that is a compilation
4271 -- unit and for which no associated body will be compiled in this
4275 -- Case of a package declaration other than a compilation unit
4277 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4280 -- Case of a compilation unit that does not require a body
4282 elsif not Body_Required
(Parent
(N
))
4283 and then not Unit_Requires_Body
(Id
)
4287 -- Special case of generating calling stubs for a remote call interface
4288 -- package: even though the package declaration requires one, the body
4289 -- won't be processed in this compilation (so any stubs for RACWs
4290 -- declared in the package must be generated here, along with the spec).
4292 elsif Parent
(N
) = Cunit
(Main_Unit
)
4293 and then Is_Remote_Call_Interface
(Id
)
4294 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4299 -- For a nested instance, delay processing until freeze point
4301 if Has_Delayed_Freeze
(Id
)
4302 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4307 -- The package declaration may be subject to pragma Ghost with policy
4308 -- Ignore. Set the mode now to ensure that any nodes generated during
4309 -- expansion are properly flagged as ignored Ghost.
4313 -- For a package declaration that implies no associated body, generate
4314 -- task activation call and RACW supporting bodies now (since we won't
4315 -- have a specific separate compilation unit for that).
4320 -- Generate RACW subprogram bodies
4322 if Has_RACW
(Id
) then
4323 Decls
:= Private_Declarations
(Spec
);
4326 Decls
:= Visible_Declarations
(Spec
);
4331 Set_Visible_Declarations
(Spec
, Decls
);
4334 Append_RACW_Bodies
(Decls
, Id
);
4335 Analyze_List
(Decls
);
4338 -- Generate task activation call as last step of elaboration
4340 if Present
(Activation_Chain_Entity
(N
)) then
4341 Build_Task_Activation_Call
(N
);
4344 -- When the package is subject to pragma Initial_Condition and lacks
4345 -- a body, the assertion expression must be verified at the end of
4346 -- the visible declarations. Otherwise the check is performed at the
4347 -- end of the body statements (see Expand_N_Package_Body).
4349 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4350 Expand_Pragma_Initial_Condition
(N
);
4356 -- Build dispatch tables of library level tagged types
4358 if Tagged_Type_Expansion
4359 and then (Is_Compilation_Unit
(Id
)
4360 or else (Is_Generic_Instance
(Id
)
4361 and then Is_Library_Level_Entity
(Id
)))
4363 Build_Static_Dispatch_Tables
(N
);
4366 -- Note: it is not necessary to worry about generating a subprogram
4367 -- descriptor, since the only way to get exception handlers into a
4368 -- package spec is to include instantiations, and that would cause
4369 -- generation of subprogram descriptors to be delayed in any case.
4371 -- Set to encode entity names in package spec before gigi is called
4373 Qualify_Entity_Names
(N
);
4375 if Ekind
(Id
) /= E_Generic_Package
then
4378 Clean_Stmts
=> No_List
,
4380 Top_Decls
=> No_List
,
4381 Defer_Abort
=> False,
4384 Set_Finalizer
(Id
, Fin_Id
);
4387 -- Restore the original Ghost mode once analysis and expansion have
4391 end Expand_N_Package_Declaration
;
4393 -----------------------------
4394 -- Find_Node_To_Be_Wrapped --
4395 -----------------------------
4397 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4399 The_Parent
: Node_Id
;
4405 case Nkind
(The_Parent
) is
4407 -- Simple statement can be wrapped
4412 -- Usually assignments are good candidate for wrapping except
4413 -- when they have been generated as part of a controlled aggregate
4414 -- where the wrapping should take place more globally. Note that
4415 -- No_Ctrl_Actions may be set also for non-controlled assignements
4416 -- in order to disable the use of dispatching _assign, so we need
4417 -- to test explicitly for a controlled type here.
4419 when N_Assignment_Statement
=>
4420 if No_Ctrl_Actions
(The_Parent
)
4421 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4428 -- An entry call statement is a special case if it occurs in the
4429 -- context of a Timed_Entry_Call. In this case we wrap the entire
4430 -- timed entry call.
4432 when N_Entry_Call_Statement |
4433 N_Procedure_Call_Statement
=>
4434 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4435 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4437 N_Conditional_Entry_Call
)
4439 return Parent
(Parent
(The_Parent
));
4444 -- Object declarations are also a boundary for the transient scope
4445 -- even if they are not really wrapped. For further details, see
4446 -- Wrap_Transient_Declaration.
4448 when N_Object_Declaration |
4449 N_Object_Renaming_Declaration |
4450 N_Subtype_Declaration
=>
4453 -- The expression itself is to be wrapped if its parent is a
4454 -- compound statement or any other statement where the expression
4455 -- is known to be scalar.
4457 when N_Accept_Alternative |
4458 N_Attribute_Definition_Clause |
4461 N_Delay_Alternative |
4462 N_Delay_Until_Statement |
4463 N_Delay_Relative_Statement |
4464 N_Discriminant_Association |
4466 N_Entry_Body_Formal_Part |
4469 N_Iteration_Scheme |
4470 N_Terminate_Alternative
=>
4471 pragma Assert
(Present
(P
));
4474 when N_Attribute_Reference
=>
4476 if Is_Procedure_Attribute_Name
4477 (Attribute_Name
(The_Parent
))
4482 -- A raise statement can be wrapped. This will arise when the
4483 -- expression in a raise_with_expression uses the secondary
4484 -- stack, for example.
4486 when N_Raise_Statement
=>
4489 -- If the expression is within the iteration scheme of a loop,
4490 -- we must create a declaration for it, followed by an assignment
4491 -- in order to have a usable statement to wrap.
4493 when N_Loop_Parameter_Specification
=>
4494 return Parent
(The_Parent
);
4496 -- The following nodes contains "dummy calls" which don't need to
4499 when N_Parameter_Specification |
4500 N_Discriminant_Specification |
4501 N_Component_Declaration
=>
4504 -- The return statement is not to be wrapped when the function
4505 -- itself needs wrapping at the outer-level
4507 when N_Simple_Return_Statement
=>
4509 Applies_To
: constant Entity_Id
:=
4511 (Return_Statement_Entity
(The_Parent
));
4512 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4514 if Requires_Transient_Scope
(Return_Type
) then
4521 -- If we leave a scope without having been able to find a node to
4522 -- wrap, something is going wrong but this can happen in error
4523 -- situation that are not detected yet (such as a dynamic string
4524 -- in a pragma export)
4526 when N_Subprogram_Body |
4527 N_Package_Declaration |
4529 N_Block_Statement
=>
4532 -- Otherwise continue the search
4539 The_Parent
:= Parent
(P
);
4541 end Find_Node_To_Be_Wrapped
;
4543 ----------------------------------
4544 -- Has_New_Controlled_Component --
4545 ----------------------------------
4547 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4551 if not Is_Tagged_Type
(E
) then
4552 return Has_Controlled_Component
(E
);
4553 elsif not Is_Derived_Type
(E
) then
4554 return Has_Controlled_Component
(E
);
4557 Comp
:= First_Component
(E
);
4558 while Present
(Comp
) loop
4559 if Chars
(Comp
) = Name_uParent
then
4562 elsif Scope
(Original_Record_Component
(Comp
)) = E
4563 and then Needs_Finalization
(Etype
(Comp
))
4568 Next_Component
(Comp
);
4572 end Has_New_Controlled_Component
;
4574 ---------------------------------
4575 -- Has_Simple_Protected_Object --
4576 ---------------------------------
4578 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4580 if Has_Task
(T
) then
4583 elsif Is_Simple_Protected_Type
(T
) then
4586 elsif Is_Array_Type
(T
) then
4587 return Has_Simple_Protected_Object
(Component_Type
(T
));
4589 elsif Is_Record_Type
(T
) then
4594 Comp
:= First_Component
(T
);
4595 while Present
(Comp
) loop
4596 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4600 Next_Component
(Comp
);
4609 end Has_Simple_Protected_Object
;
4611 ------------------------------------
4612 -- Insert_Actions_In_Scope_Around --
4613 ------------------------------------
4615 procedure Insert_Actions_In_Scope_Around
4618 Manage_SS
: Boolean)
4620 Act_Before
: constant List_Id
:=
4621 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4622 Act_After
: constant List_Id
:=
4623 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4624 Act_Cleanup
: constant List_Id
:=
4625 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4626 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4627 -- Last), but this was incorrect as Process_Transient_Object may
4628 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4630 procedure Process_Transient_Objects
4631 (First_Object
: Node_Id
;
4632 Last_Object
: Node_Id
;
4633 Related_Node
: Node_Id
);
4634 -- First_Object and Last_Object define a list which contains potential
4635 -- controlled transient objects. Finalization flags are inserted before
4636 -- First_Object and finalization calls are inserted after Last_Object.
4637 -- Related_Node is the node for which transient objects have been
4640 -------------------------------
4641 -- Process_Transient_Objects --
4642 -------------------------------
4644 procedure Process_Transient_Objects
4645 (First_Object
: Node_Id
;
4646 Last_Object
: Node_Id
;
4647 Related_Node
: Node_Id
)
4649 Must_Hook
: Boolean := False;
4650 -- Flag denoting whether the context requires transient variable
4651 -- export to the outer finalizer.
4653 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4654 -- Determine whether an arbitrary node denotes a subprogram call
4656 procedure Detect_Subprogram_Call
is
4657 new Traverse_Proc
(Is_Subprogram_Call
);
4659 ------------------------
4660 -- Is_Subprogram_Call --
4661 ------------------------
4663 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4665 -- Complex constructs are factored out by the expander and their
4666 -- occurrences are replaced with references to temporaries or
4667 -- object renamings. Due to this expansion activity, inspect the
4668 -- original tree to detect subprogram calls.
4670 if Nkind_In
(N
, N_Identifier
,
4671 N_Object_Renaming_Declaration
)
4672 and then Original_Node
(N
) /= N
4674 Detect_Subprogram_Call
(Original_Node
(N
));
4676 -- The original construct contains a subprogram call, there is
4677 -- no point in continuing the tree traversal.
4685 -- The original construct contains a subprogram call, there is no
4686 -- point in continuing the tree traversal.
4688 elsif Nkind
(N
) = N_Object_Declaration
4689 and then Present
(Expression
(N
))
4690 and then Nkind
(Original_Node
(Expression
(N
))) = N_Function_Call
4695 -- A regular procedure or function call
4697 elsif Nkind
(N
) in N_Subprogram_Call
then
4706 end Is_Subprogram_Call
;
4710 Built
: Boolean := False;
4711 Desig_Typ
: Entity_Id
;
4713 Fin_Block
: Node_Id
;
4714 Fin_Data
: Finalization_Exception_Data
;
4715 Fin_Decls
: List_Id
;
4716 Fin_Insrt
: Node_Id
;
4717 Last_Fin
: Node_Id
:= Empty
;
4721 Obj_Typ
: Entity_Id
;
4722 Prev_Fin
: Node_Id
:= Empty
;
4726 Temp_Id
: Entity_Id
;
4729 -- Start of processing for Process_Transient_Objects
4732 -- Recognize a scenario where the transient context is an object
4733 -- declaration initialized by a build-in-place function call:
4735 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4737 -- The rough expansion of the above is:
4739 -- Temp : ... := Ctrl_Func_Call;
4741 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4743 -- The finalization of any controlled transient must happen after
4744 -- the build-in-place function call is executed.
4746 if Nkind
(N
) = N_Object_Declaration
4747 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
4750 Fin_Insrt
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
4752 -- Search the context for at least one subprogram call. If found, the
4753 -- machinery exports all transient objects to the enclosing finalizer
4754 -- due to the possibility of abnormal call termination.
4757 Detect_Subprogram_Call
(N
);
4758 Fin_Insrt
:= Last_Object
;
4761 -- Examine all objects in the list First_Object .. Last_Object
4763 Stmt
:= First_Object
;
4764 while Present
(Stmt
) loop
4765 if Nkind
(Stmt
) = N_Object_Declaration
4766 and then Analyzed
(Stmt
)
4767 and then Is_Finalizable_Transient
(Stmt
, N
)
4769 -- Do not process the node to be wrapped since it will be
4770 -- handled by the enclosing finalizer.
4772 and then Stmt
/= Related_Node
4775 Obj_Id
:= Defining_Identifier
(Stmt
);
4776 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4777 Desig_Typ
:= Obj_Typ
;
4779 Set_Is_Processed_Transient
(Obj_Id
);
4781 -- Handle access types
4783 if Is_Access_Type
(Desig_Typ
) then
4784 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4787 -- Create the necessary entities and declarations the first
4792 Fin_Decls
:= New_List
;
4794 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4797 -- Transient variables associated with subprogram calls need
4798 -- extra processing. These variables are usually created right
4799 -- before the call and finalized immediately after the call.
4800 -- If an exception occurs during the call, the clean up code
4801 -- is skipped due to the sudden change in control and the
4802 -- transient is never finalized.
4804 -- To handle this case, such variables are "exported" to the
4805 -- enclosing sequence of statements where their corresponding
4806 -- "hooks" are picked up by the finalization machinery.
4810 -- Step 1: Create an access type which provides a reference
4811 -- to the transient object. Generate:
4813 -- Ann : access [all] <Desig_Typ>;
4815 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4817 Insert_Action
(Stmt
,
4818 Make_Full_Type_Declaration
(Loc
,
4819 Defining_Identifier
=> Ptr_Id
,
4821 Make_Access_To_Object_Definition
(Loc
,
4823 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4824 Subtype_Indication
=>
4825 New_Occurrence_Of
(Desig_Typ
, Loc
))));
4827 -- Step 2: Create a temporary which acts as a hook to the
4828 -- transient object. Generate:
4830 -- Temp : Ptr_Id := null;
4832 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4834 Insert_Action
(Stmt
,
4835 Make_Object_Declaration
(Loc
,
4836 Defining_Identifier
=> Temp_Id
,
4837 Object_Definition
=>
4838 New_Occurrence_Of
(Ptr_Id
, Loc
)));
4840 -- Mark the temporary as a transient hook. This signals the
4841 -- machinery in Build_Finalizer to recognize this special
4844 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4846 -- Step 3: Hook the transient object to the temporary
4848 if Is_Access_Type
(Obj_Typ
) then
4850 Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
4853 Make_Attribute_Reference
(Loc
,
4854 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
4855 Attribute_Name
=> Name_Unrestricted_Access
);
4859 -- Temp := Ptr_Id (Obj_Id);
4861 -- Temp := Obj_Id'Unrestricted_Access;
4863 -- When the transient object is initialized by an aggregate,
4864 -- the hook must capture the object after the last component
4865 -- assignment takes place. Only then is the object fully
4868 if Ekind
(Obj_Id
) = E_Variable
4869 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
4871 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
4873 -- Otherwise the hook seizes the related object immediately
4879 Insert_After_And_Analyze
(Temp_Ins
,
4880 Make_Assignment_Statement
(Loc
,
4881 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4882 Expression
=> Expr
));
4887 -- The transient object is about to be finalized by the clean
4888 -- up code following the subprogram call. In order to avoid
4889 -- double finalization, clear the hook.
4896 Make_Assignment_Statement
(Loc
,
4897 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4898 Expression
=> Make_Null
(Loc
)));
4902 -- [Deep_]Finalize (Obj_Ref);
4904 -- Set type of dereference, so that proper conversion are
4905 -- generated when operation is inherited.
4907 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
4909 if Is_Access_Type
(Obj_Typ
) then
4910 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4911 Set_Etype
(Obj_Ref
, Directly_Designated_Type
(Obj_Typ
));
4915 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4920 -- [Deep_]Finalize (Obj_Ref);
4924 -- if not Raised then
4927 -- (Enn, Get_Current_Excep.all.all);
4932 Make_Block_Statement
(Loc
,
4933 Handled_Statement_Sequence
=>
4934 Make_Handled_Sequence_Of_Statements
(Loc
,
4935 Statements
=> Stmts
,
4936 Exception_Handlers
=> New_List
(
4937 Build_Exception_Handler
(Fin_Data
))));
4939 -- The single raise statement must be inserted after all the
4940 -- finalization blocks, and we put everything into a wrapper
4941 -- block to clearly expose the construct to the back-end.
4943 if Present
(Prev_Fin
) then
4944 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4946 Insert_After_And_Analyze
(Fin_Insrt
,
4947 Make_Block_Statement
(Loc
,
4948 Declarations
=> Fin_Decls
,
4949 Handled_Statement_Sequence
=>
4950 Make_Handled_Sequence_Of_Statements
(Loc
,
4951 Statements
=> New_List
(Fin_Block
))));
4953 Last_Fin
:= Fin_Block
;
4956 Prev_Fin
:= Fin_Block
;
4959 -- Terminate the scan after the last object has been processed to
4960 -- avoid touching unrelated code.
4962 if Stmt
= Last_Object
then
4970 if Present
(Prev_Fin
) then
4971 Insert_List_Before_And_Analyze
(Prev_Fin
, Act_Cleanup
);
4973 Insert_List_After_And_Analyze
(Fin_Insrt
, Act_Cleanup
);
4978 -- if Raised and then not Abort then
4979 -- Raise_From_Controlled_Operation (E);
4982 if Built
and then Present
(Last_Fin
) then
4983 Insert_After_And_Analyze
(Last_Fin
,
4984 Build_Raise_Statement
(Fin_Data
));
4986 end Process_Transient_Objects
;
4990 Loc
: constant Source_Ptr
:= Sloc
(N
);
4991 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4992 First_Obj
: Node_Id
;
4994 Mark_Id
: Entity_Id
;
4997 -- Start of processing for Insert_Actions_In_Scope_Around
5000 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
5004 -- If the node to be wrapped is the trigger of an asynchronous select,
5005 -- it is not part of a statement list. The actions must be inserted
5006 -- before the select itself, which is part of some list of statements.
5007 -- Note that the triggering alternative includes the triggering
5008 -- statement and an optional statement list. If the node to be
5009 -- wrapped is part of that list, the normal insertion applies.
5011 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5012 and then not Is_List_Member
(Node_To_Wrap
)
5014 Target
:= Parent
(Parent
(Node_To_Wrap
));
5019 First_Obj
:= Target
;
5022 -- Add all actions associated with a transient scope into the main tree.
5023 -- There are several scenarios here:
5025 -- +--- Before ----+ +----- After ---+
5026 -- 1) First_Obj ....... Target ........ Last_Obj
5028 -- 2) First_Obj ....... Target
5030 -- 3) Target ........ Last_Obj
5032 -- Flag declarations are inserted before the first object
5034 if Present
(Act_Before
) then
5035 First_Obj
:= First
(Act_Before
);
5036 Insert_List_Before
(Target
, Act_Before
);
5039 -- Finalization calls are inserted after the last object
5041 if Present
(Act_After
) then
5042 Last_Obj
:= Last
(Act_After
);
5043 Insert_List_After
(Target
, Act_After
);
5046 -- Mark and release the secondary stack when the context warrants it
5049 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5052 -- Mnn : constant Mark_Id := SS_Mark;
5054 Insert_Before_And_Analyze
5055 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5058 -- SS_Release (Mnn);
5060 Insert_After_And_Analyze
5061 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5064 -- Check for transient controlled objects associated with Target and
5065 -- generate the appropriate finalization actions for them.
5067 Process_Transient_Objects
5068 (First_Object
=> First_Obj
,
5069 Last_Object
=> Last_Obj
,
5070 Related_Node
=> Target
);
5072 -- Reset the action lists
5075 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5077 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5081 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5083 end Insert_Actions_In_Scope_Around
;
5085 ------------------------------
5086 -- Is_Simple_Protected_Type --
5087 ------------------------------
5089 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5092 Is_Protected_Type
(T
)
5093 and then not Uses_Lock_Free
(T
)
5094 and then not Has_Entries
(T
)
5095 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5096 end Is_Simple_Protected_Type
;
5098 -----------------------
5099 -- Make_Adjust_Call --
5100 -----------------------
5102 function Make_Adjust_Call
5105 Skip_Self
: Boolean := False) return Node_Id
5107 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5108 Adj_Id
: Entity_Id
:= Empty
;
5109 Ref
: Node_Id
:= Obj_Ref
;
5113 -- Recover the proper type which contains Deep_Adjust
5115 if Is_Class_Wide_Type
(Typ
) then
5116 Utyp
:= Root_Type
(Typ
);
5121 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5122 Set_Assignment_OK
(Ref
);
5124 -- Deal with untagged derivation of private views
5126 if Is_Untagged_Derivation
(Typ
) then
5127 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5128 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5129 Set_Assignment_OK
(Ref
);
5132 -- When dealing with the completion of a private type, use the base
5135 if Utyp
/= Base_Type
(Utyp
) then
5136 pragma Assert
(Is_Private_Type
(Typ
));
5138 Utyp
:= Base_Type
(Utyp
);
5139 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5143 if Has_Controlled_Component
(Utyp
) then
5144 if Is_Tagged_Type
(Utyp
) then
5145 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5147 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5151 -- Class-wide types, interfaces and types with controlled components
5153 elsif Is_Class_Wide_Type
(Typ
)
5154 or else Is_Interface
(Typ
)
5155 or else Has_Controlled_Component
(Utyp
)
5157 if Is_Tagged_Type
(Utyp
) then
5158 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5160 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5163 -- Derivations from [Limited_]Controlled
5165 elsif Is_Controlled
(Utyp
) then
5166 if Has_Controlled_Component
(Utyp
) then
5167 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5169 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5174 elsif Is_Tagged_Type
(Utyp
) then
5175 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5178 raise Program_Error
;
5181 if Present
(Adj_Id
) then
5183 -- If the object is unanalyzed, set its expected type for use in
5184 -- Convert_View in case an additional conversion is needed.
5187 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5189 Set_Etype
(Ref
, Typ
);
5192 -- The object reference may need another conversion depending on the
5193 -- type of the formal and that of the actual.
5195 if not Is_Class_Wide_Type
(Typ
) then
5196 Ref
:= Convert_View
(Adj_Id
, Ref
);
5202 Param
=> New_Copy_Tree
(Ref
),
5203 Skip_Self
=> Skip_Self
);
5207 end Make_Adjust_Call
;
5209 ----------------------
5210 -- Make_Attach_Call --
5211 ----------------------
5213 function Make_Attach_Call
5215 Ptr_Typ
: Entity_Id
) return Node_Id
5217 pragma Assert
(VM_Target
/= No_VM
);
5219 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5222 Make_Procedure_Call_Statement
(Loc
,
5224 New_Occurrence_Of
(RTE
(RE_Attach
), Loc
),
5225 Parameter_Associations
=> New_List
(
5226 New_Occurrence_Of
(Finalization_Master
(Ptr_Typ
), Loc
),
5227 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5228 end Make_Attach_Call
;
5230 ----------------------
5231 -- Make_Detach_Call --
5232 ----------------------
5234 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5235 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5239 Make_Procedure_Call_Statement
(Loc
,
5241 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5242 Parameter_Associations
=> New_List
(
5243 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5244 end Make_Detach_Call
;
5252 Proc_Id
: Entity_Id
;
5254 Skip_Self
: Boolean := False) return Node_Id
5256 Params
: constant List_Id
:= New_List
(Param
);
5259 -- Do not apply the controlled action to the object itself by signaling
5260 -- the related routine to avoid self.
5263 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5267 Make_Procedure_Call_Statement
(Loc
,
5268 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5269 Parameter_Associations
=> Params
);
5272 --------------------------
5273 -- Make_Deep_Array_Body --
5274 --------------------------
5276 function Make_Deep_Array_Body
5277 (Prim
: Final_Primitives
;
5278 Typ
: Entity_Id
) return List_Id
5280 function Build_Adjust_Or_Finalize_Statements
5281 (Typ
: Entity_Id
) return List_Id
;
5282 -- Create the statements necessary to adjust or finalize an array of
5283 -- controlled elements. Generate:
5286 -- Abort : constant Boolean := Triggered_By_Abort;
5288 -- Abort : constant Boolean := False; -- no abort
5290 -- E : Exception_Occurrence;
5291 -- Raised : Boolean := False;
5294 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5295 -- ^-- in the finalization case
5297 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5299 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5303 -- if not Raised then
5305 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5312 -- if Raised and then not Abort then
5313 -- Raise_From_Controlled_Operation (E);
5317 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5318 -- Create the statements necessary to initialize an array of controlled
5319 -- elements. Include a mechanism to carry out partial finalization if an
5320 -- exception occurs. Generate:
5323 -- Counter : Integer := 0;
5326 -- for J1 in V'Range (1) loop
5328 -- for JN in V'Range (N) loop
5330 -- [Deep_]Initialize (V (J1, ..., JN));
5332 -- Counter := Counter + 1;
5337 -- Abort : constant Boolean := Triggered_By_Abort;
5339 -- Abort : constant Boolean := False; -- no abort
5340 -- E : Exception_Occurence;
5341 -- Raised : Boolean := False;
5348 -- V'Length (N) - Counter;
5350 -- for F1 in reverse V'Range (1) loop
5352 -- for FN in reverse V'Range (N) loop
5353 -- if Counter > 0 then
5354 -- Counter := Counter - 1;
5357 -- [Deep_]Finalize (V (F1, ..., FN));
5361 -- if not Raised then
5363 -- Save_Occurrence (E,
5364 -- Get_Current_Excep.all.all);
5373 -- if Raised and then not Abort then
5374 -- Raise_From_Controlled_Operation (E);
5383 function New_References_To
5385 Loc
: Source_Ptr
) return List_Id
;
5386 -- Given a list of defining identifiers, return a list of references to
5387 -- the original identifiers, in the same order as they appear.
5389 -----------------------------------------
5390 -- Build_Adjust_Or_Finalize_Statements --
5391 -----------------------------------------
5393 function Build_Adjust_Or_Finalize_Statements
5394 (Typ
: Entity_Id
) return List_Id
5396 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5397 Index_List
: constant List_Id
:= New_List
;
5398 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5399 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5400 Finalizer_Decls
: List_Id
:= No_List
;
5401 Finalizer_Data
: Finalization_Exception_Data
;
5404 Core_Loop
: Node_Id
;
5407 Loop_Id
: Entity_Id
;
5410 Exceptions_OK
: constant Boolean :=
5411 not Restriction_Active
(No_Exception_Propagation
);
5413 procedure Build_Indexes
;
5414 -- Generate the indexes used in the dimension loops
5420 procedure Build_Indexes
is
5422 -- Generate the following identifiers:
5423 -- Jnn - for initialization
5425 for Dim
in 1 .. Num_Dims
loop
5426 Append_To
(Index_List
,
5427 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5431 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5434 Finalizer_Decls
:= New_List
;
5437 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5440 Make_Indexed_Component
(Loc
,
5441 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5442 Expressions
=> New_References_To
(Index_List
, Loc
));
5443 Set_Etype
(Comp_Ref
, Comp_Typ
);
5446 -- [Deep_]Adjust (V (J1, ..., JN))
5448 if Prim
= Adjust_Case
then
5449 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5452 -- [Deep_]Finalize (V (J1, ..., JN))
5454 else pragma Assert
(Prim
= Finalize_Case
);
5455 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5458 -- Generate the block which houses the adjust or finalize call:
5460 -- <adjust or finalize call>; -- No_Exception_Propagation
5462 -- begin -- Exception handlers allowed
5463 -- <adjust or finalize call>
5467 -- if not Raised then
5469 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5473 if Exceptions_OK
then
5475 Make_Block_Statement
(Loc
,
5476 Handled_Statement_Sequence
=>
5477 Make_Handled_Sequence_Of_Statements
(Loc
,
5478 Statements
=> New_List
(Call
),
5479 Exception_Handlers
=> New_List
(
5480 Build_Exception_Handler
(Finalizer_Data
))));
5485 -- Generate the dimension loops starting from the innermost one
5487 -- for Jnn in [reverse] V'Range (Dim) loop
5491 J
:= Last
(Index_List
);
5493 while Present
(J
) and then Dim
> 0 loop
5499 Make_Loop_Statement
(Loc
,
5501 Make_Iteration_Scheme
(Loc
,
5502 Loop_Parameter_Specification
=>
5503 Make_Loop_Parameter_Specification
(Loc
,
5504 Defining_Identifier
=> Loop_Id
,
5505 Discrete_Subtype_Definition
=>
5506 Make_Attribute_Reference
(Loc
,
5507 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5508 Attribute_Name
=> Name_Range
,
5509 Expressions
=> New_List
(
5510 Make_Integer_Literal
(Loc
, Dim
))),
5512 Reverse_Present
=> Prim
= Finalize_Case
)),
5514 Statements
=> New_List
(Core_Loop
),
5515 End_Label
=> Empty
);
5520 -- Generate the block which contains the core loop, the declarations
5521 -- of the abort flag, the exception occurrence, the raised flag and
5522 -- the conditional raise:
5525 -- Abort : constant Boolean := Triggered_By_Abort;
5527 -- Abort : constant Boolean := False; -- no abort
5529 -- E : Exception_Occurrence;
5530 -- Raised : Boolean := False;
5535 -- if Raised and then not Abort then -- Expection handlers OK
5536 -- Raise_From_Controlled_Operation (E);
5540 Stmts
:= New_List
(Core_Loop
);
5542 if Exceptions_OK
then
5544 Build_Raise_Statement
(Finalizer_Data
));
5549 Make_Block_Statement
(Loc
,
5552 Handled_Statement_Sequence
=>
5553 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5554 end Build_Adjust_Or_Finalize_Statements
;
5556 ---------------------------------
5557 -- Build_Initialize_Statements --
5558 ---------------------------------
5560 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5561 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5562 Final_List
: constant List_Id
:= New_List
;
5563 Index_List
: constant List_Id
:= New_List
;
5564 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5565 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5566 Counter_Id
: Entity_Id
;
5570 Final_Block
: Node_Id
;
5571 Final_Loop
: Node_Id
;
5572 Finalizer_Data
: Finalization_Exception_Data
;
5573 Finalizer_Decls
: List_Id
:= No_List
;
5574 Init_Loop
: Node_Id
;
5579 Exceptions_OK
: constant Boolean :=
5580 not Restriction_Active
(No_Exception_Propagation
);
5582 function Build_Counter_Assignment
return Node_Id
;
5583 -- Generate the following assignment:
5584 -- Counter := V'Length (1) *
5586 -- V'Length (N) - Counter;
5588 function Build_Finalization_Call
return Node_Id
;
5589 -- Generate a deep finalization call for an array element
5591 procedure Build_Indexes
;
5592 -- Generate the initialization and finalization indexes used in the
5595 function Build_Initialization_Call
return Node_Id
;
5596 -- Generate a deep initialization call for an array element
5598 ------------------------------
5599 -- Build_Counter_Assignment --
5600 ------------------------------
5602 function Build_Counter_Assignment
return Node_Id
is
5607 -- Start from the first dimension and generate:
5612 Make_Attribute_Reference
(Loc
,
5613 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5614 Attribute_Name
=> Name_Length
,
5615 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5617 -- Process the rest of the dimensions, generate:
5618 -- Expr * V'Length (N)
5621 while Dim
<= Num_Dims
loop
5623 Make_Op_Multiply
(Loc
,
5626 Make_Attribute_Reference
(Loc
,
5627 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5628 Attribute_Name
=> Name_Length
,
5629 Expressions
=> New_List
(
5630 Make_Integer_Literal
(Loc
, Dim
))));
5636 -- Counter := Expr - Counter;
5639 Make_Assignment_Statement
(Loc
,
5640 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5642 Make_Op_Subtract
(Loc
,
5644 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5645 end Build_Counter_Assignment
;
5647 -----------------------------
5648 -- Build_Finalization_Call --
5649 -----------------------------
5651 function Build_Finalization_Call
return Node_Id
is
5652 Comp_Ref
: constant Node_Id
:=
5653 Make_Indexed_Component
(Loc
,
5654 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5655 Expressions
=> New_References_To
(Final_List
, Loc
));
5658 Set_Etype
(Comp_Ref
, Comp_Typ
);
5661 -- [Deep_]Finalize (V);
5663 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5664 end Build_Finalization_Call
;
5670 procedure Build_Indexes
is
5672 -- Generate the following identifiers:
5673 -- Jnn - for initialization
5674 -- Fnn - for finalization
5676 for Dim
in 1 .. Num_Dims
loop
5677 Append_To
(Index_List
,
5678 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5680 Append_To
(Final_List
,
5681 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5685 -------------------------------
5686 -- Build_Initialization_Call --
5687 -------------------------------
5689 function Build_Initialization_Call
return Node_Id
is
5690 Comp_Ref
: constant Node_Id
:=
5691 Make_Indexed_Component
(Loc
,
5692 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5693 Expressions
=> New_References_To
(Index_List
, Loc
));
5696 Set_Etype
(Comp_Ref
, Comp_Typ
);
5699 -- [Deep_]Initialize (V (J1, ..., JN));
5701 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5702 end Build_Initialization_Call
;
5704 -- Start of processing for Build_Initialize_Statements
5707 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5708 Finalizer_Decls
:= New_List
;
5711 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5713 -- Generate the block which houses the finalization call, the index
5714 -- guard and the handler which triggers Program_Error later on.
5716 -- if Counter > 0 then
5717 -- Counter := Counter - 1;
5719 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5721 -- begin -- Exceptions allowed
5722 -- [Deep_]Finalize (V (F1, ..., FN));
5725 -- if not Raised then
5727 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5732 if Exceptions_OK
then
5734 Make_Block_Statement
(Loc
,
5735 Handled_Statement_Sequence
=>
5736 Make_Handled_Sequence_Of_Statements
(Loc
,
5737 Statements
=> New_List
(Build_Finalization_Call
),
5738 Exception_Handlers
=> New_List
(
5739 Build_Exception_Handler
(Finalizer_Data
))));
5741 Fin_Stmt
:= Build_Finalization_Call
;
5744 -- This is the core of the loop, the dimension iterators are added
5745 -- one by one in reverse.
5748 Make_If_Statement
(Loc
,
5751 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5752 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5754 Then_Statements
=> New_List
(
5755 Make_Assignment_Statement
(Loc
,
5756 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5758 Make_Op_Subtract
(Loc
,
5759 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5760 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5762 Else_Statements
=> New_List
(Fin_Stmt
));
5764 -- Generate all finalization loops starting from the innermost
5767 -- for Fnn in reverse V'Range (Dim) loop
5771 F
:= Last
(Final_List
);
5773 while Present
(F
) and then Dim
> 0 loop
5779 Make_Loop_Statement
(Loc
,
5781 Make_Iteration_Scheme
(Loc
,
5782 Loop_Parameter_Specification
=>
5783 Make_Loop_Parameter_Specification
(Loc
,
5784 Defining_Identifier
=> Loop_Id
,
5785 Discrete_Subtype_Definition
=>
5786 Make_Attribute_Reference
(Loc
,
5787 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5788 Attribute_Name
=> Name_Range
,
5789 Expressions
=> New_List
(
5790 Make_Integer_Literal
(Loc
, Dim
))),
5792 Reverse_Present
=> True)),
5794 Statements
=> New_List
(Final_Loop
),
5795 End_Label
=> Empty
);
5800 -- Generate the block which contains the finalization loops, the
5801 -- declarations of the abort flag, the exception occurrence, the
5802 -- raised flag and the conditional raise.
5805 -- Abort : constant Boolean := Triggered_By_Abort;
5807 -- Abort : constant Boolean := False; -- no abort
5809 -- E : Exception_Occurrence;
5810 -- Raised : Boolean := False;
5816 -- V'Length (N) - Counter;
5820 -- if Raised and then not Abort then -- Exception handlers OK
5821 -- Raise_From_Controlled_Operation (E);
5824 -- raise; -- Exception handlers OK
5827 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5829 if Exceptions_OK
then
5831 Build_Raise_Statement
(Finalizer_Data
));
5832 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5836 Make_Block_Statement
(Loc
,
5839 Handled_Statement_Sequence
=>
5840 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5842 -- Generate the block which contains the initialization call and
5843 -- the partial finalization code.
5846 -- [Deep_]Initialize (V (J1, ..., JN));
5848 -- Counter := Counter + 1;
5852 -- <finalization code>
5856 Make_Block_Statement
(Loc
,
5857 Handled_Statement_Sequence
=>
5858 Make_Handled_Sequence_Of_Statements
(Loc
,
5859 Statements
=> New_List
(Build_Initialization_Call
),
5860 Exception_Handlers
=> New_List
(
5861 Make_Exception_Handler
(Loc
,
5862 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5863 Statements
=> New_List
(Final_Block
)))));
5865 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5866 Make_Assignment_Statement
(Loc
,
5867 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5870 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5871 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5873 -- Generate all initialization loops starting from the innermost
5876 -- for Jnn in V'Range (Dim) loop
5880 J
:= Last
(Index_List
);
5882 while Present
(J
) and then Dim
> 0 loop
5888 Make_Loop_Statement
(Loc
,
5890 Make_Iteration_Scheme
(Loc
,
5891 Loop_Parameter_Specification
=>
5892 Make_Loop_Parameter_Specification
(Loc
,
5893 Defining_Identifier
=> Loop_Id
,
5894 Discrete_Subtype_Definition
=>
5895 Make_Attribute_Reference
(Loc
,
5896 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5897 Attribute_Name
=> Name_Range
,
5898 Expressions
=> New_List
(
5899 Make_Integer_Literal
(Loc
, Dim
))))),
5901 Statements
=> New_List
(Init_Loop
),
5902 End_Label
=> Empty
);
5907 -- Generate the block which contains the counter variable and the
5908 -- initialization loops.
5911 -- Counter : Integer := 0;
5918 Make_Block_Statement
(Loc
,
5919 Declarations
=> New_List
(
5920 Make_Object_Declaration
(Loc
,
5921 Defining_Identifier
=> Counter_Id
,
5922 Object_Definition
=>
5923 New_Occurrence_Of
(Standard_Integer
, Loc
),
5924 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5926 Handled_Statement_Sequence
=>
5927 Make_Handled_Sequence_Of_Statements
(Loc
,
5928 Statements
=> New_List
(Init_Loop
))));
5929 end Build_Initialize_Statements
;
5931 -----------------------
5932 -- New_References_To --
5933 -----------------------
5935 function New_References_To
5937 Loc
: Source_Ptr
) return List_Id
5939 Refs
: constant List_Id
:= New_List
;
5944 while Present
(Id
) loop
5945 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
5950 end New_References_To
;
5952 -- Start of processing for Make_Deep_Array_Body
5956 when Address_Case
=>
5957 return Make_Finalize_Address_Stmts
(Typ
);
5961 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5963 when Initialize_Case
=>
5964 return Build_Initialize_Statements
(Typ
);
5966 end Make_Deep_Array_Body
;
5968 --------------------
5969 -- Make_Deep_Proc --
5970 --------------------
5972 function Make_Deep_Proc
5973 (Prim
: Final_Primitives
;
5975 Stmts
: List_Id
) return Entity_Id
5977 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5979 Proc_Id
: Entity_Id
;
5982 -- Create the object formal, generate:
5983 -- V : System.Address
5985 if Prim
= Address_Case
then
5986 Formals
:= New_List
(
5987 Make_Parameter_Specification
(Loc
,
5988 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5990 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5997 Formals
:= New_List
(
5998 Make_Parameter_Specification
(Loc
,
5999 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6001 Out_Present
=> True,
6002 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6004 -- F : Boolean := True
6006 if Prim
= Adjust_Case
6007 or else Prim
= Finalize_Case
6010 Make_Parameter_Specification
(Loc
,
6011 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6013 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6015 New_Occurrence_Of
(Standard_True
, Loc
)));
6020 Make_Defining_Identifier
(Loc
,
6021 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6024 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6027 -- exception -- Finalize and Adjust cases only
6028 -- raise Program_Error;
6029 -- end Deep_Initialize / Adjust / Finalize;
6033 -- procedure Finalize_Address (V : System.Address) is
6036 -- end Finalize_Address;
6039 Make_Subprogram_Body
(Loc
,
6041 Make_Procedure_Specification
(Loc
,
6042 Defining_Unit_Name
=> Proc_Id
,
6043 Parameter_Specifications
=> Formals
),
6045 Declarations
=> Empty_List
,
6047 Handled_Statement_Sequence
=>
6048 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6053 ---------------------------
6054 -- Make_Deep_Record_Body --
6055 ---------------------------
6057 function Make_Deep_Record_Body
6058 (Prim
: Final_Primitives
;
6060 Is_Local
: Boolean := False) return List_Id
6062 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6063 -- Build the statements necessary to adjust a record type. The type may
6064 -- have discriminants and contain variant parts. Generate:
6068 -- [Deep_]Adjust (V.Comp_1);
6070 -- when Id : others =>
6071 -- if not Raised then
6073 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6078 -- [Deep_]Adjust (V.Comp_N);
6080 -- when Id : others =>
6081 -- if not Raised then
6083 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6088 -- Deep_Adjust (V._parent, False); -- If applicable
6090 -- when Id : others =>
6091 -- if not Raised then
6093 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6099 -- Adjust (V); -- If applicable
6102 -- if not Raised then
6104 -- Save_Occurence (E, Get_Current_Excep.all.all);
6109 -- if Raised and then not Abort then
6110 -- Raise_From_Controlled_Operation (E);
6114 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6115 -- Build the statements necessary to finalize a record type. The type
6116 -- may have discriminants and contain variant parts. Generate:
6119 -- Abort : constant Boolean := Triggered_By_Abort;
6121 -- Abort : constant Boolean := False; -- no abort
6122 -- E : Exception_Occurence;
6123 -- Raised : Boolean := False;
6128 -- Finalize (V); -- If applicable
6131 -- if not Raised then
6133 -- Save_Occurence (E, Get_Current_Excep.all.all);
6138 -- case Variant_1 is
6140 -- case State_Counter_N => -- If Is_Local is enabled
6150 -- <<LN>> -- If Is_Local is enabled
6152 -- [Deep_]Finalize (V.Comp_N);
6155 -- if not Raised then
6157 -- Save_Occurence (E, Get_Current_Excep.all.all);
6163 -- [Deep_]Finalize (V.Comp_1);
6166 -- if not Raised then
6168 -- Save_Occurence (E, Get_Current_Excep.all.all);
6174 -- case State_Counter_1 => -- If Is_Local is enabled
6180 -- Deep_Finalize (V._parent, False); -- If applicable
6182 -- when Id : others =>
6183 -- if not Raised then
6185 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6189 -- if Raised and then not Abort then
6190 -- Raise_From_Controlled_Operation (E);
6194 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6195 -- Given a derived tagged type Typ, traverse all components, find field
6196 -- _parent and return its type.
6198 procedure Preprocess_Components
6200 Num_Comps
: out Int
;
6201 Has_POC
: out Boolean);
6202 -- Examine all components in component list Comps, count all controlled
6203 -- components and determine whether at least one of them is per-object
6204 -- constrained. Component _parent is always skipped.
6206 -----------------------------
6207 -- Build_Adjust_Statements --
6208 -----------------------------
6210 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6211 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6212 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6213 Bod_Stmts
: List_Id
;
6214 Finalizer_Data
: Finalization_Exception_Data
;
6215 Finalizer_Decls
: List_Id
:= No_List
;
6219 Exceptions_OK
: constant Boolean :=
6220 not Restriction_Active
(No_Exception_Propagation
);
6222 function Process_Component_List_For_Adjust
6223 (Comps
: Node_Id
) return List_Id
;
6224 -- Build all necessary adjust statements for a single component list
6226 ---------------------------------------
6227 -- Process_Component_List_For_Adjust --
6228 ---------------------------------------
6230 function Process_Component_List_For_Adjust
6231 (Comps
: Node_Id
) return List_Id
6233 Stmts
: constant List_Id
:= New_List
;
6235 Decl_Id
: Entity_Id
;
6236 Decl_Typ
: Entity_Id
;
6240 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6241 -- Process the declaration of a single controlled component
6243 ----------------------------------
6244 -- Process_Component_For_Adjust --
6245 ----------------------------------
6247 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6248 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6249 Typ
: constant Entity_Id
:= Etype
(Id
);
6254 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6256 -- begin -- Exception handlers allowed
6257 -- [Deep_]Adjust (V.Id);
6260 -- if not Raised then
6262 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6269 Make_Selected_Component
(Loc
,
6270 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6271 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6274 if Exceptions_OK
then
6276 Make_Block_Statement
(Loc
,
6277 Handled_Statement_Sequence
=>
6278 Make_Handled_Sequence_Of_Statements
(Loc
,
6279 Statements
=> New_List
(Adj_Stmt
),
6280 Exception_Handlers
=> New_List
(
6281 Build_Exception_Handler
(Finalizer_Data
))));
6284 Append_To
(Stmts
, Adj_Stmt
);
6285 end Process_Component_For_Adjust
;
6287 -- Start of processing for Process_Component_List_For_Adjust
6290 -- Perform an initial check, determine the number of controlled
6291 -- components in the current list and whether at least one of them
6292 -- is per-object constrained.
6294 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6296 -- The processing in this routine is done in the following order:
6297 -- 1) Regular components
6298 -- 2) Per-object constrained components
6301 if Num_Comps
> 0 then
6303 -- Process all regular components in order of declarations
6305 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6306 while Present
(Decl
) loop
6307 Decl_Id
:= Defining_Identifier
(Decl
);
6308 Decl_Typ
:= Etype
(Decl_Id
);
6310 -- Skip _parent as well as per-object constrained components
6312 if Chars
(Decl_Id
) /= Name_uParent
6313 and then Needs_Finalization
(Decl_Typ
)
6315 if Has_Access_Constraint
(Decl_Id
)
6316 and then No
(Expression
(Decl
))
6320 Process_Component_For_Adjust
(Decl
);
6324 Next_Non_Pragma
(Decl
);
6327 -- Process all per-object constrained components in order of
6331 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6332 while Present
(Decl
) loop
6333 Decl_Id
:= Defining_Identifier
(Decl
);
6334 Decl_Typ
:= Etype
(Decl_Id
);
6338 if Chars
(Decl_Id
) /= Name_uParent
6339 and then Needs_Finalization
(Decl_Typ
)
6340 and then Has_Access_Constraint
(Decl_Id
)
6341 and then No
(Expression
(Decl
))
6343 Process_Component_For_Adjust
(Decl
);
6346 Next_Non_Pragma
(Decl
);
6351 -- Process all variants, if any
6354 if Present
(Variant_Part
(Comps
)) then
6356 Var_Alts
: constant List_Id
:= New_List
;
6360 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6361 while Present
(Var
) loop
6364 -- when <discrete choices> =>
6365 -- <adjust statements>
6367 Append_To
(Var_Alts
,
6368 Make_Case_Statement_Alternative
(Loc
,
6370 New_Copy_List
(Discrete_Choices
(Var
)),
6372 Process_Component_List_For_Adjust
(
6373 Component_List
(Var
))));
6375 Next_Non_Pragma
(Var
);
6379 -- case V.<discriminant> is
6380 -- when <discrete choices 1> =>
6381 -- <adjust statements 1>
6383 -- when <discrete choices N> =>
6384 -- <adjust statements N>
6388 Make_Case_Statement
(Loc
,
6390 Make_Selected_Component
(Loc
,
6391 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6393 Make_Identifier
(Loc
,
6394 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6395 Alternatives
=> Var_Alts
);
6399 -- Add the variant case statement to the list of statements
6401 if Present
(Var_Case
) then
6402 Append_To
(Stmts
, Var_Case
);
6405 -- If the component list did not have any controlled components
6406 -- nor variants, return null.
6408 if Is_Empty_List
(Stmts
) then
6409 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6413 end Process_Component_List_For_Adjust
;
6415 -- Start of processing for Build_Adjust_Statements
6418 Finalizer_Decls
:= New_List
;
6419 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6421 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6422 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6427 -- Create an adjust sequence for all record components
6429 if Present
(Component_List
(Rec_Def
)) then
6431 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6434 -- A derived record type must adjust all inherited components. This
6435 -- action poses the following problem:
6437 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6442 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6444 -- Deep_Adjust (Obj._parent);
6449 -- Adjusting the derived type will invoke Adjust of the parent and
6450 -- then that of the derived type. This is undesirable because both
6451 -- routines may modify shared components. Only the Adjust of the
6452 -- derived type should be invoked.
6454 -- To prevent this double adjustment of shared components,
6455 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6457 -- procedure Deep_Adjust
6458 -- (Obj : in out Some_Type;
6459 -- Flag : Boolean := True)
6467 -- When Deep_Adjust is invokes for field _parent, a value of False is
6468 -- provided for the flag:
6470 -- Deep_Adjust (Obj._parent, False);
6472 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6474 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6479 if Needs_Finalization
(Par_Typ
) then
6483 Make_Selected_Component
(Loc
,
6484 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6486 Make_Identifier
(Loc
, Name_uParent
)),
6491 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6493 -- begin -- Exceptions OK
6494 -- Deep_Adjust (V._parent, False);
6496 -- when Id : others =>
6497 -- if not Raised then
6499 -- Save_Occurrence (E,
6500 -- Get_Current_Excep.all.all);
6504 if Present
(Call
) then
6507 if Exceptions_OK
then
6509 Make_Block_Statement
(Loc
,
6510 Handled_Statement_Sequence
=>
6511 Make_Handled_Sequence_Of_Statements
(Loc
,
6512 Statements
=> New_List
(Adj_Stmt
),
6513 Exception_Handlers
=> New_List
(
6514 Build_Exception_Handler
(Finalizer_Data
))));
6517 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6523 -- Adjust the object. This action must be performed last after all
6524 -- components have been adjusted.
6526 if Is_Controlled
(Typ
) then
6532 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
6536 -- Adjust (V); -- No_Exception_Propagation
6538 -- begin -- Exception handlers allowed
6542 -- if not Raised then
6544 -- Save_Occurrence (E,
6545 -- Get_Current_Excep.all.all);
6550 if Present
(Proc
) then
6552 Make_Procedure_Call_Statement
(Loc
,
6553 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6554 Parameter_Associations
=> New_List
(
6555 Make_Identifier
(Loc
, Name_V
)));
6557 if Exceptions_OK
then
6559 Make_Block_Statement
(Loc
,
6560 Handled_Statement_Sequence
=>
6561 Make_Handled_Sequence_Of_Statements
(Loc
,
6562 Statements
=> New_List
(Adj_Stmt
),
6563 Exception_Handlers
=> New_List
(
6564 Build_Exception_Handler
6565 (Finalizer_Data
))));
6568 Append_To
(Bod_Stmts
,
6569 Make_If_Statement
(Loc
,
6570 Condition
=> Make_Identifier
(Loc
, Name_F
),
6571 Then_Statements
=> New_List
(Adj_Stmt
)));
6576 -- At this point either all adjustment statements have been generated
6577 -- or the type is not controlled.
6579 if Is_Empty_List
(Bod_Stmts
) then
6580 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6586 -- Abort : constant Boolean := Triggered_By_Abort;
6588 -- Abort : constant Boolean := False; -- no abort
6590 -- E : Exception_Occurence;
6591 -- Raised : Boolean := False;
6594 -- <adjust statements>
6596 -- if Raised and then not Abort then
6597 -- Raise_From_Controlled_Operation (E);
6602 if Exceptions_OK
then
6603 Append_To
(Bod_Stmts
,
6604 Build_Raise_Statement
(Finalizer_Data
));
6609 Make_Block_Statement
(Loc
,
6612 Handled_Statement_Sequence
=>
6613 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6615 end Build_Adjust_Statements
;
6617 -------------------------------
6618 -- Build_Finalize_Statements --
6619 -------------------------------
6621 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6622 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6623 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6624 Bod_Stmts
: List_Id
;
6626 Finalizer_Data
: Finalization_Exception_Data
;
6627 Finalizer_Decls
: List_Id
:= No_List
;
6631 Exceptions_OK
: constant Boolean :=
6632 not Restriction_Active
(No_Exception_Propagation
);
6634 function Process_Component_List_For_Finalize
6635 (Comps
: Node_Id
) return List_Id
;
6636 -- Build all necessary finalization statements for a single component
6637 -- list. The statements may include a jump circuitry if flag Is_Local
6640 -----------------------------------------
6641 -- Process_Component_List_For_Finalize --
6642 -----------------------------------------
6644 function Process_Component_List_For_Finalize
6645 (Comps
: Node_Id
) return List_Id
6648 Counter_Id
: Entity_Id
;
6650 Decl_Id
: Entity_Id
;
6651 Decl_Typ
: Entity_Id
;
6654 Jump_Block
: Node_Id
;
6656 Label_Id
: Entity_Id
;
6660 procedure Process_Component_For_Finalize
6665 -- Process the declaration of a single controlled component. If
6666 -- flag Is_Local is enabled, create the corresponding label and
6667 -- jump circuitry. Alts is the list of case alternatives, Decls
6668 -- is the top level declaration list where labels are declared
6669 -- and Stmts is the list of finalization actions.
6671 ------------------------------------
6672 -- Process_Component_For_Finalize --
6673 ------------------------------------
6675 procedure Process_Component_For_Finalize
6681 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6682 Typ
: constant Entity_Id
:= Etype
(Id
);
6689 Label_Id
: Entity_Id
;
6696 Make_Identifier
(Loc
,
6697 Chars
=> New_External_Name
('L', Num_Comps
));
6698 Set_Entity
(Label_Id
,
6699 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6700 Label
:= Make_Label
(Loc
, Label_Id
);
6703 Make_Implicit_Label_Declaration
(Loc
,
6704 Defining_Identifier
=> Entity
(Label_Id
),
6705 Label_Construct
=> Label
));
6712 Make_Case_Statement_Alternative
(Loc
,
6713 Discrete_Choices
=> New_List
(
6714 Make_Integer_Literal
(Loc
, Num_Comps
)),
6716 Statements
=> New_List
(
6717 Make_Goto_Statement
(Loc
,
6719 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6724 Append_To
(Stmts
, Label
);
6726 -- Decrease the number of components to be processed.
6727 -- This action yields a new Label_Id in future calls.
6729 Num_Comps
:= Num_Comps
- 1;
6734 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6736 -- begin -- Exception handlers allowed
6737 -- [Deep_]Finalize (V.Id);
6740 -- if not Raised then
6742 -- Save_Occurrence (E,
6743 -- Get_Current_Excep.all.all);
6750 Make_Selected_Component
(Loc
,
6751 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6752 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6755 if not Restriction_Active
(No_Exception_Propagation
) then
6757 Make_Block_Statement
(Loc
,
6758 Handled_Statement_Sequence
=>
6759 Make_Handled_Sequence_Of_Statements
(Loc
,
6760 Statements
=> New_List
(Fin_Stmt
),
6761 Exception_Handlers
=> New_List
(
6762 Build_Exception_Handler
(Finalizer_Data
))));
6765 Append_To
(Stmts
, Fin_Stmt
);
6766 end Process_Component_For_Finalize
;
6768 -- Start of processing for Process_Component_List_For_Finalize
6771 -- Perform an initial check, look for controlled and per-object
6772 -- constrained components.
6774 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6776 -- Create a state counter to service the current component list.
6777 -- This step is performed before the variants are inspected in
6778 -- order to generate the same state counter names as those from
6779 -- Build_Initialize_Statements.
6781 if Num_Comps
> 0 and then Is_Local
then
6782 Counter
:= Counter
+ 1;
6785 Make_Defining_Identifier
(Loc
,
6786 Chars
=> New_External_Name
('C', Counter
));
6789 -- Process the component in the following order:
6791 -- 2) Per-object constrained components
6792 -- 3) Regular components
6794 -- Start with the variant parts
6797 if Present
(Variant_Part
(Comps
)) then
6799 Var_Alts
: constant List_Id
:= New_List
;
6803 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6804 while Present
(Var
) loop
6807 -- when <discrete choices> =>
6808 -- <finalize statements>
6810 Append_To
(Var_Alts
,
6811 Make_Case_Statement_Alternative
(Loc
,
6813 New_Copy_List
(Discrete_Choices
(Var
)),
6815 Process_Component_List_For_Finalize
(
6816 Component_List
(Var
))));
6818 Next_Non_Pragma
(Var
);
6822 -- case V.<discriminant> is
6823 -- when <discrete choices 1> =>
6824 -- <finalize statements 1>
6826 -- when <discrete choices N> =>
6827 -- <finalize statements N>
6831 Make_Case_Statement
(Loc
,
6833 Make_Selected_Component
(Loc
,
6834 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6836 Make_Identifier
(Loc
,
6837 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6838 Alternatives
=> Var_Alts
);
6842 -- The current component list does not have a single controlled
6843 -- component, however it may contain variants. Return the case
6844 -- statement for the variants or nothing.
6846 if Num_Comps
= 0 then
6847 if Present
(Var_Case
) then
6848 return New_List
(Var_Case
);
6850 return New_List
(Make_Null_Statement
(Loc
));
6854 -- Prepare all lists
6860 -- Process all per-object constrained components in reverse order
6863 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6864 while Present
(Decl
) loop
6865 Decl_Id
:= Defining_Identifier
(Decl
);
6866 Decl_Typ
:= Etype
(Decl_Id
);
6870 if Chars
(Decl_Id
) /= Name_uParent
6871 and then Needs_Finalization
(Decl_Typ
)
6872 and then Has_Access_Constraint
(Decl_Id
)
6873 and then No
(Expression
(Decl
))
6875 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6878 Prev_Non_Pragma
(Decl
);
6882 -- Process the rest of the components in reverse order
6884 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6885 while Present
(Decl
) loop
6886 Decl_Id
:= Defining_Identifier
(Decl
);
6887 Decl_Typ
:= Etype
(Decl_Id
);
6891 if Chars
(Decl_Id
) /= Name_uParent
6892 and then Needs_Finalization
(Decl_Typ
)
6894 -- Skip per-object constrained components since they were
6895 -- handled in the above step.
6897 if Has_Access_Constraint
(Decl_Id
)
6898 and then No
(Expression
(Decl
))
6902 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6906 Prev_Non_Pragma
(Decl
);
6911 -- LN : label; -- If Is_Local is enabled
6916 -- case CounterX is .
6926 -- <<LN>> -- If Is_Local is enabled
6928 -- [Deep_]Finalize (V.CompY);
6930 -- when Id : others =>
6931 -- if not Raised then
6933 -- Save_Occurrence (E,
6934 -- Get_Current_Excep.all.all);
6938 -- <<L0>> -- If Is_Local is enabled
6943 -- Add the declaration of default jump location L0, its
6944 -- corresponding alternative and its place in the statements.
6946 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6947 Set_Entity
(Label_Id
,
6948 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6949 Label
:= Make_Label
(Loc
, Label_Id
);
6951 Append_To
(Decls
, -- declaration
6952 Make_Implicit_Label_Declaration
(Loc
,
6953 Defining_Identifier
=> Entity
(Label_Id
),
6954 Label_Construct
=> Label
));
6956 Append_To
(Alts
, -- alternative
6957 Make_Case_Statement_Alternative
(Loc
,
6958 Discrete_Choices
=> New_List
(
6959 Make_Others_Choice
(Loc
)),
6961 Statements
=> New_List
(
6962 Make_Goto_Statement
(Loc
,
6963 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6965 Append_To
(Stmts
, Label
); -- statement
6967 -- Create the jump block
6970 Make_Case_Statement
(Loc
,
6971 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6972 Alternatives
=> Alts
));
6976 Make_Block_Statement
(Loc
,
6977 Declarations
=> Decls
,
6978 Handled_Statement_Sequence
=>
6979 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6981 if Present
(Var_Case
) then
6982 return New_List
(Var_Case
, Jump_Block
);
6984 return New_List
(Jump_Block
);
6986 end Process_Component_List_For_Finalize
;
6988 -- Start of processing for Build_Finalize_Statements
6991 Finalizer_Decls
:= New_List
;
6992 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6994 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6995 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7000 -- Create a finalization sequence for all record components
7002 if Present
(Component_List
(Rec_Def
)) then
7004 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7007 -- A derived record type must finalize all inherited components. This
7008 -- action poses the following problem:
7010 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7015 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7017 -- Deep_Finalize (Obj._parent);
7022 -- Finalizing the derived type will invoke Finalize of the parent and
7023 -- then that of the derived type. This is undesirable because both
7024 -- routines may modify shared components. Only the Finalize of the
7025 -- derived type should be invoked.
7027 -- To prevent this double adjustment of shared components,
7028 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7030 -- procedure Deep_Finalize
7031 -- (Obj : in out Some_Type;
7032 -- Flag : Boolean := True)
7040 -- When Deep_Finalize is invoked for field _parent, a value of False
7041 -- is provided for the flag:
7043 -- Deep_Finalize (Obj._parent, False);
7045 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7047 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7052 if Needs_Finalization
(Par_Typ
) then
7056 Make_Selected_Component
(Loc
,
7057 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7059 Make_Identifier
(Loc
, Name_uParent
)),
7064 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
7066 -- begin -- Exceptions OK
7067 -- Deep_Finalize (V._parent, False);
7069 -- when Id : others =>
7070 -- if not Raised then
7072 -- Save_Occurrence (E,
7073 -- Get_Current_Excep.all.all);
7077 if Present
(Call
) then
7080 if Exceptions_OK
then
7082 Make_Block_Statement
(Loc
,
7083 Handled_Statement_Sequence
=>
7084 Make_Handled_Sequence_Of_Statements
(Loc
,
7085 Statements
=> New_List
(Fin_Stmt
),
7086 Exception_Handlers
=> New_List
(
7087 Build_Exception_Handler
7088 (Finalizer_Data
))));
7091 Append_To
(Bod_Stmts
, Fin_Stmt
);
7097 -- Finalize the object. This action must be performed first before
7098 -- all components have been finalized.
7100 if Is_Controlled
(Typ
) and then not Is_Local
then
7106 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7110 -- Finalize (V); -- No_Exception_Propagation
7116 -- if not Raised then
7118 -- Save_Occurrence (E,
7119 -- Get_Current_Excep.all.all);
7124 if Present
(Proc
) then
7126 Make_Procedure_Call_Statement
(Loc
,
7127 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7128 Parameter_Associations
=> New_List
(
7129 Make_Identifier
(Loc
, Name_V
)));
7131 if Exceptions_OK
then
7133 Make_Block_Statement
(Loc
,
7134 Handled_Statement_Sequence
=>
7135 Make_Handled_Sequence_Of_Statements
(Loc
,
7136 Statements
=> New_List
(Fin_Stmt
),
7137 Exception_Handlers
=> New_List
(
7138 Build_Exception_Handler
7139 (Finalizer_Data
))));
7142 Prepend_To
(Bod_Stmts
,
7143 Make_If_Statement
(Loc
,
7144 Condition
=> Make_Identifier
(Loc
, Name_F
),
7145 Then_Statements
=> New_List
(Fin_Stmt
)));
7150 -- At this point either all finalization statements have been
7151 -- generated or the type is not controlled.
7153 if No
(Bod_Stmts
) then
7154 return New_List
(Make_Null_Statement
(Loc
));
7158 -- Abort : constant Boolean := Triggered_By_Abort;
7160 -- Abort : constant Boolean := False; -- no abort
7162 -- E : Exception_Occurence;
7163 -- Raised : Boolean := False;
7166 -- <finalize statements>
7168 -- if Raised and then not Abort then
7169 -- Raise_From_Controlled_Operation (E);
7174 if Exceptions_OK
then
7175 Append_To
(Bod_Stmts
,
7176 Build_Raise_Statement
(Finalizer_Data
));
7181 Make_Block_Statement
(Loc
,
7184 Handled_Statement_Sequence
=>
7185 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7187 end Build_Finalize_Statements
;
7189 -----------------------
7190 -- Parent_Field_Type --
7191 -----------------------
7193 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7197 Field
:= First_Entity
(Typ
);
7198 while Present
(Field
) loop
7199 if Chars
(Field
) = Name_uParent
then
7200 return Etype
(Field
);
7203 Next_Entity
(Field
);
7206 -- A derived tagged type should always have a parent field
7208 raise Program_Error
;
7209 end Parent_Field_Type
;
7211 ---------------------------
7212 -- Preprocess_Components --
7213 ---------------------------
7215 procedure Preprocess_Components
7217 Num_Comps
: out Int
;
7218 Has_POC
: out Boolean)
7228 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7229 while Present
(Decl
) loop
7230 Id
:= Defining_Identifier
(Decl
);
7233 -- Skip field _parent
7235 if Chars
(Id
) /= Name_uParent
7236 and then Needs_Finalization
(Typ
)
7238 Num_Comps
:= Num_Comps
+ 1;
7240 if Has_Access_Constraint
(Id
)
7241 and then No
(Expression
(Decl
))
7247 Next_Non_Pragma
(Decl
);
7249 end Preprocess_Components
;
7251 -- Start of processing for Make_Deep_Record_Body
7255 when Address_Case
=>
7256 return Make_Finalize_Address_Stmts
(Typ
);
7259 return Build_Adjust_Statements
(Typ
);
7261 when Finalize_Case
=>
7262 return Build_Finalize_Statements
(Typ
);
7264 when Initialize_Case
=>
7266 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7269 if Is_Controlled
(Typ
) then
7271 Make_Procedure_Call_Statement
(Loc
,
7274 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7275 Parameter_Associations
=> New_List
(
7276 Make_Identifier
(Loc
, Name_V
))));
7282 end Make_Deep_Record_Body
;
7284 ----------------------
7285 -- Make_Final_Call --
7286 ----------------------
7288 function Make_Final_Call
7291 Skip_Self
: Boolean := False) return Node_Id
7293 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7295 Fin_Id
: Entity_Id
:= Empty
;
7300 -- Recover the proper type which contains [Deep_]Finalize
7302 if Is_Class_Wide_Type
(Typ
) then
7303 Utyp
:= Root_Type
(Typ
);
7307 elsif Is_Concurrent_Type
(Typ
) then
7308 Utyp
:= Corresponding_Record_Type
(Typ
);
7310 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7312 elsif Is_Private_Type
(Typ
)
7313 and then Present
(Full_View
(Typ
))
7314 and then Is_Concurrent_Type
(Full_View
(Typ
))
7316 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7318 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7326 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7327 Set_Assignment_OK
(Ref
);
7329 -- Deal with untagged derivation of private views. If the parent type
7330 -- is a protected type, Deep_Finalize is found on the corresponding
7331 -- record of the ancestor.
7333 if Is_Untagged_Derivation
(Typ
) then
7334 if Is_Protected_Type
(Typ
) then
7335 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7337 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7339 if Is_Protected_Type
(Utyp
) then
7340 Utyp
:= Corresponding_Record_Type
(Utyp
);
7344 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7345 Set_Assignment_OK
(Ref
);
7348 -- Deal with derived private types which do not inherit primitives from
7349 -- their parents. In this case, [Deep_]Finalize can be found in the full
7350 -- view of the parent type.
7352 if Is_Tagged_Type
(Utyp
)
7353 and then Is_Derived_Type
(Utyp
)
7354 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7355 and then Is_Private_Type
(Etype
(Utyp
))
7356 and then Present
(Full_View
(Etype
(Utyp
)))
7358 Utyp
:= Full_View
(Etype
(Utyp
));
7359 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7360 Set_Assignment_OK
(Ref
);
7363 -- When dealing with the completion of a private type, use the base type
7366 if Utyp
/= Base_Type
(Utyp
) then
7367 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7369 Utyp
:= Base_Type
(Utyp
);
7370 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7371 Set_Assignment_OK
(Ref
);
7375 if Has_Controlled_Component
(Utyp
) then
7376 if Is_Tagged_Type
(Utyp
) then
7377 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7379 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7383 -- Class-wide types, interfaces and types with controlled components
7385 elsif Is_Class_Wide_Type
(Typ
)
7386 or else Is_Interface
(Typ
)
7387 or else Has_Controlled_Component
(Utyp
)
7389 if Is_Tagged_Type
(Utyp
) then
7390 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7392 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7395 -- Derivations from [Limited_]Controlled
7397 elsif Is_Controlled
(Utyp
) then
7398 if Has_Controlled_Component
(Utyp
) then
7399 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7401 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7406 elsif Is_Tagged_Type
(Utyp
) then
7407 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7410 raise Program_Error
;
7413 if Present
(Fin_Id
) then
7415 -- When finalizing a class-wide object, do not convert to the root
7416 -- type in order to produce a dispatching call.
7418 if Is_Class_Wide_Type
(Typ
) then
7421 -- Ensure that a finalization routine is at least decorated in order
7422 -- to inspect the object parameter.
7424 elsif Analyzed
(Fin_Id
)
7425 or else Ekind
(Fin_Id
) = E_Procedure
7427 -- In certain cases, such as the creation of Stream_Read, the
7428 -- visible entity of the type is its full view. Since Stream_Read
7429 -- will have to create an object of type Typ, the local object
7430 -- will be finalzed by the scope finalizer generated later on. The
7431 -- object parameter of Deep_Finalize will always use the private
7432 -- view of the type. To avoid such a clash between a private and a
7433 -- full view, perform an unchecked conversion of the object
7434 -- reference to the private view.
7437 Formal_Typ
: constant Entity_Id
:=
7438 Etype
(First_Formal
(Fin_Id
));
7440 if Is_Private_Type
(Formal_Typ
)
7441 and then Present
(Full_View
(Formal_Typ
))
7442 and then Full_View
(Formal_Typ
) = Utyp
7444 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7448 Ref
:= Convert_View
(Fin_Id
, Ref
);
7454 Param
=> New_Copy_Tree
(Ref
),
7455 Skip_Self
=> Skip_Self
);
7459 end Make_Final_Call
;
7461 --------------------------------
7462 -- Make_Finalize_Address_Body --
7463 --------------------------------
7465 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7466 Is_Task
: constant Boolean :=
7467 Ekind
(Typ
) = E_Record_Type
7468 and then Is_Concurrent_Record_Type
(Typ
)
7469 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7471 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7472 Proc_Id
: Entity_Id
;
7476 -- The corresponding records of task types are not controlled by design.
7477 -- For the sake of completeness, create an empty Finalize_Address to be
7478 -- used in task class-wide allocations.
7483 -- Nothing to do if the type is not controlled or it already has a
7484 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7485 -- come from source. These are usually generated for completeness and
7486 -- do not need the Finalize_Address primitive.
7488 elsif not Needs_Finalization
(Typ
)
7489 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7491 (Is_Class_Wide_Type
(Typ
)
7492 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7493 and then not Comes_From_Source
(Root_Type
(Typ
)))
7499 Make_Defining_Identifier
(Loc
,
7500 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7504 -- procedure <Typ>FD (V : System.Address) is
7506 -- null; -- for tasks
7508 -- declare -- for all other types
7509 -- type Pnn is access all Typ;
7510 -- for Pnn'Storage_Size use 0;
7512 -- [Deep_]Finalize (Pnn (V).all);
7517 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7519 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7523 Make_Subprogram_Body
(Loc
,
7525 Make_Procedure_Specification
(Loc
,
7526 Defining_Unit_Name
=> Proc_Id
,
7528 Parameter_Specifications
=> New_List
(
7529 Make_Parameter_Specification
(Loc
,
7530 Defining_Identifier
=>
7531 Make_Defining_Identifier
(Loc
, Name_V
),
7533 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7535 Declarations
=> No_List
,
7537 Handled_Statement_Sequence
=>
7538 Make_Handled_Sequence_Of_Statements
(Loc
,
7539 Statements
=> Stmts
)));
7541 Set_TSS
(Typ
, Proc_Id
);
7542 end Make_Finalize_Address_Body
;
7544 ---------------------------------
7545 -- Make_Finalize_Address_Stmts --
7546 ---------------------------------
7548 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7549 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7550 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7552 Desg_Typ
: Entity_Id
;
7556 if Is_Array_Type
(Typ
) then
7557 if Is_Constrained
(First_Subtype
(Typ
)) then
7558 Desg_Typ
:= First_Subtype
(Typ
);
7560 Desg_Typ
:= Base_Type
(Typ
);
7563 -- Class-wide types of constrained root types
7565 elsif Is_Class_Wide_Type
(Typ
)
7566 and then Has_Discriminants
(Root_Type
(Typ
))
7568 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7571 Parent_Typ
: Entity_Id
;
7574 -- Climb the parent type chain looking for a non-constrained type
7576 Parent_Typ
:= Root_Type
(Typ
);
7577 while Parent_Typ
/= Etype
(Parent_Typ
)
7578 and then Has_Discriminants
(Parent_Typ
)
7580 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7582 Parent_Typ
:= Etype
(Parent_Typ
);
7585 -- Handle views created for tagged types with unknown
7588 if Is_Underlying_Record_View
(Parent_Typ
) then
7589 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7592 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7602 -- type Ptr_Typ is access all Typ;
7603 -- for Ptr_Typ'Storage_Size use 0;
7606 Make_Full_Type_Declaration
(Loc
,
7607 Defining_Identifier
=> Ptr_Typ
,
7609 Make_Access_To_Object_Definition
(Loc
,
7610 All_Present
=> True,
7611 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7613 Make_Attribute_Definition_Clause
(Loc
,
7614 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7615 Chars
=> Name_Storage_Size
,
7616 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7618 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7620 -- Unconstrained arrays require special processing in order to retrieve
7621 -- the elements. To achieve this, we have to skip the dope vector which
7622 -- lays in front of the elements and then use a thin pointer to perform
7623 -- the address-to-access conversion.
7625 if Is_Array_Type
(Typ
)
7626 and then not Is_Constrained
(First_Subtype
(Typ
))
7629 Dope_Id
: Entity_Id
;
7632 -- Ensure that Ptr_Typ a thin pointer, generate:
7633 -- for Ptr_Typ'Size use System.Address'Size;
7636 Make_Attribute_Definition_Clause
(Loc
,
7637 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7640 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7643 -- Dnn : constant Storage_Offset :=
7644 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7646 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7649 Make_Object_Declaration
(Loc
,
7650 Defining_Identifier
=> Dope_Id
,
7651 Constant_Present
=> True,
7652 Object_Definition
=>
7653 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7655 Make_Op_Divide
(Loc
,
7657 Make_Attribute_Reference
(Loc
,
7658 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7659 Attribute_Name
=> Name_Descriptor_Size
),
7661 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7663 -- Shift the address from the start of the dope vector to the
7664 -- start of the elements:
7668 -- Note that this is done through a wrapper routine since RTSfind
7669 -- cannot retrieve operations with string names of the form "+".
7672 Make_Function_Call
(Loc
,
7674 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7675 Parameter_Associations
=> New_List
(
7677 New_Occurrence_Of
(Dope_Id
, Loc
)));
7681 -- Create the block and the finalization call
7684 Make_Block_Statement
(Loc
,
7685 Declarations
=> Decls
,
7687 Handled_Statement_Sequence
=>
7688 Make_Handled_Sequence_Of_Statements
(Loc
,
7689 Statements
=> New_List
(
7692 Make_Explicit_Dereference
(Loc
,
7693 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7694 Typ
=> Desg_Typ
)))));
7695 end Make_Finalize_Address_Stmts
;
7697 -------------------------------------
7698 -- Make_Handler_For_Ctrl_Operation --
7699 -------------------------------------
7703 -- when E : others =>
7704 -- Raise_From_Controlled_Operation (E);
7709 -- raise Program_Error [finalize raised exception];
7711 -- depending on whether Raise_From_Controlled_Operation is available
7713 function Make_Handler_For_Ctrl_Operation
7714 (Loc
: Source_Ptr
) return Node_Id
7717 -- Choice parameter (for the first case above)
7719 Raise_Node
: Node_Id
;
7720 -- Procedure call or raise statement
7723 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7724 -- it to Raise_From_Controlled_Operation so that the original exception
7725 -- name and message can be recorded in the exception message for
7728 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7729 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7731 Make_Procedure_Call_Statement
(Loc
,
7734 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7735 Parameter_Associations
=> New_List
(
7736 New_Occurrence_Of
(E_Occ
, Loc
)));
7738 -- Restricted run-time: exception messages are not supported
7743 Make_Raise_Program_Error
(Loc
,
7744 Reason
=> PE_Finalize_Raised_Exception
);
7748 Make_Implicit_Exception_Handler
(Loc
,
7749 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7750 Choice_Parameter
=> E_Occ
,
7751 Statements
=> New_List
(Raise_Node
));
7752 end Make_Handler_For_Ctrl_Operation
;
7754 --------------------
7755 -- Make_Init_Call --
7756 --------------------
7758 function Make_Init_Call
7760 Typ
: Entity_Id
) return Node_Id
7762 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7769 -- Deal with the type and object reference. Depending on the context, an
7770 -- object reference may need several conversions.
7772 if Is_Concurrent_Type
(Typ
) then
7774 Utyp
:= Corresponding_Record_Type
(Typ
);
7775 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7777 elsif Is_Private_Type
(Typ
)
7778 and then Present
(Full_View
(Typ
))
7779 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7782 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7783 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7791 Set_Assignment_OK
(Ref
);
7793 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7795 -- Deal with untagged derivation of private views
7797 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
7798 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7799 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7801 -- The following is to prevent problems with UC see 1.156 RH ???
7803 Set_Assignment_OK
(Ref
);
7806 -- If the underlying_type is a subtype, then we are dealing with the
7807 -- completion of a private type. We need to access the base type and
7808 -- generate a conversion to it.
7810 if Utyp
/= Base_Type
(Utyp
) then
7811 pragma Assert
(Is_Private_Type
(Typ
));
7812 Utyp
:= Base_Type
(Utyp
);
7813 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7816 -- Select the appropriate version of initialize
7818 if Has_Controlled_Component
(Utyp
) then
7819 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7821 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7822 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7825 -- The object reference may need another conversion depending on the
7826 -- type of the formal and that of the actual.
7828 Ref
:= Convert_View
(Proc
, Ref
);
7831 -- [Deep_]Initialize (Ref);
7834 Make_Procedure_Call_Statement
(Loc
,
7836 New_Occurrence_Of
(Proc
, Loc
),
7837 Parameter_Associations
=> New_List
(Ref
));
7840 ------------------------------
7841 -- Make_Local_Deep_Finalize --
7842 ------------------------------
7844 function Make_Local_Deep_Finalize
7846 Nam
: Entity_Id
) return Node_Id
7848 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7852 Formals
:= New_List
(
7856 Make_Parameter_Specification
(Loc
,
7857 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7859 Out_Present
=> True,
7860 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
7862 -- F : Boolean := True
7864 Make_Parameter_Specification
(Loc
,
7865 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7866 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7867 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
7869 -- Add the necessary number of counters to represent the initialization
7870 -- state of an object.
7873 Make_Subprogram_Body
(Loc
,
7875 Make_Procedure_Specification
(Loc
,
7876 Defining_Unit_Name
=> Nam
,
7877 Parameter_Specifications
=> Formals
),
7879 Declarations
=> No_List
,
7881 Handled_Statement_Sequence
=>
7882 Make_Handled_Sequence_Of_Statements
(Loc
,
7883 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7884 end Make_Local_Deep_Finalize
;
7886 ------------------------------------
7887 -- Make_Set_Finalize_Address_Call --
7888 ------------------------------------
7890 function Make_Set_Finalize_Address_Call
7892 Ptr_Typ
: Entity_Id
) return Node_Id
7894 -- It is possible for Ptr_Typ to be a partial view, if the access type
7895 -- is a full view declared in the private part of a nested package, and
7896 -- the finalization actions take place when completing analysis of the
7897 -- enclosing unit. For this reason use Underlying_Type twice below.
7899 Desig_Typ
: constant Entity_Id
:=
7901 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
7902 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
7903 Fin_Mas
: constant Entity_Id
:=
7904 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
7907 -- Both the finalization master and primitive Finalize_Address must be
7910 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
7913 -- Set_Finalize_Address
7914 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
7917 Make_Procedure_Call_Statement
(Loc
,
7919 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
7920 Parameter_Associations
=> New_List
(
7921 New_Occurrence_Of
(Fin_Mas
, Loc
),
7923 Make_Attribute_Reference
(Loc
,
7924 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
7925 Attribute_Name
=> Name_Unrestricted_Access
)));
7926 end Make_Set_Finalize_Address_Call
;
7928 --------------------------
7929 -- Make_Transient_Block --
7930 --------------------------
7932 function Make_Transient_Block
7935 Par
: Node_Id
) return Node_Id
7937 Decls
: constant List_Id
:= New_List
;
7938 Instrs
: constant List_Id
:= New_List
(Action
);
7943 -- Case where only secondary stack use is involved
7945 if VM_Target
= No_VM
7946 and then Uses_Sec_Stack
(Current_Scope
)
7947 and then Nkind
(Action
) /= N_Simple_Return_Statement
7948 and then Nkind
(Par
) /= N_Exception_Handler
7954 S
:= Scope
(Current_Scope
);
7956 -- At the outer level, no need to release the sec stack
7958 if S
= Standard_Standard
then
7959 Set_Uses_Sec_Stack
(Current_Scope
, False);
7962 -- In a function, only release the sec stack if the function
7963 -- does not return on the sec stack otherwise the result may
7964 -- be lost. The caller is responsible for releasing.
7966 elsif Ekind
(S
) = E_Function
then
7967 Set_Uses_Sec_Stack
(Current_Scope
, False);
7969 if not Requires_Transient_Scope
(Etype
(S
)) then
7970 Set_Uses_Sec_Stack
(S
, True);
7971 Check_Restriction
(No_Secondary_Stack
, Action
);
7976 -- In a loop or entry we should install a block encompassing
7977 -- all the construct. For now just release right away.
7979 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7982 -- In a procedure or a block, we release on exit of the
7983 -- procedure or block. ??? memory leak can be created by
7986 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7987 Set_Uses_Sec_Stack
(S
, True);
7988 Check_Restriction
(No_Secondary_Stack
, Action
);
7989 Set_Uses_Sec_Stack
(Current_Scope
, False);
7999 -- Create the transient block. Set the parent now since the block itself
8000 -- is not part of the tree. The current scope is the E_Block entity
8001 -- that has been pushed by Establish_Transient_Scope.
8003 pragma Assert
(Ekind
(Current_Scope
) = E_Block
);
8005 Make_Block_Statement
(Loc
,
8006 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
8007 Declarations
=> Decls
,
8008 Handled_Statement_Sequence
=>
8009 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8010 Has_Created_Identifier
=> True);
8011 Set_Parent
(Block
, Par
);
8013 -- Insert actions stuck in the transient scopes as well as all freezing
8014 -- nodes needed by those actions. Do not insert cleanup actions here,
8015 -- they will be transferred to the newly created block.
8017 Insert_Actions_In_Scope_Around
8018 (Action
, Clean
=> False, Manage_SS
=> False);
8020 Insert
:= Prev
(Action
);
8021 if Present
(Insert
) then
8022 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
8025 -- Transfer cleanup actions to the newly created block
8028 Cleanup_Actions
: List_Id
8029 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8030 Actions_To_Be_Wrapped
(Cleanup
);
8032 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8033 Cleanup_Actions
:= No_List
;
8036 -- When the transient scope was established, we pushed the entry for the
8037 -- transient scope onto the scope stack, so that the scope was active
8038 -- for the installation of finalizable entities etc. Now we must remove
8039 -- this entry, since we have constructed a proper block.
8044 end Make_Transient_Block
;
8046 ------------------------
8047 -- Node_To_Be_Wrapped --
8048 ------------------------
8050 function Node_To_Be_Wrapped
return Node_Id
is
8052 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8053 end Node_To_Be_Wrapped
;
8055 ----------------------------
8056 -- Set_Node_To_Be_Wrapped --
8057 ----------------------------
8059 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8061 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8062 end Set_Node_To_Be_Wrapped
;
8064 ----------------------------
8065 -- Store_Actions_In_Scope --
8066 ----------------------------
8068 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8069 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8070 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8073 if No
(Actions
) then
8076 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8077 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8079 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8084 elsif AK
= Before
then
8085 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8088 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8090 end Store_Actions_In_Scope
;
8092 ----------------------------------
8093 -- Store_After_Actions_In_Scope --
8094 ----------------------------------
8096 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8098 Store_Actions_In_Scope
(After
, L
);
8099 end Store_After_Actions_In_Scope
;
8101 -----------------------------------
8102 -- Store_Before_Actions_In_Scope --
8103 -----------------------------------
8105 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8107 Store_Actions_In_Scope
(Before
, L
);
8108 end Store_Before_Actions_In_Scope
;
8110 -----------------------------------
8111 -- Store_Cleanup_Actions_In_Scope --
8112 -----------------------------------
8114 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8116 Store_Actions_In_Scope
(Cleanup
, L
);
8117 end Store_Cleanup_Actions_In_Scope
;
8119 --------------------------------
8120 -- Wrap_Transient_Declaration --
8121 --------------------------------
8123 -- If a transient scope has been established during the processing of the
8124 -- Expression of an Object_Declaration, it is not possible to wrap the
8125 -- declaration into a transient block as usual case, otherwise the object
8126 -- would be itself declared in the wrong scope. Therefore, all entities (if
8127 -- any) defined in the transient block are moved to the proper enclosing
8128 -- scope. Furthermore, if they are controlled variables they are finalized
8129 -- right after the declaration. The finalization list of the transient
8130 -- scope is defined as a renaming of the enclosing one so during their
8131 -- initialization they will be attached to the proper finalization list.
8132 -- For instance, the following declaration :
8134 -- X : Typ := F (G (A), G (B));
8136 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8137 -- is expanded into :
8139 -- X : Typ := [ complex Expression-Action ];
8140 -- [Deep_]Finalize (_v1);
8141 -- [Deep_]Finalize (_v2);
8143 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8148 Curr_S
:= Current_Scope
;
8149 Encl_S
:= Scope
(Curr_S
);
8151 -- Insert all actions inluding cleanup generated while analyzing or
8152 -- expanding the transient context back into the tree. Manage the
8153 -- secondary stack when the object declaration appears in a library
8154 -- level package [body]. This is not needed for .NET/JVM as those do
8155 -- not support the secondary stack.
8157 Insert_Actions_In_Scope_Around
8162 and then Uses_Sec_Stack
(Curr_S
)
8163 and then Nkind
(N
) = N_Object_Declaration
8164 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8165 and then Is_Library_Level_Entity
(Encl_S
));
8168 -- Relocate local entities declared within the transient scope to the
8169 -- enclosing scope. This action sets their Is_Public flag accordingly.
8171 Transfer_Entities
(Curr_S
, Encl_S
);
8173 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8174 -- is properly released upon exiting the said scope. This is not needed
8175 -- for .NET/JVM as those do not support the secondary stack.
8177 if VM_Target
= No_VM
and then Uses_Sec_Stack
(Curr_S
) then
8178 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8180 -- Do not mark a function that returns on the secondary stack as the
8181 -- reclamation is done by the caller.
8183 if Ekind
(Curr_S
) = E_Function
8184 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8188 -- Otherwise mark the enclosing dynamic scope
8191 Set_Uses_Sec_Stack
(Curr_S
);
8192 Check_Restriction
(No_Secondary_Stack
, N
);
8195 end Wrap_Transient_Declaration
;
8197 -------------------------------
8198 -- Wrap_Transient_Expression --
8199 -------------------------------
8201 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8202 Loc
: constant Source_Ptr
:= Sloc
(N
);
8203 Expr
: Node_Id
:= Relocate_Node
(N
);
8204 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8205 Typ
: constant Entity_Id
:= Etype
(N
);
8212 -- M : constant Mark_Id := SS_Mark;
8213 -- procedure Finalizer is ... (See Build_Finalizer)
8216 -- Temp := <Expr>; -- general case
8217 -- Temp := (if <Expr> then True else False); -- boolean case
8223 -- A special case is made for Boolean expressions so that the back-end
8224 -- knows to generate a conditional branch instruction, if running with
8225 -- -fpreserve-control-flow. This ensures that a control flow change
8226 -- signalling the decision outcome occurs before the cleanup actions.
8228 if Opt
.Suppress_Control_Flow_Optimizations
8229 and then Is_Boolean_Type
(Typ
)
8232 Make_If_Expression
(Loc
,
8233 Expressions
=> New_List
(
8235 New_Occurrence_Of
(Standard_True
, Loc
),
8236 New_Occurrence_Of
(Standard_False
, Loc
)));
8239 Insert_Actions
(N
, New_List
(
8240 Make_Object_Declaration
(Loc
,
8241 Defining_Identifier
=> Temp
,
8242 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8244 Make_Transient_Block
(Loc
,
8246 Make_Assignment_Statement
(Loc
,
8247 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8248 Expression
=> Expr
),
8249 Par
=> Parent
(N
))));
8251 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8252 Analyze_And_Resolve
(N
, Typ
);
8253 end Wrap_Transient_Expression
;
8255 ------------------------------
8256 -- Wrap_Transient_Statement --
8257 ------------------------------
8259 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8260 Loc
: constant Source_Ptr
:= Sloc
(N
);
8261 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8266 -- M : constant Mark_Id := SS_Mark;
8267 -- procedure Finalizer is ... (See Build_Finalizer)
8277 Make_Transient_Block
(Loc
,
8279 Par
=> Parent
(N
)));
8281 -- With the scope stack back to normal, we can call analyze on the
8282 -- resulting block. At this point, the transient scope is being
8283 -- treated like a perfectly normal scope, so there is nothing
8284 -- special about it.
8286 -- Note: Wrap_Transient_Statement is called with the node already
8287 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8288 -- otherwise we would get a recursive processing of the node when
8289 -- we do this Analyze call.
8292 end Wrap_Transient_Statement
;