1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Nlists
; use Nlists
;
46 with Nmake
; use Nmake
;
48 with Output
; use Output
;
49 with Restrict
; use Restrict
;
50 with Rident
; use Rident
;
51 with Rtsfind
; use Rtsfind
;
52 with Sinfo
; use Sinfo
;
54 with Sem_Aux
; use Sem_Aux
;
55 with Sem_Ch3
; use Sem_Ch3
;
56 with Sem_Ch7
; use Sem_Ch7
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Util
; use Sem_Util
;
60 with Snames
; use Snames
;
61 with Stand
; use Stand
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Uintp
; use Uintp
;
67 package body Exp_Ch7
is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
129 -- N is a node which may generate a transient scope. Loop over the parent
130 -- pointers of N until it find the appropriate node to wrap. If it returns
131 -- Empty, it means that no transient scope is needed in this context.
133 procedure Insert_Actions_In_Scope_Around
136 Manage_SS
: Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
145 Par
: Node_Id
) return Node_Id
;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
230 -- Y : Controlled := Init;
236 -- Z : R := (C => X);
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
251 -- System.FI.Finalize_List (_L);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
287 type Final_Primitives
is
288 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
293 (Initialize_Case
=> Name_Initialize
,
294 Adjust_Case
=> Name_Adjust
,
295 Finalize_Case
=> Name_Finalize
,
296 Address_Case
=> Name_Finalize_Address
);
297 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
298 (Initialize_Case
=> TSS_Deep_Initialize
,
299 Adjust_Case
=> TSS_Deep_Adjust
,
300 Finalize_Case
=> TSS_Deep_Finalize
,
301 Address_Case
=> TSS_Finalize_Address
);
303 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
304 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
305 -- Has_Controlled_Component set and store them using the TSS mechanism.
307 function Build_Cleanup_Statements
309 Additional_Cleanup
: List_Id
) return List_Id
;
310 -- Create the clean up calls for an asynchronous call block, task master,
311 -- protected subprogram body, task allocation block or task body, or
312 -- additional cleanup actions parked on a transient block. If the context
313 -- does not contain the above constructs, the routine returns an empty
316 procedure Build_Finalizer
318 Clean_Stmts
: List_Id
;
321 Defer_Abort
: Boolean;
322 Fin_Id
: out Entity_Id
);
323 -- N may denote an accept statement, block, entry body, package body,
324 -- package spec, protected body, subprogram body, or a task body. Create
325 -- a procedure which contains finalization calls for all controlled objects
326 -- declared in the declarative or statement region of N. The calls are
327 -- built in reverse order relative to the original declarations. In the
328 -- case of a task body, the routine delays the creation of the finalizer
329 -- until all statements have been moved to the task body procedure.
330 -- Clean_Stmts may contain additional context-dependent code used to abort
331 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
332 -- Mark_Id is the secondary stack used in the current context or Empty if
333 -- missing. Top_Decls is the list on which the declaration of the finalizer
334 -- is attached in the non-package case. Defer_Abort indicates that the
335 -- statements passed in perform actions that require abort to be deferred,
336 -- such as for task termination. Fin_Id is the finalizer declaration
339 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
340 -- N is a construct which contains a handled sequence of statements, Fin_Id
341 -- is the entity of a finalizer. Create an At_End handler which covers the
342 -- statements of N and calls Fin_Id. If the handled statement sequence has
343 -- an exception handler, the statements will be wrapped in a block to avoid
344 -- unwanted interaction with the new At_End handler.
346 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
347 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
348 -- Has_Component_Component set and store them using the TSS mechanism.
350 procedure Check_Visibly_Controlled
351 (Prim
: Final_Primitives
;
353 E
: in out Entity_Id
;
354 Cref
: in out Node_Id
);
355 -- The controlled operation declared for a derived type may not be
356 -- overriding, if the controlled operations of the parent type are hidden,
357 -- for example when the parent is a private type whose full view is
358 -- controlled. For other primitive operations we modify the name of the
359 -- operation to indicate that it is not overriding, but this is not
360 -- possible for Initialize, etc. because they have to be retrievable by
361 -- name. Before generating the proper call to one of these operations we
362 -- check whether Typ is known to be controlled at the point of definition.
363 -- If it is not then we must retrieve the hidden operation of the parent
364 -- and use it instead. This is one case that might be solved more cleanly
365 -- once Overriding pragmas or declarations are in place.
367 function Convert_View
370 Ind
: Pos
:= 1) return Node_Id
;
371 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
372 -- argument being passed to it. Ind indicates which formal of procedure
373 -- Proc we are trying to match. This function will, if necessary, generate
374 -- a conversion between the partial and full view of Arg to match the type
375 -- of the formal of Proc, or force a conversion to the class-wide type in
376 -- the case where the operation is abstract.
378 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
379 -- Given an arbitrary entity, traverse the scope chain looking for the
380 -- first enclosing function. Return Empty if no function was found.
382 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
);
383 -- Subsidiary to the expansion of package specs and bodies. Generate a
384 -- runtime check needed to verify the assumption introduced by pragma
385 -- Initial_Condition. N denotes the package spec or body.
391 Skip_Self
: Boolean := False) return Node_Id
;
392 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
393 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
394 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
395 -- action has an effect on the components only (if any).
397 function Make_Deep_Proc
398 (Prim
: Final_Primitives
;
400 Stmts
: List_Id
) return Node_Id
;
401 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
402 -- Deep_Finalize procedures according to the first parameter, these
403 -- procedures operate on the type Typ. The Stmts parameter gives the body
406 function Make_Deep_Array_Body
407 (Prim
: Final_Primitives
;
408 Typ
: Entity_Id
) return List_Id
;
409 -- This function generates the list of statements for implementing
410 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
411 -- the first parameter, these procedures operate on the array type Typ.
413 function Make_Deep_Record_Body
414 (Prim
: Final_Primitives
;
416 Is_Local
: Boolean := False) return List_Id
;
417 -- This function generates the list of statements for implementing
418 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
419 -- the first parameter, these procedures operate on the record type Typ.
420 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
421 -- whether the inner logic should be dictated by state counters.
423 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
424 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
425 -- Make_Deep_Record_Body. Generate the following statements:
428 -- type Acc_Typ is access all Typ;
429 -- for Acc_Typ'Storage_Size use 0;
431 -- [Deep_]Finalize (Acc_Typ (V).all);
434 ----------------------------
435 -- Build_Array_Deep_Procs --
436 ----------------------------
438 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
442 (Prim
=> Initialize_Case
,
444 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
446 if not Is_Limited_View
(Typ
) then
449 (Prim
=> Adjust_Case
,
451 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
454 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
455 -- suppressed since these routine will not be used.
457 if not Restriction_Active
(No_Finalization
) then
460 (Prim
=> Finalize_Case
,
462 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
464 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
465 -- .NET do not support address arithmetic and unchecked conversions.
467 if VM_Target
= No_VM
then
470 (Prim
=> Address_Case
,
472 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
475 end Build_Array_Deep_Procs
;
477 ------------------------------
478 -- Build_Cleanup_Statements --
479 ------------------------------
481 function Build_Cleanup_Statements
483 Additional_Cleanup
: List_Id
) return List_Id
485 Is_Asynchronous_Call
: constant Boolean :=
486 Nkind
(N
) = N_Block_Statement
487 and then Is_Asynchronous_Call_Block
(N
);
488 Is_Master
: constant Boolean :=
489 Nkind
(N
) /= N_Entry_Body
490 and then Is_Task_Master
(N
);
491 Is_Protected_Body
: constant Boolean :=
492 Nkind
(N
) = N_Subprogram_Body
493 and then Is_Protected_Subprogram_Body
(N
);
494 Is_Task_Allocation
: constant Boolean :=
495 Nkind
(N
) = N_Block_Statement
496 and then Is_Task_Allocation_Block
(N
);
497 Is_Task_Body
: constant Boolean :=
498 Nkind
(Original_Node
(N
)) = N_Task_Body
;
500 Loc
: constant Source_Ptr
:= Sloc
(N
);
501 Stmts
: constant List_Id
:= New_List
;
505 if Restricted_Profile
then
507 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
509 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
513 if Restriction_Active
(No_Task_Hierarchy
) = False then
514 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
517 -- Add statements to unlock the protected object parameter and to
518 -- undefer abort. If the context is a protected procedure and the object
519 -- has entries, call the entry service routine.
521 -- NOTE: The generated code references _object, a parameter to the
524 elsif Is_Protected_Body
then
526 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
527 Conc_Typ
: Entity_Id
;
529 Param_Typ
: Entity_Id
;
532 -- Find the _object parameter representing the protected object
534 Param
:= First
(Parameter_Specifications
(Spec
));
536 Param_Typ
:= Etype
(Parameter_Type
(Param
));
538 if Ekind
(Param_Typ
) = E_Record_Type
then
539 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
542 exit when No
(Param
) or else Present
(Conc_Typ
);
546 pragma Assert
(Present
(Param
));
548 -- Historical note: In earlier versions of GNAT, there was code
549 -- at this point to generate stuff to service entry queues. It is
550 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
552 Build_Protected_Subprogram_Call_Cleanup
553 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
556 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
557 -- tasks. Other unactivated tasks are completed by Complete_Task or
560 -- NOTE: The generated code references _chain, a local object
562 elsif Is_Task_Allocation
then
565 -- Expunge_Unactivated_Tasks (_chain);
567 -- where _chain is the list of tasks created by the allocator but not
568 -- yet activated. This list will be empty unless the block completes
572 Make_Procedure_Call_Statement
(Loc
,
575 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
576 Parameter_Associations
=> New_List
(
577 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
579 -- Attempt to cancel an asynchronous entry call whenever the block which
580 -- contains the abortable part is exited.
582 -- NOTE: The generated code references Cnn, a local object
584 elsif Is_Asynchronous_Call
then
586 Cancel_Param
: constant Entity_Id
:=
587 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
590 -- If it is of type Communication_Block, this must be a protected
591 -- entry call. Generate:
593 -- if Enqueued (Cancel_Param) then
594 -- Cancel_Protected_Entry_Call (Cancel_Param);
597 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
599 Make_If_Statement
(Loc
,
601 Make_Function_Call
(Loc
,
603 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
604 Parameter_Associations
=> New_List
(
605 New_Occurrence_Of
(Cancel_Param
, Loc
))),
607 Then_Statements
=> New_List
(
608 Make_Procedure_Call_Statement
(Loc
,
611 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
612 Parameter_Associations
=> New_List
(
613 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
615 -- Asynchronous delay, generate:
616 -- Cancel_Async_Delay (Cancel_Param);
618 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
620 Make_Procedure_Call_Statement
(Loc
,
622 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
623 Parameter_Associations
=> New_List
(
624 Make_Attribute_Reference
(Loc
,
626 New_Occurrence_Of
(Cancel_Param
, Loc
),
627 Attribute_Name
=> Name_Unchecked_Access
))));
629 -- Task entry call, generate:
630 -- Cancel_Task_Entry_Call (Cancel_Param);
634 Make_Procedure_Call_Statement
(Loc
,
636 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
637 Parameter_Associations
=> New_List
(
638 New_Occurrence_Of
(Cancel_Param
, Loc
))));
643 Append_List_To
(Stmts
, Additional_Cleanup
);
645 end Build_Cleanup_Statements
;
647 -----------------------------
648 -- Build_Controlling_Procs --
649 -----------------------------
651 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
653 if Is_Array_Type
(Typ
) then
654 Build_Array_Deep_Procs
(Typ
);
655 else pragma Assert
(Is_Record_Type
(Typ
));
656 Build_Record_Deep_Procs
(Typ
);
658 end Build_Controlling_Procs
;
660 -----------------------------
661 -- Build_Exception_Handler --
662 -----------------------------
664 function Build_Exception_Handler
665 (Data
: Finalization_Exception_Data
;
666 For_Library
: Boolean := False) return Node_Id
669 Proc_To_Call
: Entity_Id
;
674 pragma Assert
(Present
(Data
.Raised_Id
));
676 if Exception_Extra_Info
677 or else (For_Library
and not Restricted_Profile
)
679 if Exception_Extra_Info
then
683 -- Get_Current_Excep.all
686 Make_Function_Call
(Data
.Loc
,
688 Make_Explicit_Dereference
(Data
.Loc
,
691 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
698 Except
:= Make_Null
(Data
.Loc
);
701 if For_Library
and then not Restricted_Profile
then
702 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
703 Actuals
:= New_List
(Except
);
706 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
708 -- The dereference occurs only when Exception_Extra_Info is true,
709 -- and therefore Except is not null.
713 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
714 Make_Explicit_Dereference
(Data
.Loc
, Except
));
720 -- if not Raised_Id then
721 -- Raised_Id := True;
723 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
725 -- Save_Library_Occurrence (Get_Current_Excep.all);
730 Make_If_Statement
(Data
.Loc
,
732 Make_Op_Not
(Data
.Loc
,
733 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
735 Then_Statements
=> New_List
(
736 Make_Assignment_Statement
(Data
.Loc
,
737 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
738 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
740 Make_Procedure_Call_Statement
(Data
.Loc
,
742 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
743 Parameter_Associations
=> Actuals
))));
748 -- Raised_Id := True;
751 Make_Assignment_Statement
(Data
.Loc
,
752 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
753 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
761 Make_Exception_Handler
(Data
.Loc
,
762 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
763 Statements
=> Stmts
);
764 end Build_Exception_Handler
;
766 -------------------------------
767 -- Build_Finalization_Master --
768 -------------------------------
770 procedure Build_Finalization_Master
772 Ins_Node
: Node_Id
:= Empty
;
773 Encl_Scope
: Entity_Id
:= Empty
)
775 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
776 -- Determine whether entity E is inside a wrapper package created for
777 -- an instance of Ada.Unchecked_Deallocation.
779 ------------------------------
780 -- In_Deallocation_Instance --
781 ------------------------------
783 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
784 Pkg
: constant Entity_Id
:= Scope
(E
);
785 Par
: Node_Id
:= Empty
;
788 if Ekind
(Pkg
) = E_Package
789 and then Present
(Related_Instance
(Pkg
))
790 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
792 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
796 and then Chars
(Par
) = Name_Unchecked_Deallocation
797 and then Chars
(Scope
(Par
)) = Name_Ada
798 and then Scope
(Scope
(Par
)) = Standard_Standard
;
802 end In_Deallocation_Instance
;
806 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
808 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
809 -- A finalization master created for a named access type is associated
810 -- with the full view (if applicable) as a consequence of freezing. The
811 -- full view criteria does not apply to anonymous access types because
812 -- those cannot have a private and a full view.
814 -- Start of processing for Build_Finalization_Master
817 -- Certain run-time configurations and targets do not provide support
818 -- for controlled types.
820 if Restriction_Active
(No_Finalization
) then
823 -- Do not process C, C++, CIL and Java types since it is assumend that
824 -- the non-Ada side will handle their clean up.
826 elsif Convention
(Desig_Typ
) = Convention_C
827 or else Convention
(Desig_Typ
) = Convention_CIL
828 or else Convention
(Desig_Typ
) = Convention_CPP
829 or else Convention
(Desig_Typ
) = Convention_Java
833 -- Various machinery such as freezing may have already created a
834 -- finalization master.
836 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
839 -- Do not process types that return on the secondary stack
841 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
842 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
846 -- Do not process types which may never allocate an object
848 elsif No_Pool_Assigned
(Ptr_Typ
) then
851 -- Do not process access types coming from Ada.Unchecked_Deallocation
852 -- instances. Even though the designated type may be controlled, the
853 -- access type will never participate in allocation.
855 elsif In_Deallocation_Instance
(Ptr_Typ
) then
858 -- Ignore the general use of anonymous access types unless the context
859 -- requires a finalization master.
861 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
862 and then No
(Ins_Node
)
866 -- Do not process non-library access types when restriction No_Nested_
867 -- Finalization is in effect since masters are controlled objects.
869 elsif Restriction_Active
(No_Nested_Finalization
)
870 and then not Is_Library_Level_Entity
(Ptr_Typ
)
874 -- For .NET/JVM targets, allow the processing of access-to-controlled
875 -- types where the designated type is explicitly derived from [Limited_]
878 elsif VM_Target
/= No_VM
and then not Is_Controlled
(Desig_Typ
) then
881 -- Do not create finalization masters in SPARK mode because they result
882 -- in unwanted expansion.
884 -- More detail would be useful here ???
886 elsif GNATprove_Mode
then
891 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
892 Actions
: constant List_Id
:= New_List
;
893 Fin_Mas_Id
: Entity_Id
;
898 -- Fnn : aliased Finalization_Master;
900 -- Source access types use fixed master names since the master is
901 -- inserted in the same source unit only once. The only exception to
902 -- this are instances using the same access type as generic actual.
904 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
906 Make_Defining_Identifier
(Loc
,
907 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
909 -- Internally generated access types use temporaries as their names
910 -- due to possible collision with identical names coming from other
914 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
918 Make_Object_Declaration
(Loc
,
919 Defining_Identifier
=> Fin_Mas_Id
,
920 Aliased_Present
=> True,
922 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
924 -- Storage pool selection and attribute decoration of the generated
925 -- master. Since .NET/JVM compilers do not support pools, this step
928 if VM_Target
= No_VM
then
930 -- If the access type has a user-defined pool, use it as the base
931 -- storage medium for the finalization pool.
933 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
934 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
936 -- The default choice is the global pool
939 Pool_Id
:= Get_Global_Pool_For_Access_Type
(Ptr_Typ
);
940 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
944 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
947 Make_Procedure_Call_Statement
(Loc
,
949 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
950 Parameter_Associations
=> New_List
(
951 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
952 Make_Attribute_Reference
(Loc
,
953 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
954 Attribute_Name
=> Name_Unrestricted_Access
))));
957 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
959 -- A finalization master created for an anonymous access type must be
960 -- inserted before a context-dependent node.
962 if Present
(Ins_Node
) then
963 Push_Scope
(Encl_Scope
);
965 -- Treat use clauses as declarations and insert directly in front
968 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
971 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
973 Insert_Actions
(Ins_Node
, Actions
);
978 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
979 and then Has_Completion_In_Body
(Desig_Typ
)
981 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
983 -- If the designated type is not yet frozen, then append the actions
984 -- to that type's freeze actions. The actions need to be appended to
985 -- whichever type is frozen later, similarly to what Freeze_Type does
986 -- for appending the storage pool declaration for an access type.
987 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
988 -- pool object before it's declared. However, it's not clear that
989 -- this is exactly the right test to accomplish that here. ???
991 elsif Present
(Freeze_Node
(Desig_Typ
))
992 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
994 Append_Freeze_Actions
(Desig_Typ
, Actions
);
996 elsif Present
(Freeze_Node
(Ptr_Typ
))
997 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
999 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1001 -- If there's a pool created locally for the access type, then we
1002 -- need to ensure that the master gets created after the pool object,
1003 -- because otherwise we can have a forward reference, so we force the
1004 -- master actions to be inserted and analyzed after the pool entity.
1005 -- Note that both the access type and its designated type may have
1006 -- already been frozen and had their freezing actions analyzed at
1007 -- this point. (This seems a little unclean.???)
1009 elsif VM_Target
= No_VM
1010 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1012 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1015 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1018 end Build_Finalization_Master
;
1020 ---------------------
1021 -- Build_Finalizer --
1022 ---------------------
1024 procedure Build_Finalizer
1026 Clean_Stmts
: List_Id
;
1027 Mark_Id
: Entity_Id
;
1028 Top_Decls
: List_Id
;
1029 Defer_Abort
: Boolean;
1030 Fin_Id
: out Entity_Id
)
1032 Acts_As_Clean
: constant Boolean :=
1035 (Present
(Clean_Stmts
)
1036 and then Is_Non_Empty_List
(Clean_Stmts
));
1037 Exceptions_OK
: constant Boolean :=
1038 not Restriction_Active
(No_Exception_Propagation
);
1039 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1040 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1041 For_Package
: constant Boolean :=
1042 For_Package_Body
or else For_Package_Spec
;
1043 Loc
: constant Source_Ptr
:= Sloc
(N
);
1045 -- NOTE: Local variable declarations are conservative and do not create
1046 -- structures right from the start. Entities and lists are created once
1047 -- it has been established that N has at least one controlled object.
1049 Components_Built
: Boolean := False;
1050 -- A flag used to avoid double initialization of entities and lists. If
1051 -- the flag is set then the following variables have been initialized:
1057 Counter_Id
: Entity_Id
:= Empty
;
1058 Counter_Val
: Int
:= 0;
1059 -- Name and value of the state counter
1061 Decls
: List_Id
:= No_List
;
1062 -- Declarative region of N (if available). If N is a package declaration
1063 -- Decls denotes the visible declarations.
1065 Finalizer_Data
: Finalization_Exception_Data
;
1066 -- Data for the exception
1068 Finalizer_Decls
: List_Id
:= No_List
;
1069 -- Local variable declarations. This list holds the label declarations
1070 -- of all jump block alternatives as well as the declaration of the
1071 -- local exception occurence and the raised flag:
1072 -- E : Exception_Occurrence;
1073 -- Raised : Boolean := False;
1074 -- L<counter value> : label;
1076 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1077 -- Insertion point for the finalizer body. Depending on the context
1078 -- (Nkind of N) and the individual grouping of controlled objects, this
1079 -- node may denote a package declaration or body, package instantiation,
1080 -- block statement or a counter update statement.
1082 Finalizer_Stmts
: List_Id
:= No_List
;
1083 -- The statement list of the finalizer body. It contains the following:
1085 -- Abort_Defer; -- Added if abort is allowed
1086 -- <call to Prev_At_End> -- Added if exists
1087 -- <cleanup statements> -- Added if Acts_As_Clean
1088 -- <jump block> -- Added if Has_Ctrl_Objs
1089 -- <finalization statements> -- Added if Has_Ctrl_Objs
1090 -- <stack release> -- Added if Mark_Id exists
1091 -- Abort_Undefer; -- Added if abort is allowed
1093 Has_Ctrl_Objs
: Boolean := False;
1094 -- A general flag which denotes whether N has at least one controlled
1097 Has_Tagged_Types
: Boolean := False;
1098 -- A general flag which indicates whether N has at least one library-
1099 -- level tagged type declaration.
1101 HSS
: Node_Id
:= Empty
;
1102 -- The sequence of statements of N (if available)
1104 Jump_Alts
: List_Id
:= No_List
;
1105 -- Jump block alternatives. Depending on the value of the state counter,
1106 -- the control flow jumps to a sequence of finalization statements. This
1107 -- list contains the following:
1109 -- when <counter value> =>
1110 -- goto L<counter value>;
1112 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1113 -- Specific point in the finalizer statements where the jump block is
1116 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1117 -- The last controlled construct encountered when processing the top
1118 -- level lists of N. This can be a nested package, an instantiation or
1119 -- an object declaration.
1121 Prev_At_End
: Entity_Id
:= Empty
;
1122 -- The previous at end procedure of the handled statements block of N
1124 Priv_Decls
: List_Id
:= No_List
;
1125 -- The private declarations of N if N is a package declaration
1127 Spec_Id
: Entity_Id
:= Empty
;
1128 Spec_Decls
: List_Id
:= Top_Decls
;
1129 Stmts
: List_Id
:= No_List
;
1131 Tagged_Type_Stmts
: List_Id
:= No_List
;
1132 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1133 -- tagged types found in N.
1135 -----------------------
1136 -- Local subprograms --
1137 -----------------------
1139 procedure Build_Components
;
1140 -- Create all entites and initialize all lists used in the creation of
1143 procedure Create_Finalizer
;
1144 -- Create the spec and body of the finalizer and insert them in the
1145 -- proper place in the tree depending on the context.
1147 procedure Process_Declarations
1149 Preprocess
: Boolean := False;
1150 Top_Level
: Boolean := False);
1151 -- Inspect a list of declarations or statements which may contain
1152 -- objects that need finalization. When flag Preprocess is set, the
1153 -- routine will simply count the total number of controlled objects in
1154 -- Decls. Flag Top_Level denotes whether the processing is done for
1155 -- objects in nested package declarations or instances.
1157 procedure Process_Object_Declaration
1159 Has_No_Init
: Boolean := False;
1160 Is_Protected
: Boolean := False);
1161 -- Generate all the machinery associated with the finalization of a
1162 -- single object. Flag Has_No_Init is used to denote certain contexts
1163 -- where Decl does not have initialization call(s). Flag Is_Protected
1164 -- is set when Decl denotes a simple protected object.
1166 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1167 -- Generate all the code necessary to unregister the external tag of a
1170 ----------------------
1171 -- Build_Components --
1172 ----------------------
1174 procedure Build_Components
is
1175 Counter_Decl
: Node_Id
;
1176 Counter_Typ
: Entity_Id
;
1177 Counter_Typ_Decl
: Node_Id
;
1180 pragma Assert
(Present
(Decls
));
1182 -- This routine might be invoked several times when dealing with
1183 -- constructs that have two lists (either two declarative regions
1184 -- or declarations and statements). Avoid double initialization.
1186 if Components_Built
then
1190 Components_Built
:= True;
1192 if Has_Ctrl_Objs
then
1194 -- Create entities for the counter, its type, the local exception
1195 -- and the raised flag.
1197 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1198 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1200 Finalizer_Decls
:= New_List
;
1202 Build_Object_Declarations
1203 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1205 -- Since the total number of controlled objects is always known,
1206 -- build a subtype of Natural with precise bounds. This allows
1207 -- the backend to optimize the case statement. Generate:
1209 -- subtype Tnn is Natural range 0 .. Counter_Val;
1212 Make_Subtype_Declaration
(Loc
,
1213 Defining_Identifier
=> Counter_Typ
,
1214 Subtype_Indication
=>
1215 Make_Subtype_Indication
(Loc
,
1216 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1218 Make_Range_Constraint
(Loc
,
1222 Make_Integer_Literal
(Loc
, Uint_0
),
1224 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1226 -- Generate the declaration of the counter itself:
1228 -- Counter : Integer := 0;
1231 Make_Object_Declaration
(Loc
,
1232 Defining_Identifier
=> Counter_Id
,
1233 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1234 Expression
=> Make_Integer_Literal
(Loc
, 0));
1236 -- Set the type of the counter explicitly to prevent errors when
1237 -- examining object declarations later on.
1239 Set_Etype
(Counter_Id
, Counter_Typ
);
1241 -- The counter and its type are inserted before the source
1242 -- declarations of N.
1244 Prepend_To
(Decls
, Counter_Decl
);
1245 Prepend_To
(Decls
, Counter_Typ_Decl
);
1247 -- The counter and its associated type must be manually analized
1248 -- since N has already been analyzed. Use the scope of the spec
1249 -- when inserting in a package.
1252 Push_Scope
(Spec_Id
);
1253 Analyze
(Counter_Typ_Decl
);
1254 Analyze
(Counter_Decl
);
1258 Analyze
(Counter_Typ_Decl
);
1259 Analyze
(Counter_Decl
);
1262 Jump_Alts
:= New_List
;
1265 -- If the context requires additional clean up, the finalization
1266 -- machinery is added after the clean up code.
1268 if Acts_As_Clean
then
1269 Finalizer_Stmts
:= Clean_Stmts
;
1270 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1272 Finalizer_Stmts
:= New_List
;
1275 if Has_Tagged_Types
then
1276 Tagged_Type_Stmts
:= New_List
;
1278 end Build_Components
;
1280 ----------------------
1281 -- Create_Finalizer --
1282 ----------------------
1284 procedure Create_Finalizer
is
1285 Body_Id
: Entity_Id
;
1288 Jump_Block
: Node_Id
;
1290 Label_Id
: Entity_Id
;
1292 function New_Finalizer_Name
return Name_Id
;
1293 -- Create a fully qualified name of a package spec or body finalizer.
1294 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1296 ------------------------
1297 -- New_Finalizer_Name --
1298 ------------------------
1300 function New_Finalizer_Name
return Name_Id
is
1301 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1302 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1303 -- has a non-standard scope, process the scope first.
1305 ------------------------
1306 -- New_Finalizer_Name --
1307 ------------------------
1309 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1311 if Scope
(Id
) = Standard_Standard
then
1312 Get_Name_String
(Chars
(Id
));
1315 New_Finalizer_Name
(Scope
(Id
));
1316 Add_Str_To_Name_Buffer
("__");
1317 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1319 end New_Finalizer_Name
;
1321 -- Start of processing for New_Finalizer_Name
1324 -- Create the fully qualified name of the enclosing scope
1326 New_Finalizer_Name
(Spec_Id
);
1329 -- __finalize_[spec|body]
1331 Add_Str_To_Name_Buffer
("__finalize_");
1333 if For_Package_Spec
then
1334 Add_Str_To_Name_Buffer
("spec");
1336 Add_Str_To_Name_Buffer
("body");
1340 end New_Finalizer_Name
;
1342 -- Start of processing for Create_Finalizer
1345 -- Step 1: Creation of the finalizer name
1347 -- Packages must use a distinct name for their finalizers since the
1348 -- binder will have to generate calls to them by name. The name is
1349 -- of the following form:
1351 -- xx__yy__finalize_[spec|body]
1354 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1355 Set_Has_Qualified_Name
(Fin_Id
);
1356 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1358 -- The default name is _finalizer
1362 Make_Defining_Identifier
(Loc
,
1363 Chars
=> New_External_Name
(Name_uFinalizer
));
1365 -- The visibility semantics of AT_END handlers force a strange
1366 -- separation of spec and body for stack-related finalizers:
1368 -- declare : Enclosing_Scope
1369 -- procedure _finalizer;
1371 -- <controlled objects>
1372 -- procedure _finalizer is
1378 -- Both spec and body are within the same construct and scope, but
1379 -- the body is part of the handled sequence of statements. This
1380 -- placement confuses the elaboration mechanism on targets where
1381 -- AT_END handlers are expanded into "when all others" handlers:
1384 -- when all others =>
1385 -- _finalizer; -- appears to require elab checks
1390 -- Since the compiler guarantees that the body of a _finalizer is
1391 -- always inserted in the same construct where the AT_END handler
1392 -- resides, there is no need for elaboration checks.
1394 Set_Kill_Elaboration_Checks
(Fin_Id
);
1397 -- Step 2: Creation of the finalizer specification
1400 -- procedure Fin_Id;
1403 Make_Subprogram_Declaration
(Loc
,
1405 Make_Procedure_Specification
(Loc
,
1406 Defining_Unit_Name
=> Fin_Id
));
1408 -- Step 3: Creation of the finalizer body
1410 if Has_Ctrl_Objs
then
1412 -- Add L0, the default destination to the jump block
1414 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1415 Set_Entity
(Label_Id
,
1416 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1417 Label
:= Make_Label
(Loc
, Label_Id
);
1422 Prepend_To
(Finalizer_Decls
,
1423 Make_Implicit_Label_Declaration
(Loc
,
1424 Defining_Identifier
=> Entity
(Label_Id
),
1425 Label_Construct
=> Label
));
1431 Append_To
(Jump_Alts
,
1432 Make_Case_Statement_Alternative
(Loc
,
1433 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1434 Statements
=> New_List
(
1435 Make_Goto_Statement
(Loc
,
1436 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1441 Append_To
(Finalizer_Stmts
, Label
);
1443 -- Create the jump block which controls the finalization flow
1444 -- depending on the value of the state counter.
1447 Make_Case_Statement
(Loc
,
1448 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1449 Alternatives
=> Jump_Alts
);
1451 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1452 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1454 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1458 -- Add the library-level tagged type unregistration machinery before
1459 -- the jump block circuitry. This ensures that external tags will be
1460 -- removed even if a finalization exception occurs at some point.
1462 if Has_Tagged_Types
then
1463 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1466 -- Add a call to the previous At_End handler if it exists. The call
1467 -- must always precede the jump block.
1469 if Present
(Prev_At_End
) then
1470 Prepend_To
(Finalizer_Stmts
,
1471 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1473 -- Clear the At_End handler since we have already generated the
1474 -- proper replacement call for it.
1476 Set_At_End_Proc
(HSS
, Empty
);
1479 -- Release the secondary stack mark
1481 if Present
(Mark_Id
) then
1482 Append_To
(Finalizer_Stmts
, Build_SS_Release_Call
(Loc
, Mark_Id
));
1485 -- Protect the statements with abort defer/undefer. This is only when
1486 -- aborts are allowed and the clean up statements require deferral or
1487 -- there are controlled objects to be finalized.
1489 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1490 Prepend_To
(Finalizer_Stmts
,
1491 Make_Procedure_Call_Statement
(Loc
,
1492 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Defer
), Loc
)));
1494 Append_To
(Finalizer_Stmts
,
1495 Make_Procedure_Call_Statement
(Loc
,
1496 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Undefer
), Loc
)));
1499 -- The local exception does not need to be reraised for library-level
1500 -- finalizers. Note that this action must be carried out after object
1501 -- clean up, secondary stack release and abort undeferral. Generate:
1503 -- if Raised and then not Abort then
1504 -- Raise_From_Controlled_Operation (E);
1507 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1508 Append_To
(Finalizer_Stmts
,
1509 Build_Raise_Statement
(Finalizer_Data
));
1513 -- procedure Fin_Id is
1514 -- Abort : constant Boolean := Triggered_By_Abort;
1516 -- Abort : constant Boolean := False; -- no abort
1518 -- E : Exception_Occurrence; -- All added if flag
1519 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1525 -- Abort_Defer; -- Added if abort is allowed
1526 -- <call to Prev_At_End> -- Added if exists
1527 -- <cleanup statements> -- Added if Acts_As_Clean
1528 -- <jump block> -- Added if Has_Ctrl_Objs
1529 -- <finalization statements> -- Added if Has_Ctrl_Objs
1530 -- <stack release> -- Added if Mark_Id exists
1531 -- Abort_Undefer; -- Added if abort is allowed
1532 -- <exception propagation> -- Added if Has_Ctrl_Objs
1535 -- Create the body of the finalizer
1537 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1540 Set_Has_Qualified_Name
(Body_Id
);
1541 Set_Has_Fully_Qualified_Name
(Body_Id
);
1545 Make_Subprogram_Body
(Loc
,
1547 Make_Procedure_Specification
(Loc
,
1548 Defining_Unit_Name
=> Body_Id
),
1549 Declarations
=> Finalizer_Decls
,
1550 Handled_Statement_Sequence
=>
1551 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1553 -- Step 4: Spec and body insertion, analysis
1557 -- If the package spec has private declarations, the finalizer
1558 -- body must be added to the end of the list in order to have
1559 -- visibility of all private controlled objects.
1561 if For_Package_Spec
then
1562 if Present
(Priv_Decls
) then
1563 Append_To
(Priv_Decls
, Fin_Spec
);
1564 Append_To
(Priv_Decls
, Fin_Body
);
1566 Append_To
(Decls
, Fin_Spec
);
1567 Append_To
(Decls
, Fin_Body
);
1570 -- For package bodies, both the finalizer spec and body are
1571 -- inserted at the end of the package declarations.
1574 Append_To
(Decls
, Fin_Spec
);
1575 Append_To
(Decls
, Fin_Body
);
1578 -- Push the name of the package
1580 Push_Scope
(Spec_Id
);
1588 -- Create the spec for the finalizer. The At_End handler must be
1589 -- able to call the body which resides in a nested structure.
1593 -- procedure Fin_Id; -- Spec
1595 -- <objects and possibly statements>
1596 -- procedure Fin_Id is ... -- Body
1599 -- Fin_Id; -- At_End handler
1602 pragma Assert
(Present
(Spec_Decls
));
1604 Append_To
(Spec_Decls
, Fin_Spec
);
1607 -- When the finalizer acts solely as a clean up routine, the body
1608 -- is inserted right after the spec.
1610 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1611 Insert_After
(Fin_Spec
, Fin_Body
);
1613 -- In all other cases the body is inserted after either:
1615 -- 1) The counter update statement of the last controlled object
1616 -- 2) The last top level nested controlled package
1617 -- 3) The last top level controlled instantiation
1620 -- Manually freeze the spec. This is somewhat of a hack because
1621 -- a subprogram is frozen when its body is seen and the freeze
1622 -- node appears right before the body. However, in this case,
1623 -- the spec must be frozen earlier since the At_End handler
1624 -- must be able to call it.
1627 -- procedure Fin_Id; -- Spec
1628 -- [Fin_Id] -- Freeze node
1632 -- Fin_Id; -- At_End handler
1635 Ensure_Freeze_Node
(Fin_Id
);
1636 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1637 Set_Is_Frozen
(Fin_Id
);
1639 -- In the case where the last construct to contain a controlled
1640 -- object is either a nested package, an instantiation or a
1641 -- freeze node, the body must be inserted directly after the
1644 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1646 N_Package_Declaration
,
1649 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1652 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1657 end Create_Finalizer
;
1659 --------------------------
1660 -- Process_Declarations --
1661 --------------------------
1663 procedure Process_Declarations
1665 Preprocess
: Boolean := False;
1666 Top_Level
: Boolean := False)
1671 Obj_Typ
: Entity_Id
;
1672 Pack_Id
: Entity_Id
;
1676 Old_Counter_Val
: Int
;
1677 -- This variable is used to determine whether a nested package or
1678 -- instance contains at least one controlled object.
1680 procedure Processing_Actions
1681 (Has_No_Init
: Boolean := False;
1682 Is_Protected
: Boolean := False);
1683 -- Depending on the mode of operation of Process_Declarations, either
1684 -- increment the controlled object counter, set the controlled object
1685 -- flag and store the last top level construct or process the current
1686 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1687 -- the current declaration may not have initialization proc(s). Flag
1688 -- Is_Protected should be set when the current declaration denotes a
1689 -- simple protected object.
1691 ------------------------
1692 -- Processing_Actions --
1693 ------------------------
1695 procedure Processing_Actions
1696 (Has_No_Init
: Boolean := False;
1697 Is_Protected
: Boolean := False)
1700 -- Library-level tagged type
1702 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1704 Has_Tagged_Types
:= True;
1706 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1707 Last_Top_Level_Ctrl_Construct
:= Decl
;
1711 Process_Tagged_Type_Declaration
(Decl
);
1714 -- Controlled object declaration
1718 Counter_Val
:= Counter_Val
+ 1;
1719 Has_Ctrl_Objs
:= True;
1721 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
1722 Last_Top_Level_Ctrl_Construct
:= Decl
;
1726 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1729 end Processing_Actions
;
1731 -- Start of processing for Process_Declarations
1734 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1738 -- Process all declarations in reverse order
1740 Decl
:= Last_Non_Pragma
(Decls
);
1741 while Present
(Decl
) loop
1743 -- Library-level tagged types
1745 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1746 Typ
:= Defining_Identifier
(Decl
);
1748 if Is_Tagged_Type
(Typ
)
1749 and then Is_Library_Level_Entity
(Typ
)
1750 and then Convention
(Typ
) = Convention_Ada
1751 and then Present
(Access_Disp_Table
(Typ
))
1752 and then RTE_Available
(RE_Register_Tag
)
1753 and then not No_Run_Time_Mode
1754 and then not Is_Abstract_Type
(Typ
)
1759 -- Regular object declarations
1761 elsif Nkind
(Decl
) = N_Object_Declaration
then
1762 Obj_Id
:= Defining_Identifier
(Decl
);
1763 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1764 Expr
:= Expression
(Decl
);
1766 -- Bypass any form of processing for objects which have their
1767 -- finalization disabled. This applies only to objects at the
1770 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1773 -- Transient variables are treated separately in order to
1774 -- minimize the size of the generated code. For details, see
1775 -- Process_Transient_Objects.
1777 elsif Is_Processed_Transient
(Obj_Id
) then
1780 -- The object is of the form:
1781 -- Obj : Typ [:= Expr];
1783 -- Do not process the incomplete view of a deferred constant.
1784 -- Do not consider tag-to-class-wide conversions.
1786 elsif not Is_Imported
(Obj_Id
)
1787 and then Needs_Finalization
(Obj_Typ
)
1788 and then not (Ekind
(Obj_Id
) = E_Constant
1789 and then not Has_Completion
(Obj_Id
))
1790 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1794 -- The object is of the form:
1795 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1797 -- Obj : Access_Typ :=
1798 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1800 elsif Is_Access_Type
(Obj_Typ
)
1801 and then Needs_Finalization
1802 (Available_View
(Designated_Type
(Obj_Typ
)))
1803 and then Present
(Expr
)
1805 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1807 (Is_Non_BIP_Func_Call
(Expr
)
1808 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1810 Processing_Actions
(Has_No_Init
=> True);
1812 -- Processing for "hook" objects generated for controlled
1813 -- transients declared inside an Expression_With_Actions.
1815 elsif Is_Access_Type
(Obj_Typ
)
1816 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1817 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1818 N_Object_Declaration
1820 Processing_Actions
(Has_No_Init
=> True);
1822 -- Process intermediate results of an if expression with one
1823 -- of the alternatives using a controlled function call.
1825 elsif Is_Access_Type
(Obj_Typ
)
1826 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1827 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1828 N_Defining_Identifier
1829 and then Present
(Expr
)
1830 and then Nkind
(Expr
) = N_Null
1832 Processing_Actions
(Has_No_Init
=> True);
1834 -- Simple protected objects which use type System.Tasking.
1835 -- Protected_Objects.Protection to manage their locks should
1836 -- be treated as controlled since they require manual cleanup.
1837 -- The only exception is illustrated in the following example:
1840 -- type Ctrl is new Controlled ...
1841 -- procedure Finalize (Obj : in out Ctrl);
1845 -- package body Pkg is
1846 -- protected Prot is
1847 -- procedure Do_Something (Obj : in out Ctrl);
1850 -- protected body Prot is
1851 -- procedure Do_Something (Obj : in out Ctrl) is ...
1854 -- procedure Finalize (Obj : in out Ctrl) is
1856 -- Prot.Do_Something (Obj);
1860 -- Since for the most part entities in package bodies depend on
1861 -- those in package specs, Prot's lock should be cleaned up
1862 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1863 -- This act however attempts to invoke Do_Something and fails
1864 -- because the lock has disappeared.
1866 elsif Ekind
(Obj_Id
) = E_Variable
1867 and then not In_Library_Level_Package_Body
(Obj_Id
)
1868 and then (Is_Simple_Protected_Type
(Obj_Typ
)
1869 or else Has_Simple_Protected_Object
(Obj_Typ
))
1871 Processing_Actions
(Is_Protected
=> True);
1874 -- Specific cases of object renamings
1876 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1877 Obj_Id
:= Defining_Identifier
(Decl
);
1878 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1880 -- Bypass any form of processing for objects which have their
1881 -- finalization disabled. This applies only to objects at the
1884 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
1887 -- Return object of a build-in-place function. This case is
1888 -- recognized and marked by the expansion of an extended return
1889 -- statement (see Expand_N_Extended_Return_Statement).
1891 elsif Needs_Finalization
(Obj_Typ
)
1892 and then Is_Return_Object
(Obj_Id
)
1893 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1895 Processing_Actions
(Has_No_Init
=> True);
1897 -- Detect a case where a source object has been initialized by
1898 -- a controlled function call or another object which was later
1899 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1901 -- Obj1 : CW_Type := Src_Obj;
1902 -- Obj2 : CW_Type := Function_Call (...);
1904 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1905 -- Tmp : ... := Function_Call (...)'reference;
1906 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1908 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1909 Processing_Actions
(Has_No_Init
=> True);
1912 -- Inspect the freeze node of an access-to-controlled type and
1913 -- look for a delayed finalization master. This case arises when
1914 -- the freeze actions are inserted at a later time than the
1915 -- expansion of the context. Since Build_Finalizer is never called
1916 -- on a single construct twice, the master will be ultimately
1917 -- left out and never finalized. This is also needed for freeze
1918 -- actions of designated types themselves, since in some cases the
1919 -- finalization master is associated with a designated type's
1920 -- freeze node rather than that of the access type (see handling
1921 -- for freeze actions in Build_Finalization_Master).
1923 elsif Nkind
(Decl
) = N_Freeze_Entity
1924 and then Present
(Actions
(Decl
))
1926 Typ
:= Entity
(Decl
);
1928 if (Is_Access_Type
(Typ
)
1929 and then not Is_Access_Subprogram_Type
(Typ
)
1930 and then Needs_Finalization
1931 (Available_View
(Designated_Type
(Typ
))))
1932 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
1934 Old_Counter_Val
:= Counter_Val
;
1936 -- Freeze nodes are considered to be identical to packages
1937 -- and blocks in terms of nesting. The difference is that
1938 -- a finalization master created inside the freeze node is
1939 -- at the same nesting level as the node itself.
1941 Process_Declarations
(Actions
(Decl
), Preprocess
);
1943 -- The freeze node contains a finalization master
1947 and then No
(Last_Top_Level_Ctrl_Construct
)
1948 and then Counter_Val
> Old_Counter_Val
1950 Last_Top_Level_Ctrl_Construct
:= Decl
;
1954 -- Nested package declarations, avoid generics
1956 elsif Nkind
(Decl
) = N_Package_Declaration
then
1957 Spec
:= Specification
(Decl
);
1958 Pack_Id
:= Defining_Unit_Name
(Spec
);
1960 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
1961 Pack_Id
:= Defining_Identifier
(Pack_Id
);
1964 if Ekind
(Pack_Id
) /= E_Generic_Package
then
1965 Old_Counter_Val
:= Counter_Val
;
1966 Process_Declarations
1967 (Private_Declarations
(Spec
), Preprocess
);
1968 Process_Declarations
1969 (Visible_Declarations
(Spec
), Preprocess
);
1971 -- Either the visible or the private declarations contain a
1972 -- controlled object. The nested package declaration is the
1973 -- last such construct.
1977 and then No
(Last_Top_Level_Ctrl_Construct
)
1978 and then Counter_Val
> Old_Counter_Val
1980 Last_Top_Level_Ctrl_Construct
:= Decl
;
1984 -- Nested package bodies, avoid generics
1986 elsif Nkind
(Decl
) = N_Package_Body
then
1987 Spec
:= Corresponding_Spec
(Decl
);
1989 if Ekind
(Spec
) /= E_Generic_Package
then
1990 Old_Counter_Val
:= Counter_Val
;
1991 Process_Declarations
(Declarations
(Decl
), Preprocess
);
1993 -- The nested package body is the last construct to contain
1994 -- a controlled object.
1998 and then No
(Last_Top_Level_Ctrl_Construct
)
1999 and then Counter_Val
> Old_Counter_Val
2001 Last_Top_Level_Ctrl_Construct
:= Decl
;
2005 -- Handle a rare case caused by a controlled transient variable
2006 -- created as part of a record init proc. The variable is wrapped
2007 -- in a block, but the block is not associated with a transient
2010 elsif Nkind
(Decl
) = N_Block_Statement
2011 and then Inside_Init_Proc
2013 Old_Counter_Val
:= Counter_Val
;
2015 if Present
(Handled_Statement_Sequence
(Decl
)) then
2016 Process_Declarations
2017 (Statements
(Handled_Statement_Sequence
(Decl
)),
2021 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2023 -- Either the declaration or statement list of the block has a
2024 -- controlled object.
2028 and then No
(Last_Top_Level_Ctrl_Construct
)
2029 and then Counter_Val
> Old_Counter_Val
2031 Last_Top_Level_Ctrl_Construct
:= Decl
;
2034 -- Handle the case where the original context has been wrapped in
2035 -- a block to avoid interference between exception handlers and
2036 -- At_End handlers. Treat the block as transparent and process its
2039 elsif Nkind
(Decl
) = N_Block_Statement
2040 and then Is_Finalization_Wrapper
(Decl
)
2042 if Present
(Handled_Statement_Sequence
(Decl
)) then
2043 Process_Declarations
2044 (Statements
(Handled_Statement_Sequence
(Decl
)),
2048 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2051 Prev_Non_Pragma
(Decl
);
2053 end Process_Declarations
;
2055 --------------------------------
2056 -- Process_Object_Declaration --
2057 --------------------------------
2059 procedure Process_Object_Declaration
2061 Has_No_Init
: Boolean := False;
2062 Is_Protected
: Boolean := False)
2064 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2065 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2067 Init_Typ
: Entity_Id
;
2068 -- The initialization type of the related object declaration. Note
2069 -- that this is not necessarely the same type as Obj_Typ because of
2070 -- possible type derivations.
2072 Obj_Typ
: Entity_Id
;
2073 -- The type of the related object declaration
2075 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2076 -- Func_Id denotes a build-in-place function. Generate the following
2079 -- if BIPallocfrom > Secondary_Stack'Pos
2080 -- and then BIPfinalizationmaster /= null
2083 -- type Ptr_Typ is access Obj_Typ;
2084 -- for Ptr_Typ'Storage_Pool
2085 -- use Base_Pool (BIPfinalizationmaster);
2087 -- Free (Ptr_Typ (Temp));
2091 -- Obj_Typ is the type of the current object, Temp is the original
2092 -- allocation which Obj_Id renames.
2094 procedure Find_Last_Init
2095 (Last_Init
: out Node_Id
;
2096 Body_Insert
: out Node_Id
);
2097 -- Find the last initialization call related to object declaration
2098 -- Decl. Last_Init denotes the last initialization call which follows
2099 -- Decl. Body_Insert denotes a node where the finalizer body could be
2100 -- potentially inserted after (if blocks are involved).
2102 -----------------------------
2103 -- Build_BIP_Cleanup_Stmts --
2104 -----------------------------
2106 function Build_BIP_Cleanup_Stmts
2107 (Func_Id
: Entity_Id
) return Node_Id
2109 Decls
: constant List_Id
:= New_List
;
2110 Fin_Mas_Id
: constant Entity_Id
:=
2111 Build_In_Place_Formal
2112 (Func_Id
, BIP_Finalization_Master
);
2113 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2114 Temp_Id
: constant Entity_Id
:=
2115 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2119 Free_Stmt
: Node_Id
;
2120 Pool_Id
: Entity_Id
;
2121 Ptr_Typ
: Entity_Id
;
2125 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2127 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2130 Make_Object_Renaming_Declaration
(Loc
,
2131 Defining_Identifier
=> Pool_Id
,
2133 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2135 Make_Explicit_Dereference
(Loc
,
2137 Make_Function_Call
(Loc
,
2139 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2140 Parameter_Associations
=> New_List
(
2141 Make_Explicit_Dereference
(Loc
,
2143 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2145 -- Create an access type which uses the storage pool of the
2146 -- caller's finalization master.
2149 -- type Ptr_Typ is access Func_Typ;
2151 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2154 Make_Full_Type_Declaration
(Loc
,
2155 Defining_Identifier
=> Ptr_Typ
,
2157 Make_Access_To_Object_Definition
(Loc
,
2158 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2160 -- Perform minor decoration in order to set the master and the
2161 -- storage pool attributes.
2163 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2164 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2165 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2167 -- Create an explicit free statement. Note that the free uses the
2168 -- caller's pool expressed as a renaming.
2171 Make_Free_Statement
(Loc
,
2173 Unchecked_Convert_To
(Ptr_Typ
,
2174 New_Occurrence_Of
(Temp_Id
, Loc
)));
2176 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2178 -- Create a block to house the dummy type and the instantiation as
2179 -- well as to perform the cleanup the temporary.
2185 -- Free (Ptr_Typ (Temp_Id));
2189 Make_Block_Statement
(Loc
,
2190 Declarations
=> Decls
,
2191 Handled_Statement_Sequence
=>
2192 Make_Handled_Sequence_Of_Statements
(Loc
,
2193 Statements
=> New_List
(Free_Stmt
)));
2196 -- if BIPfinalizationmaster /= null then
2200 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2201 Right_Opnd
=> Make_Null
(Loc
));
2203 -- For constrained or tagged results escalate the condition to
2204 -- include the allocation format. Generate:
2206 -- if BIPallocform > Secondary_Stack'Pos
2207 -- and then BIPfinalizationmaster /= null
2210 if not Is_Constrained
(Func_Typ
)
2211 or else Is_Tagged_Type
(Func_Typ
)
2214 Alloc
: constant Entity_Id
:=
2215 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2221 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2223 Make_Integer_Literal
(Loc
,
2225 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2227 Right_Opnd
=> Cond
);
2237 Make_If_Statement
(Loc
,
2239 Then_Statements
=> New_List
(Free_Blk
));
2240 end Build_BIP_Cleanup_Stmts
;
2242 --------------------
2243 -- Find_Last_Init --
2244 --------------------
2246 procedure Find_Last_Init
2247 (Last_Init
: out Node_Id
;
2248 Body_Insert
: out Node_Id
)
2250 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2251 -- Find the last initialization call within the statements of
2254 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2255 -- Determine whether node N denotes one of the initialization
2256 -- procedures of types Init_Typ or Obj_Typ.
2258 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2259 -- Given a statement which is part of a list, return the next
2260 -- statement while skipping over dynamic elab checks.
2262 -----------------------------
2263 -- Find_Last_Init_In_Block --
2264 -----------------------------
2266 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2267 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2271 -- Examine the individual statements of the block in reverse to
2272 -- locate the last initialization call.
2274 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2275 Stmt
:= Last
(Statements
(HSS
));
2276 while Present
(Stmt
) loop
2278 -- Peek inside nested blocks in case aborts are allowed
2280 if Nkind
(Stmt
) = N_Block_Statement
then
2281 return Find_Last_Init_In_Block
(Stmt
);
2283 elsif Is_Init_Call
(Stmt
) then
2292 end Find_Last_Init_In_Block
;
2298 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2299 function Is_Init_Proc_Of
2300 (Subp_Id
: Entity_Id
;
2301 Typ
: Entity_Id
) return Boolean;
2302 -- Determine whether subprogram Subp_Id is a valid init proc of
2305 ---------------------
2306 -- Is_Init_Proc_Of --
2307 ---------------------
2309 function Is_Init_Proc_Of
2310 (Subp_Id
: Entity_Id
;
2311 Typ
: Entity_Id
) return Boolean
2313 Deep_Init
: Entity_Id
:= Empty
;
2314 Prim_Init
: Entity_Id
:= Empty
;
2315 Type_Init
: Entity_Id
:= Empty
;
2318 -- Obtain all possible initialization routines of the
2319 -- related type and try to match the subprogram entity
2320 -- against one of them.
2324 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2326 -- Primitive Initialize
2328 if Is_Controlled
(Typ
) then
2329 Prim_Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2331 if Present
(Prim_Init
) then
2332 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2336 -- Type initialization routine
2338 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2339 Type_Init
:= Base_Init_Proc
(Typ
);
2343 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2345 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2347 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2348 end Is_Init_Proc_Of
;
2352 Call_Id
: Entity_Id
;
2354 -- Start of processing for Is_Init_Call
2357 if Nkind
(N
) = N_Procedure_Call_Statement
2358 and then Nkind
(Name
(N
)) = N_Identifier
2360 Call_Id
:= Entity
(Name
(N
));
2362 -- Consider both the type of the object declaration and its
2363 -- related initialization type.
2366 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2368 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2374 -----------------------------
2375 -- Next_Suitable_Statement --
2376 -----------------------------
2378 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2379 Result
: Node_Id
:= Next
(Stmt
);
2382 -- Skip over access-before-elaboration checks
2384 if Dynamic_Elaboration_Checks
2385 and then Nkind
(Result
) = N_Raise_Program_Error
2387 Result
:= Next
(Result
);
2391 end Next_Suitable_Statement
;
2399 Deep_Init_Found
: Boolean := False;
2400 -- A flag set when a call to [Deep_]Initialize has been found
2402 -- Start of processing for Find_Last_Init
2406 Body_Insert
:= Empty
;
2408 -- Object renamings and objects associated with controlled
2409 -- function results do not require initialization.
2415 Stmt
:= Next_Suitable_Statement
(Decl
);
2417 -- A limited controlled object initialized by a function call uses
2418 -- the build-in-place machinery to obtain its value.
2420 -- Obj : Lim_Controlled_Type := Func_Call;
2424 -- Obj : Lim_Controlled_Type;
2425 -- type Ptr_Typ is access Lim_Controlled_Type;
2426 -- Temp : constant Ptr_Typ :=
2429 -- BIPaccess => Obj'Unrestricted_Access)'reference;
2431 -- In this scenario the declaration of the temporary acts as the
2432 -- last initialization statement.
2434 if Is_Limited_Type
(Obj_Typ
)
2435 and then Has_Init_Expression
(Decl
)
2436 and then No
(Expression
(Decl
))
2438 while Present
(Stmt
) loop
2439 if Nkind
(Stmt
) = N_Object_Declaration
2440 and then Present
(Expression
(Stmt
))
2441 and then Is_Object_Access_BIP_Func_Call
2442 (Expr
=> Expression
(Stmt
),
2452 -- In all other cases the initialization calls follow the related
2453 -- object. The general structure of object initialization built by
2454 -- routine Default_Initialize_Object is as follows:
2456 -- [begin -- aborts allowed
2458 -- Type_Init_Proc (Obj);
2459 -- [begin] -- exceptions allowed
2460 -- Deep_Initialize (Obj);
2461 -- [exception -- exceptions allowed
2463 -- Deep_Finalize (Obj, Self => False);
2466 -- [at end -- aborts allowed
2470 -- When aborts are allowed, the initialization calls are housed
2473 elsif Nkind
(Stmt
) = N_Block_Statement
then
2474 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2475 Body_Insert
:= Stmt
;
2477 -- Otherwise the initialization calls follow the related object
2480 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2482 -- Check for an optional call to Deep_Initialize which may
2483 -- appear within a block depending on whether the object has
2484 -- controlled components.
2486 if Present
(Stmt_2
) then
2487 if Nkind
(Stmt_2
) = N_Block_Statement
then
2488 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2490 if Present
(Call
) then
2491 Deep_Init_Found
:= True;
2493 Body_Insert
:= Stmt_2
;
2496 elsif Is_Init_Call
(Stmt_2
) then
2497 Deep_Init_Found
:= True;
2498 Last_Init
:= Stmt_2
;
2499 Body_Insert
:= Last_Init
;
2503 -- If the object lacks a call to Deep_Initialize, then it must
2504 -- have a call to its related type init proc.
2506 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2508 Body_Insert
:= Last_Init
;
2516 Count_Ins
: Node_Id
;
2518 Fin_Stmts
: List_Id
;
2521 Label_Id
: Entity_Id
;
2524 -- Start of processing for Process_Object_Declaration
2527 -- Handle the object type and the reference to the object
2529 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2530 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2533 if Is_Access_Type
(Obj_Typ
) then
2534 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2535 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2537 elsif Is_Concurrent_Type
(Obj_Typ
)
2538 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2540 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2541 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2543 elsif Is_Private_Type
(Obj_Typ
)
2544 and then Present
(Full_View
(Obj_Typ
))
2546 Obj_Typ
:= Full_View
(Obj_Typ
);
2547 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2549 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2550 Obj_Typ
:= Base_Type
(Obj_Typ
);
2551 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2558 Set_Etype
(Obj_Ref
, Obj_Typ
);
2560 -- Handle the initialization type of the object declaration
2562 Init_Typ
:= Obj_Typ
;
2564 if Is_Private_Type
(Init_Typ
)
2565 and then Present
(Full_View
(Init_Typ
))
2567 Init_Typ
:= Full_View
(Init_Typ
);
2569 elsif Is_Untagged_Derivation
(Init_Typ
) then
2570 Init_Typ
:= Root_Type
(Init_Typ
);
2577 -- Set a new value for the state counter and insert the statement
2578 -- after the object declaration. Generate:
2580 -- Counter := <value>;
2583 Make_Assignment_Statement
(Loc
,
2584 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2585 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2587 -- Insert the counter after all initialization has been done. The
2588 -- place of insertion depends on the context. If an object is being
2589 -- initialized via an aggregate, then the counter must be inserted
2590 -- after the last aggregate assignment.
2592 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2593 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
2595 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2598 -- In all other cases the counter is inserted after the last call to
2599 -- either [Deep_]Initialize or the type specific init proc.
2602 Find_Last_Init
(Count_Ins
, Body_Ins
);
2605 Insert_After
(Count_Ins
, Inc_Decl
);
2608 -- If the current declaration is the last in the list, the finalizer
2609 -- body needs to be inserted after the set counter statement for the
2610 -- current object declaration. This is complicated by the fact that
2611 -- the set counter statement may appear in abort deferred block. In
2612 -- that case, the proper insertion place is after the block.
2614 if No
(Finalizer_Insert_Nod
) then
2616 -- Insertion after an abort deffered block
2618 if Present
(Body_Ins
) then
2619 Finalizer_Insert_Nod
:= Body_Ins
;
2621 Finalizer_Insert_Nod
:= Inc_Decl
;
2625 -- Create the associated label with this object, generate:
2627 -- L<counter> : label;
2630 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2632 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2633 Label
:= Make_Label
(Loc
, Label_Id
);
2635 Prepend_To
(Finalizer_Decls
,
2636 Make_Implicit_Label_Declaration
(Loc
,
2637 Defining_Identifier
=> Entity
(Label_Id
),
2638 Label_Construct
=> Label
));
2640 -- Create the associated jump with this object, generate:
2642 -- when <counter> =>
2645 Prepend_To
(Jump_Alts
,
2646 Make_Case_Statement_Alternative
(Loc
,
2647 Discrete_Choices
=> New_List
(
2648 Make_Integer_Literal
(Loc
, Counter_Val
)),
2649 Statements
=> New_List
(
2650 Make_Goto_Statement
(Loc
,
2651 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
2653 -- Insert the jump destination, generate:
2657 Append_To
(Finalizer_Stmts
, Label
);
2659 -- Processing for simple protected objects. Such objects require
2660 -- manual finalization of their lock managers.
2662 if Is_Protected
then
2663 Fin_Stmts
:= No_List
;
2665 if Is_Simple_Protected_Type
(Obj_Typ
) then
2666 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2668 if Present
(Fin_Call
) then
2669 Fin_Stmts
:= New_List
(Fin_Call
);
2672 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2673 if Is_Record_Type
(Obj_Typ
) then
2674 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2675 elsif Is_Array_Type
(Obj_Typ
) then
2676 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2682 -- System.Tasking.Protected_Objects.Finalize_Protection
2690 if Present
(Fin_Stmts
) then
2691 Append_To
(Finalizer_Stmts
,
2692 Make_Block_Statement
(Loc
,
2693 Handled_Statement_Sequence
=>
2694 Make_Handled_Sequence_Of_Statements
(Loc
,
2695 Statements
=> Fin_Stmts
,
2697 Exception_Handlers
=> New_List
(
2698 Make_Exception_Handler
(Loc
,
2699 Exception_Choices
=> New_List
(
2700 Make_Others_Choice
(Loc
)),
2702 Statements
=> New_List
(
2703 Make_Null_Statement
(Loc
)))))));
2706 -- Processing for regular controlled objects
2710 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2712 -- begin -- Exception handlers allowed
2713 -- [Deep_]Finalize (Obj);
2716 -- when Id : others =>
2717 -- if not Raised then
2719 -- Save_Occurrence (E, Id);
2728 -- For CodePeer, the exception handlers normally generated here
2729 -- generate complex flowgraphs which result in capacity problems.
2730 -- Omitting these handlers for CodePeer is justified as follows:
2732 -- If a handler is dead, then omitting it is surely ok
2734 -- If a handler is live, then CodePeer should flag the
2735 -- potentially-exception-raising construct that causes it
2736 -- to be live. That is what we are interested in, not what
2737 -- happens after the exception is raised.
2739 if Exceptions_OK
and not CodePeer_Mode
then
2740 Fin_Stmts
:= New_List
(
2741 Make_Block_Statement
(Loc
,
2742 Handled_Statement_Sequence
=>
2743 Make_Handled_Sequence_Of_Statements
(Loc
,
2744 Statements
=> New_List
(Fin_Call
),
2746 Exception_Handlers
=> New_List
(
2747 Build_Exception_Handler
2748 (Finalizer_Data
, For_Package
)))));
2750 -- When exception handlers are prohibited, the finalization call
2751 -- appears unprotected. Any exception raised during finalization
2752 -- will bypass the circuitry which ensures the cleanup of all
2753 -- remaining objects.
2756 Fin_Stmts
:= New_List
(Fin_Call
);
2759 -- If we are dealing with a return object of a build-in-place
2760 -- function, generate the following cleanup statements:
2762 -- if BIPallocfrom > Secondary_Stack'Pos
2763 -- and then BIPfinalizationmaster /= null
2766 -- type Ptr_Typ is access Obj_Typ;
2767 -- for Ptr_Typ'Storage_Pool use
2768 -- Base_Pool (BIPfinalizationmaster.all).all;
2770 -- Free (Ptr_Typ (Temp));
2774 -- The generated code effectively detaches the temporary from the
2775 -- caller finalization master and deallocates the object. This is
2776 -- disabled on .NET/JVM because pools are not supported.
2778 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2780 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2782 if Is_Build_In_Place_Function
(Func_Id
)
2783 and then Needs_BIP_Finalization_Master
(Func_Id
)
2785 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2790 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2791 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2793 -- Temporaries created for the purpose of "exporting" a
2794 -- controlled transient out of an Expression_With_Actions (EWA)
2795 -- need guards. The following illustrates the usage of such
2798 -- Access_Typ : access [all] Obj_Typ;
2799 -- Temp : Access_Typ := null;
2800 -- <Counter> := ...;
2803 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2804 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2806 -- Temp := Ctrl_Trans'Unchecked_Access;
2809 -- The finalization machinery does not process EWA nodes as
2810 -- this may lead to premature finalization of expressions. Note
2811 -- that Temp is marked as being properly initialized regardless
2812 -- of whether the initialization of Ctrl_Trans succeeded. Since
2813 -- a failed initialization may leave Temp with a value of null,
2814 -- add a guard to handle this case:
2816 -- if Obj /= null then
2817 -- <object finalization statements>
2820 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2821 N_Object_Declaration
2823 Fin_Stmts
:= New_List
(
2824 Make_If_Statement
(Loc
,
2827 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
2828 Right_Opnd
=> Make_Null
(Loc
)),
2829 Then_Statements
=> Fin_Stmts
));
2831 -- Return objects use a flag to aid in processing their
2832 -- potential finalization when the enclosing function fails
2833 -- to return properly. Generate:
2836 -- <object finalization statements>
2840 Fin_Stmts
:= New_List
(
2841 Make_If_Statement
(Loc
,
2846 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2848 Then_Statements
=> Fin_Stmts
));
2853 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2855 -- Since the declarations are examined in reverse, the state counter
2856 -- must be decremented in order to keep with the true position of
2859 Counter_Val
:= Counter_Val
- 1;
2860 end Process_Object_Declaration
;
2862 -------------------------------------
2863 -- Process_Tagged_Type_Declaration --
2864 -------------------------------------
2866 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2867 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2868 DT_Ptr
: constant Entity_Id
:=
2869 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2872 -- Ada.Tags.Unregister_Tag (<Typ>P);
2874 Append_To
(Tagged_Type_Stmts
,
2875 Make_Procedure_Call_Statement
(Loc
,
2877 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
2878 Parameter_Associations
=> New_List
(
2879 New_Occurrence_Of
(DT_Ptr
, Loc
))));
2880 end Process_Tagged_Type_Declaration
;
2882 -- Start of processing for Build_Finalizer
2887 -- Do not perform this expansion in SPARK mode because it is not
2890 if GNATprove_Mode
then
2894 -- Step 1: Extract all lists which may contain controlled objects or
2895 -- library-level tagged types.
2897 if For_Package_Spec
then
2898 Decls
:= Visible_Declarations
(Specification
(N
));
2899 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2901 -- Retrieve the package spec id
2903 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2905 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2906 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2909 -- Accept statement, block, entry body, package body, protected body,
2910 -- subprogram body or task body.
2913 Decls
:= Declarations
(N
);
2914 HSS
:= Handled_Statement_Sequence
(N
);
2916 if Present
(HSS
) then
2917 if Present
(Statements
(HSS
)) then
2918 Stmts
:= Statements
(HSS
);
2921 if Present
(At_End_Proc
(HSS
)) then
2922 Prev_At_End
:= At_End_Proc
(HSS
);
2926 -- Retrieve the package spec id for package bodies
2928 if For_Package_Body
then
2929 Spec_Id
:= Corresponding_Spec
(N
);
2933 -- Do not process nested packages since those are handled by the
2934 -- enclosing scope's finalizer. Do not process non-expanded package
2935 -- instantiations since those will be re-analyzed and re-expanded.
2939 (not Is_Library_Level_Entity
(Spec_Id
)
2941 -- Nested packages are considered to be library level entities,
2942 -- but do not need to be processed separately. True library level
2943 -- packages have a scope value of 1.
2945 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2946 or else (Is_Generic_Instance
(Spec_Id
)
2947 and then Package_Instantiation
(Spec_Id
) /= N
))
2952 -- Step 2: Object [pre]processing
2956 -- Preprocess the visible declarations now in order to obtain the
2957 -- correct number of controlled object by the time the private
2958 -- declarations are processed.
2960 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2962 -- From all the possible contexts, only package specifications may
2963 -- have private declarations.
2965 if For_Package_Spec
then
2966 Process_Declarations
2967 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2970 -- The current context may lack controlled objects, but require some
2971 -- other form of completion (task termination for instance). In such
2972 -- cases, the finalizer must be created and carry the additional
2975 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2979 -- The preprocessing has determined that the context has controlled
2980 -- objects or library-level tagged types.
2982 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2984 -- Private declarations are processed first in order to preserve
2985 -- possible dependencies between public and private objects.
2987 if For_Package_Spec
then
2988 Process_Declarations
(Priv_Decls
);
2991 Process_Declarations
(Decls
);
2997 -- Preprocess both declarations and statements
2999 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3000 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3002 -- At this point it is known that N has controlled objects. Ensure
3003 -- that N has a declarative list since the finalizer spec will be
3006 if Has_Ctrl_Objs
and then No
(Decls
) then
3007 Set_Declarations
(N
, New_List
);
3008 Decls
:= Declarations
(N
);
3009 Spec_Decls
:= Decls
;
3012 -- The current context may lack controlled objects, but require some
3013 -- other form of completion (task termination for instance). In such
3014 -- cases, the finalizer must be created and carry the additional
3017 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3021 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3022 Process_Declarations
(Stmts
);
3023 Process_Declarations
(Decls
);
3027 -- Step 3: Finalizer creation
3029 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3032 end Build_Finalizer
;
3034 --------------------------
3035 -- Build_Finalizer_Call --
3036 --------------------------
3038 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3039 Is_Prot_Body
: constant Boolean :=
3040 Nkind
(N
) = N_Subprogram_Body
3041 and then Is_Protected_Subprogram_Body
(N
);
3042 -- Determine whether N denotes the protected version of a subprogram
3043 -- which belongs to a protected type.
3045 Loc
: constant Source_Ptr
:= Sloc
(N
);
3049 -- Do not perform this expansion in SPARK mode because we do not create
3050 -- finalizers in the first place.
3052 if GNATprove_Mode
then
3056 -- The At_End handler should have been assimilated by the finalizer
3058 HSS
:= Handled_Statement_Sequence
(N
);
3059 pragma Assert
(No
(At_End_Proc
(HSS
)));
3061 -- If the construct to be cleaned up is a protected subprogram body, the
3062 -- finalizer call needs to be associated with the block which wraps the
3063 -- unprotected version of the subprogram. The following illustrates this
3066 -- procedure Prot_SubpP is
3067 -- procedure finalizer is
3069 -- Service_Entries (Prot_Obj);
3076 -- Prot_SubpN (Prot_Obj);
3082 if Is_Prot_Body
then
3083 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3085 -- An At_End handler and regular exception handlers cannot coexist in
3086 -- the same statement sequence. Wrap the original statements in a block.
3088 elsif Present
(Exception_Handlers
(HSS
)) then
3090 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3095 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3097 Set_Handled_Statement_Sequence
(N
,
3098 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3100 HSS
:= Handled_Statement_Sequence
(N
);
3101 Set_End_Label
(HSS
, End_Lab
);
3105 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3107 Analyze
(At_End_Proc
(HSS
));
3108 Expand_At_End_Handler
(HSS
, Empty
);
3109 end Build_Finalizer_Call
;
3111 ---------------------
3112 -- Build_Late_Proc --
3113 ---------------------
3115 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3117 for Final_Prim
in Name_Of
'Range loop
3118 if Name_Of
(Final_Prim
) = Nam
then
3121 (Prim
=> Final_Prim
,
3123 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3126 end Build_Late_Proc
;
3128 -------------------------------
3129 -- Build_Object_Declarations --
3130 -------------------------------
3132 procedure Build_Object_Declarations
3133 (Data
: out Finalization_Exception_Data
;
3136 For_Package
: Boolean := False)
3141 -- This variable captures an unused dummy internal entity, see the
3142 -- comment associated with its use.
3145 pragma Assert
(Decls
/= No_List
);
3147 -- Always set the proper location as it may be needed even when
3148 -- exception propagation is forbidden.
3152 if Restriction_Active
(No_Exception_Propagation
) then
3153 Data
.Abort_Id
:= Empty
;
3155 Data
.Raised_Id
:= Empty
;
3159 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3161 -- In certain scenarios, finalization can be triggered by an abort. If
3162 -- the finalization itself fails and raises an exception, the resulting
3163 -- Program_Error must be supressed and replaced by an abort signal. In
3164 -- order to detect this scenario, save the state of entry into the
3165 -- finalization code.
3167 -- No need to do this for VM case, since VM version of Ada.Exceptions
3168 -- does not include routine Raise_From_Controlled_Operation which is the
3169 -- the sole user of flag Abort.
3171 -- This is not needed for library-level finalizers as they are called by
3172 -- the environment task and cannot be aborted.
3174 if VM_Target
= No_VM
and then not For_Package
then
3175 if Abort_Allowed
then
3176 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3179 -- Abort_Id : constant Boolean := <A_Expr>;
3182 Make_Object_Declaration
(Loc
,
3183 Defining_Identifier
=> Data
.Abort_Id
,
3184 Constant_Present
=> True,
3185 Object_Definition
=>
3186 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3188 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3190 -- Abort is not required
3193 -- Generate a dummy entity to ensure that the internal symbols are
3194 -- in sync when a unit is compiled with and without aborts.
3196 Dummy
:= Make_Temporary
(Loc
, 'A');
3197 Data
.Abort_Id
:= Empty
;
3200 -- .NET/JVM or library-level finalizers
3203 Data
.Abort_Id
:= Empty
;
3206 if Exception_Extra_Info
then
3207 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3210 -- E_Id : Exception_Occurrence;
3213 Make_Object_Declaration
(Loc
,
3214 Defining_Identifier
=> Data
.E_Id
,
3215 Object_Definition
=>
3216 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3217 Set_No_Initialization
(Decl
);
3219 Append_To
(Decls
, Decl
);
3226 -- Raised_Id : Boolean := False;
3229 Make_Object_Declaration
(Loc
,
3230 Defining_Identifier
=> Data
.Raised_Id
,
3231 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3232 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3233 end Build_Object_Declarations
;
3235 ---------------------------
3236 -- Build_Raise_Statement --
3237 ---------------------------
3239 function Build_Raise_Statement
3240 (Data
: Finalization_Exception_Data
) return Node_Id
3246 -- Standard run-time and .NET/JVM targets use the specialized routine
3247 -- Raise_From_Controlled_Operation.
3249 if Exception_Extra_Info
3250 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3253 Make_Procedure_Call_Statement
(Data
.Loc
,
3256 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3257 Parameter_Associations
=>
3258 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3260 -- Restricted run-time: exception messages are not supported and hence
3261 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3266 Make_Raise_Program_Error
(Data
.Loc
,
3267 Reason
=> PE_Finalize_Raised_Exception
);
3272 -- Raised_Id and then not Abort_Id
3276 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3278 if Present
(Data
.Abort_Id
) then
3279 Expr
:= Make_And_Then
(Data
.Loc
,
3282 Make_Op_Not
(Data
.Loc
,
3283 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3288 -- if Raised_Id and then not Abort_Id then
3289 -- Raise_From_Controlled_Operation (E_Id);
3291 -- raise Program_Error; -- restricted runtime
3295 Make_If_Statement
(Data
.Loc
,
3297 Then_Statements
=> New_List
(Stmt
));
3298 end Build_Raise_Statement
;
3300 -----------------------------
3301 -- Build_Record_Deep_Procs --
3302 -----------------------------
3304 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3308 (Prim
=> Initialize_Case
,
3310 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3312 if not Is_Limited_View
(Typ
) then
3315 (Prim
=> Adjust_Case
,
3317 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3320 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3321 -- suppressed since these routine will not be used.
3323 if not Restriction_Active
(No_Finalization
) then
3326 (Prim
=> Finalize_Case
,
3328 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3330 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3331 -- .NET do not support address arithmetic and unchecked conversions.
3333 if VM_Target
= No_VM
then
3336 (Prim
=> Address_Case
,
3338 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3341 end Build_Record_Deep_Procs
;
3347 function Cleanup_Array
3350 Typ
: Entity_Id
) return List_Id
3352 Loc
: constant Source_Ptr
:= Sloc
(N
);
3353 Index_List
: constant List_Id
:= New_List
;
3355 function Free_Component
return List_Id
;
3356 -- Generate the code to finalize the task or protected subcomponents
3357 -- of a single component of the array.
3359 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3360 -- Generate a loop over one dimension of the array
3362 --------------------
3363 -- Free_Component --
3364 --------------------
3366 function Free_Component
return List_Id
is
3367 Stmts
: List_Id
:= New_List
;
3369 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3372 -- Component type is known to contain tasks or protected objects
3375 Make_Indexed_Component
(Loc
,
3376 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3377 Expressions
=> Index_List
);
3379 Set_Etype
(Tsk
, C_Typ
);
3381 if Is_Task_Type
(C_Typ
) then
3382 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3384 elsif Is_Simple_Protected_Type
(C_Typ
) then
3385 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3387 elsif Is_Record_Type
(C_Typ
) then
3388 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3390 elsif Is_Array_Type
(C_Typ
) then
3391 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3397 ------------------------
3398 -- Free_One_Dimension --
3399 ------------------------
3401 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3405 if Dim
> Number_Dimensions
(Typ
) then
3406 return Free_Component
;
3408 -- Here we generate the required loop
3411 Index
:= Make_Temporary
(Loc
, 'J');
3412 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3415 Make_Implicit_Loop_Statement
(N
,
3416 Identifier
=> Empty
,
3418 Make_Iteration_Scheme
(Loc
,
3419 Loop_Parameter_Specification
=>
3420 Make_Loop_Parameter_Specification
(Loc
,
3421 Defining_Identifier
=> Index
,
3422 Discrete_Subtype_Definition
=>
3423 Make_Attribute_Reference
(Loc
,
3424 Prefix
=> Duplicate_Subexpr
(Obj
),
3425 Attribute_Name
=> Name_Range
,
3426 Expressions
=> New_List
(
3427 Make_Integer_Literal
(Loc
, Dim
))))),
3428 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3430 end Free_One_Dimension
;
3432 -- Start of processing for Cleanup_Array
3435 return Free_One_Dimension
(1);
3438 --------------------
3439 -- Cleanup_Record --
3440 --------------------
3442 function Cleanup_Record
3445 Typ
: Entity_Id
) return List_Id
3447 Loc
: constant Source_Ptr
:= Sloc
(N
);
3450 Stmts
: constant List_Id
:= New_List
;
3451 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3454 if Has_Discriminants
(U_Typ
)
3455 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3456 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3459 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3461 -- For now, do not attempt to free a component that may appear in a
3462 -- variant, and instead issue a warning. Doing this "properly" would
3463 -- require building a case statement and would be quite a mess. Note
3464 -- that the RM only requires that free "work" for the case of a task
3465 -- access value, so already we go way beyond this in that we deal
3466 -- with the array case and non-discriminated record cases.
3469 ("task/protected object in variant record will not be freed??", N
);
3470 return New_List
(Make_Null_Statement
(Loc
));
3473 Comp
:= First_Component
(Typ
);
3474 while Present
(Comp
) loop
3475 if Has_Task
(Etype
(Comp
))
3476 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3479 Make_Selected_Component
(Loc
,
3480 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3481 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3482 Set_Etype
(Tsk
, Etype
(Comp
));
3484 if Is_Task_Type
(Etype
(Comp
)) then
3485 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3487 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3488 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3490 elsif Is_Record_Type
(Etype
(Comp
)) then
3492 -- Recurse, by generating the prefix of the argument to
3493 -- the eventual cleanup call.
3495 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3497 elsif Is_Array_Type
(Etype
(Comp
)) then
3498 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3502 Next_Component
(Comp
);
3508 ------------------------------
3509 -- Cleanup_Protected_Object --
3510 ------------------------------
3512 function Cleanup_Protected_Object
3514 Ref
: Node_Id
) return Node_Id
3516 Loc
: constant Source_Ptr
:= Sloc
(N
);
3519 -- For restricted run-time libraries (Ravenscar), tasks are
3520 -- non-terminating, and protected objects can only appear at library
3521 -- level, so we do not want finalization of protected objects.
3523 if Restricted_Profile
then
3528 Make_Procedure_Call_Statement
(Loc
,
3530 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3531 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3533 end Cleanup_Protected_Object
;
3539 function Cleanup_Task
3541 Ref
: Node_Id
) return Node_Id
3543 Loc
: constant Source_Ptr
:= Sloc
(N
);
3546 -- For restricted run-time libraries (Ravenscar), tasks are
3547 -- non-terminating and they can only appear at library level, so we do
3548 -- not want finalization of task objects.
3550 if Restricted_Profile
then
3555 Make_Procedure_Call_Statement
(Loc
,
3557 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3558 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3562 ------------------------------
3563 -- Check_Visibly_Controlled --
3564 ------------------------------
3566 procedure Check_Visibly_Controlled
3567 (Prim
: Final_Primitives
;
3569 E
: in out Entity_Id
;
3570 Cref
: in out Node_Id
)
3572 Parent_Type
: Entity_Id
;
3576 if Is_Derived_Type
(Typ
)
3577 and then Comes_From_Source
(E
)
3578 and then not Present
(Overridden_Operation
(E
))
3580 -- We know that the explicit operation on the type does not override
3581 -- the inherited operation of the parent, and that the derivation
3582 -- is from a private type that is not visibly controlled.
3584 Parent_Type
:= Etype
(Typ
);
3585 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3587 if Present
(Op
) then
3590 -- Wrap the object to be initialized into the proper
3591 -- unchecked conversion, to be compatible with the operation
3594 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3595 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3597 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3601 end Check_Visibly_Controlled
;
3603 -------------------------------
3604 -- CW_Or_Has_Controlled_Part --
3605 -------------------------------
3607 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3609 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3610 end CW_Or_Has_Controlled_Part
;
3616 function Convert_View
3619 Ind
: Pos
:= 1) return Node_Id
3621 Fent
: Entity_Id
:= First_Entity
(Proc
);
3626 for J
in 2 .. Ind
loop
3630 Ftyp
:= Etype
(Fent
);
3632 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3633 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3635 Atyp
:= Etype
(Arg
);
3638 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3639 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3642 and then Present
(Atyp
)
3643 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3644 and then Base_Type
(Underlying_Type
(Atyp
)) =
3645 Base_Type
(Underlying_Type
(Ftyp
))
3647 return Unchecked_Convert_To
(Ftyp
, Arg
);
3649 -- If the argument is already a conversion, as generated by
3650 -- Make_Init_Call, set the target type to the type of the formal
3651 -- directly, to avoid spurious typing problems.
3653 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3654 and then not Is_Class_Wide_Type
(Atyp
)
3656 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3657 Set_Etype
(Arg
, Ftyp
);
3665 ------------------------
3666 -- Enclosing_Function --
3667 ------------------------
3669 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3670 Func_Id
: Entity_Id
;
3674 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
3675 if Ekind
(Func_Id
) = E_Function
then
3679 Func_Id
:= Scope
(Func_Id
);
3683 end Enclosing_Function
;
3685 -------------------------------
3686 -- Establish_Transient_Scope --
3687 -------------------------------
3689 -- This procedure is called each time a transient block has to be inserted
3690 -- that is to say for each call to a function with unconstrained or tagged
3691 -- result. It creates a new scope on the stack scope in order to enclose
3692 -- all transient variables generated.
3694 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3695 Loc
: constant Source_Ptr
:= Sloc
(N
);
3696 Iter_Loop
: Entity_Id
;
3697 Wrap_Node
: Node_Id
;
3700 -- Do not create a transient scope if we are already inside one
3702 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3703 if Scope_Stack
.Table
(S
).Is_Transient
then
3705 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3710 -- If we encounter Standard there are no enclosing transient scopes
3712 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3717 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3719 -- The context does not contain a node that requires a transient scope,
3722 if No
(Wrap_Node
) then
3725 -- If the node to wrap is an iteration_scheme, the expression is one of
3726 -- the bounds, and the expansion will make an explicit declaration for
3727 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3728 -- transformations here. Same for an Ada 2012 iterator specification,
3729 -- where a block is created for the expression that build the container.
3731 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3732 N_Iterator_Specification
)
3736 -- In formal verification mode, if the node to wrap is a pragma check,
3737 -- this node and enclosed expression are not expanded, so do not apply
3738 -- any transformations here.
3740 elsif GNATprove_Mode
3741 and then Nkind
(Wrap_Node
) = N_Pragma
3742 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3746 -- Create a block entity to act as a transient scope. Note that when the
3747 -- node to be wrapped is an expression or a statement, a real physical
3748 -- block is constructed (see routines Wrap_Transient_Expression and
3749 -- Wrap_Transient_Statement) and inserted into the tree.
3752 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3753 Set_Scope_Is_Transient
;
3755 -- The transient scope must also take care of the secondary stack
3759 Set_Uses_Sec_Stack
(Current_Scope
);
3760 Check_Restriction
(No_Secondary_Stack
, N
);
3762 -- The expansion of iterator loops generates references to objects
3763 -- in order to extract elements from a container:
3765 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3766 -- Obj : <object type> renames Ref.all.Element.all;
3768 -- These references are controlled and returned on the secondary
3769 -- stack. A new reference is created at each iteration of the loop
3770 -- and as a result it must be finalized and the space occupied by
3771 -- it on the secondary stack reclaimed at the end of the current
3774 -- When the context that requires a transient scope is a call to
3775 -- routine Reference, the node to be wrapped is the source object:
3777 -- for Obj of Container loop
3779 -- Routine Wrap_Transient_Declaration however does not generate a
3780 -- physical block as wrapping a declaration will kill it too ealy.
3781 -- To handle this peculiar case, mark the related iterator loop as
3782 -- requiring the secondary stack. This signals the finalization
3783 -- machinery to manage the secondary stack (see routine
3784 -- Process_Statements_For_Controlled_Objects).
3786 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
3788 if Present
(Iter_Loop
) then
3789 Set_Uses_Sec_Stack
(Iter_Loop
);
3793 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3794 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3796 if Debug_Flag_W
then
3797 Write_Str
(" <Transient>");
3801 end Establish_Transient_Scope
;
3803 ----------------------------
3804 -- Expand_Cleanup_Actions --
3805 ----------------------------
3807 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3808 Scop
: constant Entity_Id
:= Current_Scope
;
3810 Is_Asynchronous_Call
: constant Boolean :=
3811 Nkind
(N
) = N_Block_Statement
3812 and then Is_Asynchronous_Call_Block
(N
);
3813 Is_Master
: constant Boolean :=
3814 Nkind
(N
) /= N_Entry_Body
3815 and then Is_Task_Master
(N
);
3816 Is_Protected_Body
: constant Boolean :=
3817 Nkind
(N
) = N_Subprogram_Body
3818 and then Is_Protected_Subprogram_Body
(N
);
3819 Is_Task_Allocation
: constant Boolean :=
3820 Nkind
(N
) = N_Block_Statement
3821 and then Is_Task_Allocation_Block
(N
);
3822 Is_Task_Body
: constant Boolean :=
3823 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3824 Needs_Sec_Stack_Mark
: constant Boolean :=
3825 Uses_Sec_Stack
(Scop
)
3827 not Sec_Stack_Needed_For_Return
(Scop
)
3828 and then VM_Target
= No_VM
;
3829 Needs_Custom_Cleanup
: constant Boolean :=
3830 Nkind
(N
) = N_Block_Statement
3831 and then Present
(Cleanup_Actions
(N
));
3833 Actions_Required
: constant Boolean :=
3834 Requires_Cleanup_Actions
(N
, True)
3835 or else Is_Asynchronous_Call
3837 or else Is_Protected_Body
3838 or else Is_Task_Allocation
3839 or else Is_Task_Body
3840 or else Needs_Sec_Stack_Mark
3841 or else Needs_Custom_Cleanup
;
3843 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3847 procedure Wrap_HSS_In_Block
;
3848 -- Move HSS inside a new block along with the original exception
3849 -- handlers. Make the newly generated block the sole statement of HSS.
3851 -----------------------
3852 -- Wrap_HSS_In_Block --
3853 -----------------------
3855 procedure Wrap_HSS_In_Block
is
3860 -- Preserve end label to provide proper cross-reference information
3862 End_Lab
:= End_Label
(HSS
);
3864 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3866 -- Signal the finalization machinery that this particular block
3867 -- contains the original context.
3869 Set_Is_Finalization_Wrapper
(Block
);
3871 Set_Handled_Statement_Sequence
(N
,
3872 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3873 HSS
:= Handled_Statement_Sequence
(N
);
3875 Set_First_Real_Statement
(HSS
, Block
);
3876 Set_End_Label
(HSS
, End_Lab
);
3878 -- Comment needed here, see RH for 1.306 ???
3880 if Nkind
(N
) = N_Subprogram_Body
then
3881 Set_Has_Nested_Block_With_Handler
(Scop
);
3883 end Wrap_HSS_In_Block
;
3885 -- Start of processing for Expand_Cleanup_Actions
3888 -- The current construct does not need any form of servicing
3890 if not Actions_Required
then
3893 -- If the current node is a rewritten task body and the descriptors have
3894 -- not been delayed (due to some nested instantiations), do not generate
3895 -- redundant cleanup actions.
3898 and then Nkind
(N
) = N_Subprogram_Body
3899 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3904 if Needs_Custom_Cleanup
then
3905 Cln
:= Cleanup_Actions
(N
);
3911 Decls
: List_Id
:= Declarations
(N
);
3913 Mark
: Entity_Id
:= Empty
;
3914 New_Decls
: List_Id
;
3918 -- If we are generating expanded code for debugging purposes, use the
3919 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3920 -- be updated subsequently to reference the proper line in .dg files.
3921 -- If we are not debugging generated code, use No_Location instead,
3922 -- so that no debug information is generated for the cleanup code.
3923 -- This makes the behavior of the NEXT command in GDB monotonic, and
3924 -- makes the placement of breakpoints more accurate.
3926 if Debug_Generated_Code
then
3932 -- Set polling off. The finalization and cleanup code is executed
3933 -- with aborts deferred.
3935 Old_Poll
:= Polling_Required
;
3936 Polling_Required
:= False;
3938 -- A task activation call has already been built for a task
3939 -- allocation block.
3941 if not Is_Task_Allocation
then
3942 Build_Task_Activation_Call
(N
);
3946 Establish_Task_Master
(N
);
3949 New_Decls
:= New_List
;
3951 -- If secondary stack is in use, generate:
3953 -- Mnn : constant Mark_Id := SS_Mark;
3955 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3956 -- secondary stack is never used on a VM.
3958 if Needs_Sec_Stack_Mark
then
3959 Mark
:= Make_Temporary
(Loc
, 'M');
3961 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
3962 Set_Uses_Sec_Stack
(Scop
, False);
3965 -- If exception handlers are present, wrap the sequence of statements
3966 -- in a block since it is not possible to have exception handlers and
3967 -- an At_End handler in the same construct.
3969 if Present
(Exception_Handlers
(HSS
)) then
3972 -- Ensure that the First_Real_Statement field is set
3974 elsif No
(First_Real_Statement
(HSS
)) then
3975 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3978 -- Do not move the Activation_Chain declaration in the context of
3979 -- task allocation blocks. Task allocation blocks use _chain in their
3980 -- cleanup handlers and gigi complains if it is declared in the
3981 -- sequence of statements of the scope that declares the handler.
3983 if Is_Task_Allocation
then
3985 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3989 Decl
:= First
(Decls
);
3990 while Nkind
(Decl
) /= N_Object_Declaration
3991 or else Defining_Identifier
(Decl
) /= Chain
3995 -- A task allocation block should always include a _chain
3998 pragma Assert
(Present
(Decl
));
4002 Prepend_To
(New_Decls
, Decl
);
4006 -- Ensure the presence of a declaration list in order to successfully
4007 -- append all original statements to it.
4010 Set_Declarations
(N
, New_List
);
4011 Decls
:= Declarations
(N
);
4014 -- Move the declarations into the sequence of statements in order to
4015 -- have them protected by the At_End handler. It may seem weird to
4016 -- put declarations in the sequence of statement but in fact nothing
4017 -- forbids that at the tree level.
4019 Append_List_To
(Decls
, Statements
(HSS
));
4020 Set_Statements
(HSS
, Decls
);
4022 -- Reset the Sloc of the handled statement sequence to properly
4023 -- reflect the new initial "statement" in the sequence.
4025 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4027 -- The declarations of finalizer spec and auxiliary variables replace
4028 -- the old declarations that have been moved inward.
4030 Set_Declarations
(N
, New_Decls
);
4031 Analyze_Declarations
(New_Decls
);
4033 -- Generate finalization calls for all controlled objects appearing
4034 -- in the statements of N. Add context specific cleanup for various
4039 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4041 Top_Decls
=> New_Decls
,
4042 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4046 if Present
(Fin_Id
) then
4047 Build_Finalizer_Call
(N
, Fin_Id
);
4050 -- Restore saved polling mode
4052 Polling_Required
:= Old_Poll
;
4054 end Expand_Cleanup_Actions
;
4056 ---------------------------
4057 -- Expand_N_Package_Body --
4058 ---------------------------
4060 -- Add call to Activate_Tasks if body is an activator (actual processing
4061 -- is in chapter 9).
4063 -- Generate subprogram descriptor for elaboration routine
4065 -- Encode entity names in package body
4067 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4068 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
4072 -- This is done only for non-generic packages
4074 if Ekind
(Spec_Ent
) = E_Package
then
4075 Push_Scope
(Corresponding_Spec
(N
));
4077 -- Build dispatch tables of library level tagged types
4079 if Tagged_Type_Expansion
4080 and then Is_Library_Level_Entity
(Spec_Ent
)
4082 Build_Static_Dispatch_Tables
(N
);
4085 Build_Task_Activation_Call
(N
);
4087 -- When the package is subject to pragma Initial_Condition, the
4088 -- assertion expression must be verified at the end of the body
4091 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
4092 Expand_Pragma_Initial_Condition
(N
);
4098 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4099 Set_In_Package_Body
(Spec_Ent
, False);
4101 -- Set to encode entity names in package body before gigi is called
4103 Qualify_Entity_Names
(N
);
4105 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
4108 Clean_Stmts
=> No_List
,
4110 Top_Decls
=> No_List
,
4111 Defer_Abort
=> False,
4114 if Present
(Fin_Id
) then
4116 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4119 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4120 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4123 Set_Finalizer
(Body_Ent
, Fin_Id
);
4127 end Expand_N_Package_Body
;
4129 ----------------------------------
4130 -- Expand_N_Package_Declaration --
4131 ----------------------------------
4133 -- Add call to Activate_Tasks if there are tasks declared and the package
4134 -- has no body. Note that in Ada 83 this may result in premature activation
4135 -- of some tasks, given that we cannot tell whether a body will eventually
4138 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4139 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4140 Spec
: constant Node_Id
:= Specification
(N
);
4144 No_Body
: Boolean := False;
4145 -- True in the case of a package declaration that is a compilation
4146 -- unit and for which no associated body will be compiled in this
4150 -- Case of a package declaration other than a compilation unit
4152 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4155 -- Case of a compilation unit that does not require a body
4157 elsif not Body_Required
(Parent
(N
))
4158 and then not Unit_Requires_Body
(Id
)
4162 -- Special case of generating calling stubs for a remote call interface
4163 -- package: even though the package declaration requires one, the body
4164 -- won't be processed in this compilation (so any stubs for RACWs
4165 -- declared in the package must be generated here, along with the spec).
4167 elsif Parent
(N
) = Cunit
(Main_Unit
)
4168 and then Is_Remote_Call_Interface
(Id
)
4169 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4174 -- For a nested instance, delay processing until freeze point
4176 if Has_Delayed_Freeze
(Id
)
4177 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4182 -- For a package declaration that implies no associated body, generate
4183 -- task activation call and RACW supporting bodies now (since we won't
4184 -- have a specific separate compilation unit for that).
4189 -- Generate RACW subprogram bodies
4191 if Has_RACW
(Id
) then
4192 Decls
:= Private_Declarations
(Spec
);
4195 Decls
:= Visible_Declarations
(Spec
);
4200 Set_Visible_Declarations
(Spec
, Decls
);
4203 Append_RACW_Bodies
(Decls
, Id
);
4204 Analyze_List
(Decls
);
4207 -- Generate task activation call as last step of elaboration
4209 if Present
(Activation_Chain_Entity
(N
)) then
4210 Build_Task_Activation_Call
(N
);
4213 -- When the package is subject to pragma Initial_Condition and lacks
4214 -- a body, the assertion expression must be verified at the end of
4215 -- the visible declarations. Otherwise the check is performed at the
4216 -- end of the body statements (see Expand_N_Package_Body).
4218 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4219 Expand_Pragma_Initial_Condition
(N
);
4225 -- Build dispatch tables of library level tagged types
4227 if Tagged_Type_Expansion
4228 and then (Is_Compilation_Unit
(Id
)
4229 or else (Is_Generic_Instance
(Id
)
4230 and then Is_Library_Level_Entity
(Id
)))
4232 Build_Static_Dispatch_Tables
(N
);
4235 -- Note: it is not necessary to worry about generating a subprogram
4236 -- descriptor, since the only way to get exception handlers into a
4237 -- package spec is to include instantiations, and that would cause
4238 -- generation of subprogram descriptors to be delayed in any case.
4240 -- Set to encode entity names in package spec before gigi is called
4242 Qualify_Entity_Names
(N
);
4244 if Ekind
(Id
) /= E_Generic_Package
then
4247 Clean_Stmts
=> No_List
,
4249 Top_Decls
=> No_List
,
4250 Defer_Abort
=> False,
4253 Set_Finalizer
(Id
, Fin_Id
);
4255 end Expand_N_Package_Declaration
;
4257 -------------------------------------
4258 -- Expand_Pragma_Initial_Condition --
4259 -------------------------------------
4261 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
) is
4262 Loc
: constant Source_Ptr
:= Sloc
(N
);
4265 Init_Cond
: Node_Id
;
4267 Pack_Id
: Entity_Id
;
4270 if Nkind
(N
) = N_Package_Body
then
4271 Pack_Id
:= Corresponding_Spec
(N
);
4273 if Present
(Handled_Statement_Sequence
(N
)) then
4274 List
:= Statements
(Handled_Statement_Sequence
(N
));
4276 -- The package body lacks statements, create an empty list
4281 Set_Handled_Statement_Sequence
(N
,
4282 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> List
));
4285 elsif Nkind
(N
) = N_Package_Declaration
then
4286 Pack_Id
:= Defining_Entity
(N
);
4288 if Present
(Visible_Declarations
(Specification
(N
))) then
4289 List
:= Visible_Declarations
(Specification
(N
));
4291 -- The package lacks visible declarations, create an empty list
4296 Set_Visible_Declarations
(Specification
(N
), List
);
4299 -- This routine should not be used on anything other than packages
4302 raise Program_Error
;
4305 Init_Cond
:= Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
4307 -- The caller should check whether the package is subject to pragma
4308 -- Initial_Condition.
4310 pragma Assert
(Present
(Init_Cond
));
4313 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Init_Cond
)));
4315 -- The assertion expression was found to be illegal, do not generate the
4316 -- runtime check as it will repeat the illegality.
4318 if Error_Posted
(Init_Cond
) or else Error_Posted
(Expr
) then
4323 -- pragma Check (Initial_Condition, <Expr>);
4327 Chars
=> Name_Check
,
4328 Pragma_Argument_Associations
=> New_List
(
4329 Make_Pragma_Argument_Association
(Loc
,
4330 Expression
=> Make_Identifier
(Loc
, Name_Initial_Condition
)),
4332 Make_Pragma_Argument_Association
(Loc
,
4333 Expression
=> New_Copy_Tree
(Expr
))));
4335 Append_To
(List
, Check
);
4337 end Expand_Pragma_Initial_Condition
;
4339 -----------------------------
4340 -- Find_Node_To_Be_Wrapped --
4341 -----------------------------
4343 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4345 The_Parent
: Node_Id
;
4351 case Nkind
(The_Parent
) is
4353 -- Simple statement can be wrapped
4358 -- Usually assignments are good candidate for wrapping except
4359 -- when they have been generated as part of a controlled aggregate
4360 -- where the wrapping should take place more globally. Note that
4361 -- No_Ctrl_Actions may be set also for non-controlled assignements
4362 -- in order to disable the use of dispatching _assign, so we need
4363 -- to test explicitly for a controlled type here.
4365 when N_Assignment_Statement
=>
4366 if No_Ctrl_Actions
(The_Parent
)
4367 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4374 -- An entry call statement is a special case if it occurs in the
4375 -- context of a Timed_Entry_Call. In this case we wrap the entire
4376 -- timed entry call.
4378 when N_Entry_Call_Statement |
4379 N_Procedure_Call_Statement
=>
4380 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4381 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4383 N_Conditional_Entry_Call
)
4385 return Parent
(Parent
(The_Parent
));
4390 -- Object declarations are also a boundary for the transient scope
4391 -- even if they are not really wrapped. For further details, see
4392 -- Wrap_Transient_Declaration.
4394 when N_Object_Declaration |
4395 N_Object_Renaming_Declaration |
4396 N_Subtype_Declaration
=>
4399 -- The expression itself is to be wrapped if its parent is a
4400 -- compound statement or any other statement where the expression
4401 -- is known to be scalar.
4403 when N_Accept_Alternative |
4404 N_Attribute_Definition_Clause |
4407 N_Delay_Alternative |
4408 N_Delay_Until_Statement |
4409 N_Delay_Relative_Statement |
4410 N_Discriminant_Association |
4412 N_Entry_Body_Formal_Part |
4415 N_Iteration_Scheme |
4416 N_Terminate_Alternative
=>
4417 pragma Assert
(Present
(P
));
4420 when N_Attribute_Reference
=>
4422 if Is_Procedure_Attribute_Name
4423 (Attribute_Name
(The_Parent
))
4428 -- A raise statement can be wrapped. This will arise when the
4429 -- expression in a raise_with_expression uses the secondary
4430 -- stack, for example.
4432 when N_Raise_Statement
=>
4435 -- If the expression is within the iteration scheme of a loop,
4436 -- we must create a declaration for it, followed by an assignment
4437 -- in order to have a usable statement to wrap.
4439 when N_Loop_Parameter_Specification
=>
4440 return Parent
(The_Parent
);
4442 -- The following nodes contains "dummy calls" which don't need to
4445 when N_Parameter_Specification |
4446 N_Discriminant_Specification |
4447 N_Component_Declaration
=>
4450 -- The return statement is not to be wrapped when the function
4451 -- itself needs wrapping at the outer-level
4453 when N_Simple_Return_Statement
=>
4455 Applies_To
: constant Entity_Id
:=
4457 (Return_Statement_Entity
(The_Parent
));
4458 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4460 if Requires_Transient_Scope
(Return_Type
) then
4467 -- If we leave a scope without having been able to find a node to
4468 -- wrap, something is going wrong but this can happen in error
4469 -- situation that are not detected yet (such as a dynamic string
4470 -- in a pragma export)
4472 when N_Subprogram_Body |
4473 N_Package_Declaration |
4475 N_Block_Statement
=>
4478 -- Otherwise continue the search
4485 The_Parent
:= Parent
(P
);
4487 end Find_Node_To_Be_Wrapped
;
4489 -------------------------------------
4490 -- Get_Global_Pool_For_Access_Type --
4491 -------------------------------------
4493 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4495 -- Access types whose size is smaller than System.Address size can exist
4496 -- only on VMS. We can't use the usual global pool which returns an
4497 -- object of type Address as truncation will make it invalid. To handle
4498 -- this case, VMS has a dedicated global pool that returns addresses
4499 -- that fit into 32 bit accesses.
4501 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4502 return RTE
(RE_Global_Pool_32_Object
);
4504 return RTE
(RE_Global_Pool_Object
);
4506 end Get_Global_Pool_For_Access_Type
;
4508 ----------------------------------
4509 -- Has_New_Controlled_Component --
4510 ----------------------------------
4512 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4516 if not Is_Tagged_Type
(E
) then
4517 return Has_Controlled_Component
(E
);
4518 elsif not Is_Derived_Type
(E
) then
4519 return Has_Controlled_Component
(E
);
4522 Comp
:= First_Component
(E
);
4523 while Present
(Comp
) loop
4524 if Chars
(Comp
) = Name_uParent
then
4527 elsif Scope
(Original_Record_Component
(Comp
)) = E
4528 and then Needs_Finalization
(Etype
(Comp
))
4533 Next_Component
(Comp
);
4537 end Has_New_Controlled_Component
;
4539 ---------------------------------
4540 -- Has_Simple_Protected_Object --
4541 ---------------------------------
4543 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4545 if Has_Task
(T
) then
4548 elsif Is_Simple_Protected_Type
(T
) then
4551 elsif Is_Array_Type
(T
) then
4552 return Has_Simple_Protected_Object
(Component_Type
(T
));
4554 elsif Is_Record_Type
(T
) then
4559 Comp
:= First_Component
(T
);
4560 while Present
(Comp
) loop
4561 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4565 Next_Component
(Comp
);
4574 end Has_Simple_Protected_Object
;
4576 ------------------------------------
4577 -- Insert_Actions_In_Scope_Around --
4578 ------------------------------------
4580 procedure Insert_Actions_In_Scope_Around
4583 Manage_SS
: Boolean)
4585 Act_Before
: constant List_Id
:=
4586 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4587 Act_After
: constant List_Id
:=
4588 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4589 Act_Cleanup
: constant List_Id
:=
4590 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4591 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4592 -- Last), but this was incorrect as Process_Transient_Object may
4593 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4595 procedure Process_Transient_Objects
4596 (First_Object
: Node_Id
;
4597 Last_Object
: Node_Id
;
4598 Related_Node
: Node_Id
);
4599 -- First_Object and Last_Object define a list which contains potential
4600 -- controlled transient objects. Finalization flags are inserted before
4601 -- First_Object and finalization calls are inserted after Last_Object.
4602 -- Related_Node is the node for which transient objects have been
4605 -------------------------------
4606 -- Process_Transient_Objects --
4607 -------------------------------
4609 procedure Process_Transient_Objects
4610 (First_Object
: Node_Id
;
4611 Last_Object
: Node_Id
;
4612 Related_Node
: Node_Id
)
4614 Must_Hook
: Boolean := False;
4615 -- Flag denoting whether the context requires transient variable
4616 -- export to the outer finalizer.
4618 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4619 -- Determine whether an arbitrary node denotes a subprogram call
4621 procedure Detect_Subprogram_Call
is
4622 new Traverse_Proc
(Is_Subprogram_Call
);
4624 ------------------------
4625 -- Is_Subprogram_Call --
4626 ------------------------
4628 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4630 -- Complex constructs are factored out by the expander and their
4631 -- occurrences are replaced with references to temporaries. Due to
4632 -- this expansion activity, inspect the original tree to detect
4633 -- subprogram calls.
4635 if Nkind
(N
) = N_Identifier
and then Original_Node
(N
) /= N
then
4636 Detect_Subprogram_Call
(Original_Node
(N
));
4638 -- The original construct contains a subprogram call, there is
4639 -- no point in continuing the tree traversal.
4647 -- The original construct contains a subprogram call, there is no
4648 -- point in continuing the tree traversal.
4650 elsif Nkind
(N
) = N_Object_Declaration
4651 and then Present
(Expression
(N
))
4652 and then Nkind
(Original_Node
(Expression
(N
))) = N_Function_Call
4657 -- A regular procedure or function call
4659 elsif Nkind
(N
) in N_Subprogram_Call
then
4668 end Is_Subprogram_Call
;
4672 Built
: Boolean := False;
4673 Desig_Typ
: Entity_Id
;
4675 Fin_Block
: Node_Id
;
4676 Fin_Data
: Finalization_Exception_Data
;
4677 Fin_Decls
: List_Id
;
4678 Fin_Insrt
: Node_Id
;
4679 Last_Fin
: Node_Id
:= Empty
;
4683 Obj_Typ
: Entity_Id
;
4684 Prev_Fin
: Node_Id
:= Empty
;
4688 Temp_Id
: Entity_Id
;
4691 -- Start of processing for Process_Transient_Objects
4694 -- Recognize a scenario where the transient context is an object
4695 -- declaration initialized by a build-in-place function call:
4697 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4699 -- The rough expansion of the above is:
4701 -- Temp : ... := Ctrl_Func_Call;
4703 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4705 -- The finalization of any controlled transient must happen after
4706 -- the build-in-place function call is executed.
4708 if Nkind
(N
) = N_Object_Declaration
4709 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
4712 Fin_Insrt
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
4714 -- Search the context for at least one subprogram call. If found, the
4715 -- machinery exports all transient objects to the enclosing finalizer
4716 -- due to the possibility of abnormal call termination.
4719 Detect_Subprogram_Call
(N
);
4720 Fin_Insrt
:= Last_Object
;
4723 -- Examine all objects in the list First_Object .. Last_Object
4725 Stmt
:= First_Object
;
4726 while Present
(Stmt
) loop
4727 if Nkind
(Stmt
) = N_Object_Declaration
4728 and then Analyzed
(Stmt
)
4729 and then Is_Finalizable_Transient
(Stmt
, N
)
4731 -- Do not process the node to be wrapped since it will be
4732 -- handled by the enclosing finalizer.
4734 and then Stmt
/= Related_Node
4737 Obj_Id
:= Defining_Identifier
(Stmt
);
4738 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4739 Desig_Typ
:= Obj_Typ
;
4741 Set_Is_Processed_Transient
(Obj_Id
);
4743 -- Handle access types
4745 if Is_Access_Type
(Desig_Typ
) then
4746 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4749 -- Create the necessary entities and declarations the first
4754 Fin_Decls
:= New_List
;
4756 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4759 -- Transient variables associated with subprogram calls need
4760 -- extra processing. These variables are usually created right
4761 -- before the call and finalized immediately after the call.
4762 -- If an exception occurs during the call, the clean up code
4763 -- is skipped due to the sudden change in control and the
4764 -- transient is never finalized.
4766 -- To handle this case, such variables are "exported" to the
4767 -- enclosing sequence of statements where their corresponding
4768 -- "hooks" are picked up by the finalization machinery.
4772 -- Step 1: Create an access type which provides a reference
4773 -- to the transient object. Generate:
4775 -- Ann : access [all] <Desig_Typ>;
4777 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4779 Insert_Action
(Stmt
,
4780 Make_Full_Type_Declaration
(Loc
,
4781 Defining_Identifier
=> Ptr_Id
,
4783 Make_Access_To_Object_Definition
(Loc
,
4785 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4786 Subtype_Indication
=>
4787 New_Occurrence_Of
(Desig_Typ
, Loc
))));
4789 -- Step 2: Create a temporary which acts as a hook to the
4790 -- transient object. Generate:
4792 -- Temp : Ptr_Id := null;
4794 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4796 Insert_Action
(Stmt
,
4797 Make_Object_Declaration
(Loc
,
4798 Defining_Identifier
=> Temp_Id
,
4799 Object_Definition
=>
4800 New_Occurrence_Of
(Ptr_Id
, Loc
)));
4802 -- Mark the temporary as a transient hook. This signals the
4803 -- machinery in Build_Finalizer to recognize this special
4806 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4808 -- Step 3: Hook the transient object to the temporary
4810 if Is_Access_Type
(Obj_Typ
) then
4812 Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
4815 Make_Attribute_Reference
(Loc
,
4816 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
4817 Attribute_Name
=> Name_Unrestricted_Access
);
4821 -- Temp := Ptr_Id (Obj_Id);
4823 -- Temp := Obj_Id'Unrestricted_Access;
4825 -- When the transient object is initialized by an aggregate,
4826 -- the hook must capture the object after the last component
4827 -- assignment takes place. Only then is the object fully
4830 if Ekind
(Obj_Id
) = E_Variable
4831 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
4833 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
4835 -- Otherwise the hook seizes the related object immediately
4841 Insert_After_And_Analyze
(Temp_Ins
,
4842 Make_Assignment_Statement
(Loc
,
4843 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4844 Expression
=> Expr
));
4849 -- The transient object is about to be finalized by the clean
4850 -- up code following the subprogram call. In order to avoid
4851 -- double finalization, clear the hook.
4858 Make_Assignment_Statement
(Loc
,
4859 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4860 Expression
=> Make_Null
(Loc
)));
4864 -- [Deep_]Finalize (Obj_Ref);
4866 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
4868 if Is_Access_Type
(Obj_Typ
) then
4869 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4873 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4878 -- [Deep_]Finalize (Obj_Ref);
4882 -- if not Raised then
4885 -- (Enn, Get_Current_Excep.all.all);
4890 Make_Block_Statement
(Loc
,
4891 Handled_Statement_Sequence
=>
4892 Make_Handled_Sequence_Of_Statements
(Loc
,
4893 Statements
=> Stmts
,
4894 Exception_Handlers
=> New_List
(
4895 Build_Exception_Handler
(Fin_Data
))));
4897 -- The single raise statement must be inserted after all the
4898 -- finalization blocks, and we put everything into a wrapper
4899 -- block to clearly expose the construct to the back-end.
4901 if Present
(Prev_Fin
) then
4902 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4904 Insert_After_And_Analyze
(Fin_Insrt
,
4905 Make_Block_Statement
(Loc
,
4906 Declarations
=> Fin_Decls
,
4907 Handled_Statement_Sequence
=>
4908 Make_Handled_Sequence_Of_Statements
(Loc
,
4909 Statements
=> New_List
(Fin_Block
))));
4911 Last_Fin
:= Fin_Block
;
4914 Prev_Fin
:= Fin_Block
;
4917 -- Terminate the scan after the last object has been processed to
4918 -- avoid touching unrelated code.
4920 if Stmt
= Last_Object
then
4928 if Present
(Prev_Fin
) then
4929 Insert_List_Before_And_Analyze
(Prev_Fin
, Act_Cleanup
);
4931 Insert_List_After_And_Analyze
(Fin_Insrt
, Act_Cleanup
);
4936 -- if Raised and then not Abort then
4937 -- Raise_From_Controlled_Operation (E);
4940 if Built
and then Present
(Last_Fin
) then
4941 Insert_After_And_Analyze
(Last_Fin
,
4942 Build_Raise_Statement
(Fin_Data
));
4944 end Process_Transient_Objects
;
4948 Loc
: constant Source_Ptr
:= Sloc
(N
);
4949 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4950 First_Obj
: Node_Id
;
4952 Mark_Id
: Entity_Id
;
4955 -- Start of processing for Insert_Actions_In_Scope_Around
4958 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
4962 -- If the node to be wrapped is the trigger of an asynchronous select,
4963 -- it is not part of a statement list. The actions must be inserted
4964 -- before the select itself, which is part of some list of statements.
4965 -- Note that the triggering alternative includes the triggering
4966 -- statement and an optional statement list. If the node to be
4967 -- wrapped is part of that list, the normal insertion applies.
4969 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4970 and then not Is_List_Member
(Node_To_Wrap
)
4972 Target
:= Parent
(Parent
(Node_To_Wrap
));
4977 First_Obj
:= Target
;
4980 -- Add all actions associated with a transient scope into the main tree.
4981 -- There are several scenarios here:
4983 -- +--- Before ----+ +----- After ---+
4984 -- 1) First_Obj ....... Target ........ Last_Obj
4986 -- 2) First_Obj ....... Target
4988 -- 3) Target ........ Last_Obj
4990 -- Flag declarations are inserted before the first object
4992 if Present
(Act_Before
) then
4993 First_Obj
:= First
(Act_Before
);
4994 Insert_List_Before
(Target
, Act_Before
);
4997 -- Finalization calls are inserted after the last object
4999 if Present
(Act_After
) then
5000 Last_Obj
:= Last
(Act_After
);
5001 Insert_List_After
(Target
, Act_After
);
5004 -- Mark and release the secondary stack when the context warrants it
5007 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5010 -- Mnn : constant Mark_Id := SS_Mark;
5012 Insert_Before_And_Analyze
5013 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5016 -- SS_Release (Mnn);
5018 Insert_After_And_Analyze
5019 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5022 -- Check for transient controlled objects associated with Target and
5023 -- generate the appropriate finalization actions for them.
5025 Process_Transient_Objects
5026 (First_Object
=> First_Obj
,
5027 Last_Object
=> Last_Obj
,
5028 Related_Node
=> Target
);
5030 -- Reset the action lists
5033 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5035 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5039 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5041 end Insert_Actions_In_Scope_Around
;
5043 ------------------------------
5044 -- Is_Simple_Protected_Type --
5045 ------------------------------
5047 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5050 Is_Protected_Type
(T
)
5051 and then not Uses_Lock_Free
(T
)
5052 and then not Has_Entries
(T
)
5053 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5054 end Is_Simple_Protected_Type
;
5056 -----------------------
5057 -- Make_Adjust_Call --
5058 -----------------------
5060 function Make_Adjust_Call
5063 Skip_Self
: Boolean := False) return Node_Id
5065 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5066 Adj_Id
: Entity_Id
:= Empty
;
5067 Ref
: Node_Id
:= Obj_Ref
;
5071 -- Recover the proper type which contains Deep_Adjust
5073 if Is_Class_Wide_Type
(Typ
) then
5074 Utyp
:= Root_Type
(Typ
);
5079 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5080 Set_Assignment_OK
(Ref
);
5082 -- Deal with untagged derivation of private views
5084 if Is_Untagged_Derivation
(Typ
) then
5085 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5086 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5087 Set_Assignment_OK
(Ref
);
5090 -- When dealing with the completion of a private type, use the base
5093 if Utyp
/= Base_Type
(Utyp
) then
5094 pragma Assert
(Is_Private_Type
(Typ
));
5096 Utyp
:= Base_Type
(Utyp
);
5097 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5101 if Has_Controlled_Component
(Utyp
) then
5102 if Is_Tagged_Type
(Utyp
) then
5103 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5105 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5109 -- Class-wide types, interfaces and types with controlled components
5111 elsif Is_Class_Wide_Type
(Typ
)
5112 or else Is_Interface
(Typ
)
5113 or else Has_Controlled_Component
(Utyp
)
5115 if Is_Tagged_Type
(Utyp
) then
5116 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5118 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5121 -- Derivations from [Limited_]Controlled
5123 elsif Is_Controlled
(Utyp
) then
5124 if Has_Controlled_Component
(Utyp
) then
5125 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5127 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5132 elsif Is_Tagged_Type
(Utyp
) then
5133 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5136 raise Program_Error
;
5139 if Present
(Adj_Id
) then
5141 -- If the object is unanalyzed, set its expected type for use in
5142 -- Convert_View in case an additional conversion is needed.
5145 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5147 Set_Etype
(Ref
, Typ
);
5150 -- The object reference may need another conversion depending on the
5151 -- type of the formal and that of the actual.
5153 if not Is_Class_Wide_Type
(Typ
) then
5154 Ref
:= Convert_View
(Adj_Id
, Ref
);
5160 Param
=> New_Copy_Tree
(Ref
),
5161 Skip_Self
=> Skip_Self
);
5165 end Make_Adjust_Call
;
5167 ----------------------
5168 -- Make_Attach_Call --
5169 ----------------------
5171 function Make_Attach_Call
5173 Ptr_Typ
: Entity_Id
) return Node_Id
5175 pragma Assert
(VM_Target
/= No_VM
);
5177 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5180 Make_Procedure_Call_Statement
(Loc
,
5182 New_Occurrence_Of
(RTE
(RE_Attach
), Loc
),
5183 Parameter_Associations
=> New_List
(
5184 New_Occurrence_Of
(Finalization_Master
(Ptr_Typ
), Loc
),
5185 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5186 end Make_Attach_Call
;
5188 ----------------------
5189 -- Make_Detach_Call --
5190 ----------------------
5192 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5193 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5197 Make_Procedure_Call_Statement
(Loc
,
5199 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5200 Parameter_Associations
=> New_List
(
5201 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5202 end Make_Detach_Call
;
5210 Proc_Id
: Entity_Id
;
5212 Skip_Self
: Boolean := False) return Node_Id
5214 Params
: constant List_Id
:= New_List
(Param
);
5217 -- Do not apply the controlled action to the object itself by signaling
5218 -- the related routine to avoid self.
5221 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5225 Make_Procedure_Call_Statement
(Loc
,
5226 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5227 Parameter_Associations
=> Params
);
5230 --------------------------
5231 -- Make_Deep_Array_Body --
5232 --------------------------
5234 function Make_Deep_Array_Body
5235 (Prim
: Final_Primitives
;
5236 Typ
: Entity_Id
) return List_Id
5238 function Build_Adjust_Or_Finalize_Statements
5239 (Typ
: Entity_Id
) return List_Id
;
5240 -- Create the statements necessary to adjust or finalize an array of
5241 -- controlled elements. Generate:
5244 -- Abort : constant Boolean := Triggered_By_Abort;
5246 -- Abort : constant Boolean := False; -- no abort
5248 -- E : Exception_Occurrence;
5249 -- Raised : Boolean := False;
5252 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5253 -- ^-- in the finalization case
5255 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5257 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5261 -- if not Raised then
5263 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5270 -- if Raised and then not Abort then
5271 -- Raise_From_Controlled_Operation (E);
5275 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5276 -- Create the statements necessary to initialize an array of controlled
5277 -- elements. Include a mechanism to carry out partial finalization if an
5278 -- exception occurs. Generate:
5281 -- Counter : Integer := 0;
5284 -- for J1 in V'Range (1) loop
5286 -- for JN in V'Range (N) loop
5288 -- [Deep_]Initialize (V (J1, ..., JN));
5290 -- Counter := Counter + 1;
5295 -- Abort : constant Boolean := Triggered_By_Abort;
5297 -- Abort : constant Boolean := False; -- no abort
5298 -- E : Exception_Occurence;
5299 -- Raised : Boolean := False;
5306 -- V'Length (N) - Counter;
5308 -- for F1 in reverse V'Range (1) loop
5310 -- for FN in reverse V'Range (N) loop
5311 -- if Counter > 0 then
5312 -- Counter := Counter - 1;
5315 -- [Deep_]Finalize (V (F1, ..., FN));
5319 -- if not Raised then
5321 -- Save_Occurrence (E,
5322 -- Get_Current_Excep.all.all);
5331 -- if Raised and then not Abort then
5332 -- Raise_From_Controlled_Operation (E);
5341 function New_References_To
5343 Loc
: Source_Ptr
) return List_Id
;
5344 -- Given a list of defining identifiers, return a list of references to
5345 -- the original identifiers, in the same order as they appear.
5347 -----------------------------------------
5348 -- Build_Adjust_Or_Finalize_Statements --
5349 -----------------------------------------
5351 function Build_Adjust_Or_Finalize_Statements
5352 (Typ
: Entity_Id
) return List_Id
5354 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5355 Index_List
: constant List_Id
:= New_List
;
5356 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5357 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5358 Finalizer_Decls
: List_Id
:= No_List
;
5359 Finalizer_Data
: Finalization_Exception_Data
;
5362 Core_Loop
: Node_Id
;
5365 Loop_Id
: Entity_Id
;
5368 Exceptions_OK
: constant Boolean :=
5369 not Restriction_Active
(No_Exception_Propagation
);
5371 procedure Build_Indexes
;
5372 -- Generate the indexes used in the dimension loops
5378 procedure Build_Indexes
is
5380 -- Generate the following identifiers:
5381 -- Jnn - for initialization
5383 for Dim
in 1 .. Num_Dims
loop
5384 Append_To
(Index_List
,
5385 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5389 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5392 Finalizer_Decls
:= New_List
;
5395 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5398 Make_Indexed_Component
(Loc
,
5399 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5400 Expressions
=> New_References_To
(Index_List
, Loc
));
5401 Set_Etype
(Comp_Ref
, Comp_Typ
);
5404 -- [Deep_]Adjust (V (J1, ..., JN))
5406 if Prim
= Adjust_Case
then
5407 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5410 -- [Deep_]Finalize (V (J1, ..., JN))
5412 else pragma Assert
(Prim
= Finalize_Case
);
5413 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5416 -- Generate the block which houses the adjust or finalize call:
5418 -- <adjust or finalize call>; -- No_Exception_Propagation
5420 -- begin -- Exception handlers allowed
5421 -- <adjust or finalize call>
5425 -- if not Raised then
5427 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5431 if Exceptions_OK
then
5433 Make_Block_Statement
(Loc
,
5434 Handled_Statement_Sequence
=>
5435 Make_Handled_Sequence_Of_Statements
(Loc
,
5436 Statements
=> New_List
(Call
),
5437 Exception_Handlers
=> New_List
(
5438 Build_Exception_Handler
(Finalizer_Data
))));
5443 -- Generate the dimension loops starting from the innermost one
5445 -- for Jnn in [reverse] V'Range (Dim) loop
5449 J
:= Last
(Index_List
);
5451 while Present
(J
) and then Dim
> 0 loop
5457 Make_Loop_Statement
(Loc
,
5459 Make_Iteration_Scheme
(Loc
,
5460 Loop_Parameter_Specification
=>
5461 Make_Loop_Parameter_Specification
(Loc
,
5462 Defining_Identifier
=> Loop_Id
,
5463 Discrete_Subtype_Definition
=>
5464 Make_Attribute_Reference
(Loc
,
5465 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5466 Attribute_Name
=> Name_Range
,
5467 Expressions
=> New_List
(
5468 Make_Integer_Literal
(Loc
, Dim
))),
5470 Reverse_Present
=> Prim
= Finalize_Case
)),
5472 Statements
=> New_List
(Core_Loop
),
5473 End_Label
=> Empty
);
5478 -- Generate the block which contains the core loop, the declarations
5479 -- of the abort flag, the exception occurrence, the raised flag and
5480 -- the conditional raise:
5483 -- Abort : constant Boolean := Triggered_By_Abort;
5485 -- Abort : constant Boolean := False; -- no abort
5487 -- E : Exception_Occurrence;
5488 -- Raised : Boolean := False;
5493 -- if Raised and then not Abort then -- Expection handlers OK
5494 -- Raise_From_Controlled_Operation (E);
5498 Stmts
:= New_List
(Core_Loop
);
5500 if Exceptions_OK
then
5502 Build_Raise_Statement
(Finalizer_Data
));
5507 Make_Block_Statement
(Loc
,
5510 Handled_Statement_Sequence
=>
5511 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5512 end Build_Adjust_Or_Finalize_Statements
;
5514 ---------------------------------
5515 -- Build_Initialize_Statements --
5516 ---------------------------------
5518 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5519 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5520 Final_List
: constant List_Id
:= New_List
;
5521 Index_List
: constant List_Id
:= New_List
;
5522 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5523 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5524 Counter_Id
: Entity_Id
;
5528 Final_Block
: Node_Id
;
5529 Final_Loop
: Node_Id
;
5530 Finalizer_Data
: Finalization_Exception_Data
;
5531 Finalizer_Decls
: List_Id
:= No_List
;
5532 Init_Loop
: Node_Id
;
5537 Exceptions_OK
: constant Boolean :=
5538 not Restriction_Active
(No_Exception_Propagation
);
5540 function Build_Counter_Assignment
return Node_Id
;
5541 -- Generate the following assignment:
5542 -- Counter := V'Length (1) *
5544 -- V'Length (N) - Counter;
5546 function Build_Finalization_Call
return Node_Id
;
5547 -- Generate a deep finalization call for an array element
5549 procedure Build_Indexes
;
5550 -- Generate the initialization and finalization indexes used in the
5553 function Build_Initialization_Call
return Node_Id
;
5554 -- Generate a deep initialization call for an array element
5556 ------------------------------
5557 -- Build_Counter_Assignment --
5558 ------------------------------
5560 function Build_Counter_Assignment
return Node_Id
is
5565 -- Start from the first dimension and generate:
5570 Make_Attribute_Reference
(Loc
,
5571 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5572 Attribute_Name
=> Name_Length
,
5573 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5575 -- Process the rest of the dimensions, generate:
5576 -- Expr * V'Length (N)
5579 while Dim
<= Num_Dims
loop
5581 Make_Op_Multiply
(Loc
,
5584 Make_Attribute_Reference
(Loc
,
5585 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5586 Attribute_Name
=> Name_Length
,
5587 Expressions
=> New_List
(
5588 Make_Integer_Literal
(Loc
, Dim
))));
5594 -- Counter := Expr - Counter;
5597 Make_Assignment_Statement
(Loc
,
5598 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5600 Make_Op_Subtract
(Loc
,
5602 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5603 end Build_Counter_Assignment
;
5605 -----------------------------
5606 -- Build_Finalization_Call --
5607 -----------------------------
5609 function Build_Finalization_Call
return Node_Id
is
5610 Comp_Ref
: constant Node_Id
:=
5611 Make_Indexed_Component
(Loc
,
5612 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5613 Expressions
=> New_References_To
(Final_List
, Loc
));
5616 Set_Etype
(Comp_Ref
, Comp_Typ
);
5619 -- [Deep_]Finalize (V);
5621 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5622 end Build_Finalization_Call
;
5628 procedure Build_Indexes
is
5630 -- Generate the following identifiers:
5631 -- Jnn - for initialization
5632 -- Fnn - for finalization
5634 for Dim
in 1 .. Num_Dims
loop
5635 Append_To
(Index_List
,
5636 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5638 Append_To
(Final_List
,
5639 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5643 -------------------------------
5644 -- Build_Initialization_Call --
5645 -------------------------------
5647 function Build_Initialization_Call
return Node_Id
is
5648 Comp_Ref
: constant Node_Id
:=
5649 Make_Indexed_Component
(Loc
,
5650 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5651 Expressions
=> New_References_To
(Index_List
, Loc
));
5654 Set_Etype
(Comp_Ref
, Comp_Typ
);
5657 -- [Deep_]Initialize (V (J1, ..., JN));
5659 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5660 end Build_Initialization_Call
;
5662 -- Start of processing for Build_Initialize_Statements
5665 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5666 Finalizer_Decls
:= New_List
;
5669 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5671 -- Generate the block which houses the finalization call, the index
5672 -- guard and the handler which triggers Program_Error later on.
5674 -- if Counter > 0 then
5675 -- Counter := Counter - 1;
5677 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5679 -- begin -- Exceptions allowed
5680 -- [Deep_]Finalize (V (F1, ..., FN));
5683 -- if not Raised then
5685 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5690 if Exceptions_OK
then
5692 Make_Block_Statement
(Loc
,
5693 Handled_Statement_Sequence
=>
5694 Make_Handled_Sequence_Of_Statements
(Loc
,
5695 Statements
=> New_List
(Build_Finalization_Call
),
5696 Exception_Handlers
=> New_List
(
5697 Build_Exception_Handler
(Finalizer_Data
))));
5699 Fin_Stmt
:= Build_Finalization_Call
;
5702 -- This is the core of the loop, the dimension iterators are added
5703 -- one by one in reverse.
5706 Make_If_Statement
(Loc
,
5709 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5710 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5712 Then_Statements
=> New_List
(
5713 Make_Assignment_Statement
(Loc
,
5714 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5716 Make_Op_Subtract
(Loc
,
5717 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5718 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5720 Else_Statements
=> New_List
(Fin_Stmt
));
5722 -- Generate all finalization loops starting from the innermost
5725 -- for Fnn in reverse V'Range (Dim) loop
5729 F
:= Last
(Final_List
);
5731 while Present
(F
) and then Dim
> 0 loop
5737 Make_Loop_Statement
(Loc
,
5739 Make_Iteration_Scheme
(Loc
,
5740 Loop_Parameter_Specification
=>
5741 Make_Loop_Parameter_Specification
(Loc
,
5742 Defining_Identifier
=> Loop_Id
,
5743 Discrete_Subtype_Definition
=>
5744 Make_Attribute_Reference
(Loc
,
5745 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5746 Attribute_Name
=> Name_Range
,
5747 Expressions
=> New_List
(
5748 Make_Integer_Literal
(Loc
, Dim
))),
5750 Reverse_Present
=> True)),
5752 Statements
=> New_List
(Final_Loop
),
5753 End_Label
=> Empty
);
5758 -- Generate the block which contains the finalization loops, the
5759 -- declarations of the abort flag, the exception occurrence, the
5760 -- raised flag and the conditional raise.
5763 -- Abort : constant Boolean := Triggered_By_Abort;
5765 -- Abort : constant Boolean := False; -- no abort
5767 -- E : Exception_Occurrence;
5768 -- Raised : Boolean := False;
5774 -- V'Length (N) - Counter;
5778 -- if Raised and then not Abort then -- Exception handlers OK
5779 -- Raise_From_Controlled_Operation (E);
5782 -- raise; -- Exception handlers OK
5785 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5787 if Exceptions_OK
then
5789 Build_Raise_Statement
(Finalizer_Data
));
5790 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5794 Make_Block_Statement
(Loc
,
5797 Handled_Statement_Sequence
=>
5798 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5800 -- Generate the block which contains the initialization call and
5801 -- the partial finalization code.
5804 -- [Deep_]Initialize (V (J1, ..., JN));
5806 -- Counter := Counter + 1;
5810 -- <finalization code>
5814 Make_Block_Statement
(Loc
,
5815 Handled_Statement_Sequence
=>
5816 Make_Handled_Sequence_Of_Statements
(Loc
,
5817 Statements
=> New_List
(Build_Initialization_Call
),
5818 Exception_Handlers
=> New_List
(
5819 Make_Exception_Handler
(Loc
,
5820 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5821 Statements
=> New_List
(Final_Block
)))));
5823 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5824 Make_Assignment_Statement
(Loc
,
5825 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5828 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5829 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5831 -- Generate all initialization loops starting from the innermost
5834 -- for Jnn in V'Range (Dim) loop
5838 J
:= Last
(Index_List
);
5840 while Present
(J
) and then Dim
> 0 loop
5846 Make_Loop_Statement
(Loc
,
5848 Make_Iteration_Scheme
(Loc
,
5849 Loop_Parameter_Specification
=>
5850 Make_Loop_Parameter_Specification
(Loc
,
5851 Defining_Identifier
=> Loop_Id
,
5852 Discrete_Subtype_Definition
=>
5853 Make_Attribute_Reference
(Loc
,
5854 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5855 Attribute_Name
=> Name_Range
,
5856 Expressions
=> New_List
(
5857 Make_Integer_Literal
(Loc
, Dim
))))),
5859 Statements
=> New_List
(Init_Loop
),
5860 End_Label
=> Empty
);
5865 -- Generate the block which contains the counter variable and the
5866 -- initialization loops.
5869 -- Counter : Integer := 0;
5876 Make_Block_Statement
(Loc
,
5877 Declarations
=> New_List
(
5878 Make_Object_Declaration
(Loc
,
5879 Defining_Identifier
=> Counter_Id
,
5880 Object_Definition
=>
5881 New_Occurrence_Of
(Standard_Integer
, Loc
),
5882 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5884 Handled_Statement_Sequence
=>
5885 Make_Handled_Sequence_Of_Statements
(Loc
,
5886 Statements
=> New_List
(Init_Loop
))));
5887 end Build_Initialize_Statements
;
5889 -----------------------
5890 -- New_References_To --
5891 -----------------------
5893 function New_References_To
5895 Loc
: Source_Ptr
) return List_Id
5897 Refs
: constant List_Id
:= New_List
;
5902 while Present
(Id
) loop
5903 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
5908 end New_References_To
;
5910 -- Start of processing for Make_Deep_Array_Body
5914 when Address_Case
=>
5915 return Make_Finalize_Address_Stmts
(Typ
);
5919 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5921 when Initialize_Case
=>
5922 return Build_Initialize_Statements
(Typ
);
5924 end Make_Deep_Array_Body
;
5926 --------------------
5927 -- Make_Deep_Proc --
5928 --------------------
5930 function Make_Deep_Proc
5931 (Prim
: Final_Primitives
;
5933 Stmts
: List_Id
) return Entity_Id
5935 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5937 Proc_Id
: Entity_Id
;
5940 -- Create the object formal, generate:
5941 -- V : System.Address
5943 if Prim
= Address_Case
then
5944 Formals
:= New_List
(
5945 Make_Parameter_Specification
(Loc
,
5946 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5948 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5955 Formals
:= New_List
(
5956 Make_Parameter_Specification
(Loc
,
5957 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5959 Out_Present
=> True,
5960 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
5962 -- F : Boolean := True
5964 if Prim
= Adjust_Case
5965 or else Prim
= Finalize_Case
5968 Make_Parameter_Specification
(Loc
,
5969 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5971 New_Occurrence_Of
(Standard_Boolean
, Loc
),
5973 New_Occurrence_Of
(Standard_True
, Loc
)));
5978 Make_Defining_Identifier
(Loc
,
5979 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5982 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5985 -- exception -- Finalize and Adjust cases only
5986 -- raise Program_Error;
5987 -- end Deep_Initialize / Adjust / Finalize;
5991 -- procedure Finalize_Address (V : System.Address) is
5994 -- end Finalize_Address;
5997 Make_Subprogram_Body
(Loc
,
5999 Make_Procedure_Specification
(Loc
,
6000 Defining_Unit_Name
=> Proc_Id
,
6001 Parameter_Specifications
=> Formals
),
6003 Declarations
=> Empty_List
,
6005 Handled_Statement_Sequence
=>
6006 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6011 ---------------------------
6012 -- Make_Deep_Record_Body --
6013 ---------------------------
6015 function Make_Deep_Record_Body
6016 (Prim
: Final_Primitives
;
6018 Is_Local
: Boolean := False) return List_Id
6020 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6021 -- Build the statements necessary to adjust a record type. The type may
6022 -- have discriminants and contain variant parts. Generate:
6026 -- [Deep_]Adjust (V.Comp_1);
6028 -- when Id : others =>
6029 -- if not Raised then
6031 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6036 -- [Deep_]Adjust (V.Comp_N);
6038 -- when Id : others =>
6039 -- if not Raised then
6041 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6046 -- Deep_Adjust (V._parent, False); -- If applicable
6048 -- when Id : others =>
6049 -- if not Raised then
6051 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6057 -- Adjust (V); -- If applicable
6060 -- if not Raised then
6062 -- Save_Occurence (E, Get_Current_Excep.all.all);
6067 -- if Raised and then not Abort then
6068 -- Raise_From_Controlled_Operation (E);
6072 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6073 -- Build the statements necessary to finalize a record type. The type
6074 -- may have discriminants and contain variant parts. Generate:
6077 -- Abort : constant Boolean := Triggered_By_Abort;
6079 -- Abort : constant Boolean := False; -- no abort
6080 -- E : Exception_Occurence;
6081 -- Raised : Boolean := False;
6086 -- Finalize (V); -- If applicable
6089 -- if not Raised then
6091 -- Save_Occurence (E, Get_Current_Excep.all.all);
6096 -- case Variant_1 is
6098 -- case State_Counter_N => -- If Is_Local is enabled
6108 -- <<LN>> -- If Is_Local is enabled
6110 -- [Deep_]Finalize (V.Comp_N);
6113 -- if not Raised then
6115 -- Save_Occurence (E, Get_Current_Excep.all.all);
6121 -- [Deep_]Finalize (V.Comp_1);
6124 -- if not Raised then
6126 -- Save_Occurence (E, Get_Current_Excep.all.all);
6132 -- case State_Counter_1 => -- If Is_Local is enabled
6138 -- Deep_Finalize (V._parent, False); -- If applicable
6140 -- when Id : others =>
6141 -- if not Raised then
6143 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6147 -- if Raised and then not Abort then
6148 -- Raise_From_Controlled_Operation (E);
6152 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6153 -- Given a derived tagged type Typ, traverse all components, find field
6154 -- _parent and return its type.
6156 procedure Preprocess_Components
6158 Num_Comps
: out Int
;
6159 Has_POC
: out Boolean);
6160 -- Examine all components in component list Comps, count all controlled
6161 -- components and determine whether at least one of them is per-object
6162 -- constrained. Component _parent is always skipped.
6164 -----------------------------
6165 -- Build_Adjust_Statements --
6166 -----------------------------
6168 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6169 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6170 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6171 Bod_Stmts
: List_Id
;
6172 Finalizer_Data
: Finalization_Exception_Data
;
6173 Finalizer_Decls
: List_Id
:= No_List
;
6177 Exceptions_OK
: constant Boolean :=
6178 not Restriction_Active
(No_Exception_Propagation
);
6180 function Process_Component_List_For_Adjust
6181 (Comps
: Node_Id
) return List_Id
;
6182 -- Build all necessary adjust statements for a single component list
6184 ---------------------------------------
6185 -- Process_Component_List_For_Adjust --
6186 ---------------------------------------
6188 function Process_Component_List_For_Adjust
6189 (Comps
: Node_Id
) return List_Id
6191 Stmts
: constant List_Id
:= New_List
;
6193 Decl_Id
: Entity_Id
;
6194 Decl_Typ
: Entity_Id
;
6198 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6199 -- Process the declaration of a single controlled component
6201 ----------------------------------
6202 -- Process_Component_For_Adjust --
6203 ----------------------------------
6205 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6206 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6207 Typ
: constant Entity_Id
:= Etype
(Id
);
6212 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6214 -- begin -- Exception handlers allowed
6215 -- [Deep_]Adjust (V.Id);
6218 -- if not Raised then
6220 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6227 Make_Selected_Component
(Loc
,
6228 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6229 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6232 if Exceptions_OK
then
6234 Make_Block_Statement
(Loc
,
6235 Handled_Statement_Sequence
=>
6236 Make_Handled_Sequence_Of_Statements
(Loc
,
6237 Statements
=> New_List
(Adj_Stmt
),
6238 Exception_Handlers
=> New_List
(
6239 Build_Exception_Handler
(Finalizer_Data
))));
6242 Append_To
(Stmts
, Adj_Stmt
);
6243 end Process_Component_For_Adjust
;
6245 -- Start of processing for Process_Component_List_For_Adjust
6248 -- Perform an initial check, determine the number of controlled
6249 -- components in the current list and whether at least one of them
6250 -- is per-object constrained.
6252 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6254 -- The processing in this routine is done in the following order:
6255 -- 1) Regular components
6256 -- 2) Per-object constrained components
6259 if Num_Comps
> 0 then
6261 -- Process all regular components in order of declarations
6263 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6264 while Present
(Decl
) loop
6265 Decl_Id
:= Defining_Identifier
(Decl
);
6266 Decl_Typ
:= Etype
(Decl_Id
);
6268 -- Skip _parent as well as per-object constrained components
6270 if Chars
(Decl_Id
) /= Name_uParent
6271 and then Needs_Finalization
(Decl_Typ
)
6273 if Has_Access_Constraint
(Decl_Id
)
6274 and then No
(Expression
(Decl
))
6278 Process_Component_For_Adjust
(Decl
);
6282 Next_Non_Pragma
(Decl
);
6285 -- Process all per-object constrained components in order of
6289 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6290 while Present
(Decl
) loop
6291 Decl_Id
:= Defining_Identifier
(Decl
);
6292 Decl_Typ
:= Etype
(Decl_Id
);
6296 if Chars
(Decl_Id
) /= Name_uParent
6297 and then Needs_Finalization
(Decl_Typ
)
6298 and then Has_Access_Constraint
(Decl_Id
)
6299 and then No
(Expression
(Decl
))
6301 Process_Component_For_Adjust
(Decl
);
6304 Next_Non_Pragma
(Decl
);
6309 -- Process all variants, if any
6312 if Present
(Variant_Part
(Comps
)) then
6314 Var_Alts
: constant List_Id
:= New_List
;
6318 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6319 while Present
(Var
) loop
6322 -- when <discrete choices> =>
6323 -- <adjust statements>
6325 Append_To
(Var_Alts
,
6326 Make_Case_Statement_Alternative
(Loc
,
6328 New_Copy_List
(Discrete_Choices
(Var
)),
6330 Process_Component_List_For_Adjust
(
6331 Component_List
(Var
))));
6333 Next_Non_Pragma
(Var
);
6337 -- case V.<discriminant> is
6338 -- when <discrete choices 1> =>
6339 -- <adjust statements 1>
6341 -- when <discrete choices N> =>
6342 -- <adjust statements N>
6346 Make_Case_Statement
(Loc
,
6348 Make_Selected_Component
(Loc
,
6349 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6351 Make_Identifier
(Loc
,
6352 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6353 Alternatives
=> Var_Alts
);
6357 -- Add the variant case statement to the list of statements
6359 if Present
(Var_Case
) then
6360 Append_To
(Stmts
, Var_Case
);
6363 -- If the component list did not have any controlled components
6364 -- nor variants, return null.
6366 if Is_Empty_List
(Stmts
) then
6367 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6371 end Process_Component_List_For_Adjust
;
6373 -- Start of processing for Build_Adjust_Statements
6376 Finalizer_Decls
:= New_List
;
6377 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6379 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6380 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6385 -- Create an adjust sequence for all record components
6387 if Present
(Component_List
(Rec_Def
)) then
6389 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6392 -- A derived record type must adjust all inherited components. This
6393 -- action poses the following problem:
6395 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6400 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6402 -- Deep_Adjust (Obj._parent);
6407 -- Adjusting the derived type will invoke Adjust of the parent and
6408 -- then that of the derived type. This is undesirable because both
6409 -- routines may modify shared components. Only the Adjust of the
6410 -- derived type should be invoked.
6412 -- To prevent this double adjustment of shared components,
6413 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6415 -- procedure Deep_Adjust
6416 -- (Obj : in out Some_Type;
6417 -- Flag : Boolean := True)
6425 -- When Deep_Adjust is invokes for field _parent, a value of False is
6426 -- provided for the flag:
6428 -- Deep_Adjust (Obj._parent, False);
6430 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6432 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6437 if Needs_Finalization
(Par_Typ
) then
6441 Make_Selected_Component
(Loc
,
6442 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6444 Make_Identifier
(Loc
, Name_uParent
)),
6449 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6451 -- begin -- Exceptions OK
6452 -- Deep_Adjust (V._parent, False);
6454 -- when Id : others =>
6455 -- if not Raised then
6457 -- Save_Occurrence (E,
6458 -- Get_Current_Excep.all.all);
6462 if Present
(Call
) then
6465 if Exceptions_OK
then
6467 Make_Block_Statement
(Loc
,
6468 Handled_Statement_Sequence
=>
6469 Make_Handled_Sequence_Of_Statements
(Loc
,
6470 Statements
=> New_List
(Adj_Stmt
),
6471 Exception_Handlers
=> New_List
(
6472 Build_Exception_Handler
(Finalizer_Data
))));
6475 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6481 -- Adjust the object. This action must be performed last after all
6482 -- components have been adjusted.
6484 if Is_Controlled
(Typ
) then
6490 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6494 -- Adjust (V); -- No_Exception_Propagation
6496 -- begin -- Exception handlers allowed
6500 -- if not Raised then
6502 -- Save_Occurrence (E,
6503 -- Get_Current_Excep.all.all);
6508 if Present
(Proc
) then
6510 Make_Procedure_Call_Statement
(Loc
,
6511 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6512 Parameter_Associations
=> New_List
(
6513 Make_Identifier
(Loc
, Name_V
)));
6515 if Exceptions_OK
then
6517 Make_Block_Statement
(Loc
,
6518 Handled_Statement_Sequence
=>
6519 Make_Handled_Sequence_Of_Statements
(Loc
,
6520 Statements
=> New_List
(Adj_Stmt
),
6521 Exception_Handlers
=> New_List
(
6522 Build_Exception_Handler
6523 (Finalizer_Data
))));
6526 Append_To
(Bod_Stmts
,
6527 Make_If_Statement
(Loc
,
6528 Condition
=> Make_Identifier
(Loc
, Name_F
),
6529 Then_Statements
=> New_List
(Adj_Stmt
)));
6534 -- At this point either all adjustment statements have been generated
6535 -- or the type is not controlled.
6537 if Is_Empty_List
(Bod_Stmts
) then
6538 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6544 -- Abort : constant Boolean := Triggered_By_Abort;
6546 -- Abort : constant Boolean := False; -- no abort
6548 -- E : Exception_Occurence;
6549 -- Raised : Boolean := False;
6552 -- <adjust statements>
6554 -- if Raised and then not Abort then
6555 -- Raise_From_Controlled_Operation (E);
6560 if Exceptions_OK
then
6561 Append_To
(Bod_Stmts
,
6562 Build_Raise_Statement
(Finalizer_Data
));
6567 Make_Block_Statement
(Loc
,
6570 Handled_Statement_Sequence
=>
6571 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6573 end Build_Adjust_Statements
;
6575 -------------------------------
6576 -- Build_Finalize_Statements --
6577 -------------------------------
6579 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6580 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6581 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6582 Bod_Stmts
: List_Id
;
6584 Finalizer_Data
: Finalization_Exception_Data
;
6585 Finalizer_Decls
: List_Id
:= No_List
;
6589 Exceptions_OK
: constant Boolean :=
6590 not Restriction_Active
(No_Exception_Propagation
);
6592 function Process_Component_List_For_Finalize
6593 (Comps
: Node_Id
) return List_Id
;
6594 -- Build all necessary finalization statements for a single component
6595 -- list. The statements may include a jump circuitry if flag Is_Local
6598 -----------------------------------------
6599 -- Process_Component_List_For_Finalize --
6600 -----------------------------------------
6602 function Process_Component_List_For_Finalize
6603 (Comps
: Node_Id
) return List_Id
6606 Counter_Id
: Entity_Id
;
6608 Decl_Id
: Entity_Id
;
6609 Decl_Typ
: Entity_Id
;
6612 Jump_Block
: Node_Id
;
6614 Label_Id
: Entity_Id
;
6618 procedure Process_Component_For_Finalize
6623 -- Process the declaration of a single controlled component. If
6624 -- flag Is_Local is enabled, create the corresponding label and
6625 -- jump circuitry. Alts is the list of case alternatives, Decls
6626 -- is the top level declaration list where labels are declared
6627 -- and Stmts is the list of finalization actions.
6629 ------------------------------------
6630 -- Process_Component_For_Finalize --
6631 ------------------------------------
6633 procedure Process_Component_For_Finalize
6639 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6640 Typ
: constant Entity_Id
:= Etype
(Id
);
6647 Label_Id
: Entity_Id
;
6654 Make_Identifier
(Loc
,
6655 Chars
=> New_External_Name
('L', Num_Comps
));
6656 Set_Entity
(Label_Id
,
6657 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6658 Label
:= Make_Label
(Loc
, Label_Id
);
6661 Make_Implicit_Label_Declaration
(Loc
,
6662 Defining_Identifier
=> Entity
(Label_Id
),
6663 Label_Construct
=> Label
));
6670 Make_Case_Statement_Alternative
(Loc
,
6671 Discrete_Choices
=> New_List
(
6672 Make_Integer_Literal
(Loc
, Num_Comps
)),
6674 Statements
=> New_List
(
6675 Make_Goto_Statement
(Loc
,
6677 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6682 Append_To
(Stmts
, Label
);
6684 -- Decrease the number of components to be processed.
6685 -- This action yields a new Label_Id in future calls.
6687 Num_Comps
:= Num_Comps
- 1;
6692 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6694 -- begin -- Exception handlers allowed
6695 -- [Deep_]Finalize (V.Id);
6698 -- if not Raised then
6700 -- Save_Occurrence (E,
6701 -- Get_Current_Excep.all.all);
6708 Make_Selected_Component
(Loc
,
6709 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6710 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6713 if not Restriction_Active
(No_Exception_Propagation
) then
6715 Make_Block_Statement
(Loc
,
6716 Handled_Statement_Sequence
=>
6717 Make_Handled_Sequence_Of_Statements
(Loc
,
6718 Statements
=> New_List
(Fin_Stmt
),
6719 Exception_Handlers
=> New_List
(
6720 Build_Exception_Handler
(Finalizer_Data
))));
6723 Append_To
(Stmts
, Fin_Stmt
);
6724 end Process_Component_For_Finalize
;
6726 -- Start of processing for Process_Component_List_For_Finalize
6729 -- Perform an initial check, look for controlled and per-object
6730 -- constrained components.
6732 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6734 -- Create a state counter to service the current component list.
6735 -- This step is performed before the variants are inspected in
6736 -- order to generate the same state counter names as those from
6737 -- Build_Initialize_Statements.
6739 if Num_Comps
> 0 and then Is_Local
then
6740 Counter
:= Counter
+ 1;
6743 Make_Defining_Identifier
(Loc
,
6744 Chars
=> New_External_Name
('C', Counter
));
6747 -- Process the component in the following order:
6749 -- 2) Per-object constrained components
6750 -- 3) Regular components
6752 -- Start with the variant parts
6755 if Present
(Variant_Part
(Comps
)) then
6757 Var_Alts
: constant List_Id
:= New_List
;
6761 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6762 while Present
(Var
) loop
6765 -- when <discrete choices> =>
6766 -- <finalize statements>
6768 Append_To
(Var_Alts
,
6769 Make_Case_Statement_Alternative
(Loc
,
6771 New_Copy_List
(Discrete_Choices
(Var
)),
6773 Process_Component_List_For_Finalize
(
6774 Component_List
(Var
))));
6776 Next_Non_Pragma
(Var
);
6780 -- case V.<discriminant> is
6781 -- when <discrete choices 1> =>
6782 -- <finalize statements 1>
6784 -- when <discrete choices N> =>
6785 -- <finalize statements N>
6789 Make_Case_Statement
(Loc
,
6791 Make_Selected_Component
(Loc
,
6792 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6794 Make_Identifier
(Loc
,
6795 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6796 Alternatives
=> Var_Alts
);
6800 -- The current component list does not have a single controlled
6801 -- component, however it may contain variants. Return the case
6802 -- statement for the variants or nothing.
6804 if Num_Comps
= 0 then
6805 if Present
(Var_Case
) then
6806 return New_List
(Var_Case
);
6808 return New_List
(Make_Null_Statement
(Loc
));
6812 -- Prepare all lists
6818 -- Process all per-object constrained components in reverse order
6821 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6822 while Present
(Decl
) loop
6823 Decl_Id
:= Defining_Identifier
(Decl
);
6824 Decl_Typ
:= Etype
(Decl_Id
);
6828 if Chars
(Decl_Id
) /= Name_uParent
6829 and then Needs_Finalization
(Decl_Typ
)
6830 and then Has_Access_Constraint
(Decl_Id
)
6831 and then No
(Expression
(Decl
))
6833 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6836 Prev_Non_Pragma
(Decl
);
6840 -- Process the rest of the components in reverse order
6842 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6843 while Present
(Decl
) loop
6844 Decl_Id
:= Defining_Identifier
(Decl
);
6845 Decl_Typ
:= Etype
(Decl_Id
);
6849 if Chars
(Decl_Id
) /= Name_uParent
6850 and then Needs_Finalization
(Decl_Typ
)
6852 -- Skip per-object constrained components since they were
6853 -- handled in the above step.
6855 if Has_Access_Constraint
(Decl_Id
)
6856 and then No
(Expression
(Decl
))
6860 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6864 Prev_Non_Pragma
(Decl
);
6869 -- LN : label; -- If Is_Local is enabled
6874 -- case CounterX is .
6884 -- <<LN>> -- If Is_Local is enabled
6886 -- [Deep_]Finalize (V.CompY);
6888 -- when Id : others =>
6889 -- if not Raised then
6891 -- Save_Occurrence (E,
6892 -- Get_Current_Excep.all.all);
6896 -- <<L0>> -- If Is_Local is enabled
6901 -- Add the declaration of default jump location L0, its
6902 -- corresponding alternative and its place in the statements.
6904 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6905 Set_Entity
(Label_Id
,
6906 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6907 Label
:= Make_Label
(Loc
, Label_Id
);
6909 Append_To
(Decls
, -- declaration
6910 Make_Implicit_Label_Declaration
(Loc
,
6911 Defining_Identifier
=> Entity
(Label_Id
),
6912 Label_Construct
=> Label
));
6914 Append_To
(Alts
, -- alternative
6915 Make_Case_Statement_Alternative
(Loc
,
6916 Discrete_Choices
=> New_List
(
6917 Make_Others_Choice
(Loc
)),
6919 Statements
=> New_List
(
6920 Make_Goto_Statement
(Loc
,
6921 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6923 Append_To
(Stmts
, Label
); -- statement
6925 -- Create the jump block
6928 Make_Case_Statement
(Loc
,
6929 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6930 Alternatives
=> Alts
));
6934 Make_Block_Statement
(Loc
,
6935 Declarations
=> Decls
,
6936 Handled_Statement_Sequence
=>
6937 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6939 if Present
(Var_Case
) then
6940 return New_List
(Var_Case
, Jump_Block
);
6942 return New_List
(Jump_Block
);
6944 end Process_Component_List_For_Finalize
;
6946 -- Start of processing for Build_Finalize_Statements
6949 Finalizer_Decls
:= New_List
;
6950 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6952 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6953 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6958 -- Create a finalization sequence for all record components
6960 if Present
(Component_List
(Rec_Def
)) then
6962 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6965 -- A derived record type must finalize all inherited components. This
6966 -- action poses the following problem:
6968 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6973 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6975 -- Deep_Finalize (Obj._parent);
6980 -- Finalizing the derived type will invoke Finalize of the parent and
6981 -- then that of the derived type. This is undesirable because both
6982 -- routines may modify shared components. Only the Finalize of the
6983 -- derived type should be invoked.
6985 -- To prevent this double adjustment of shared components,
6986 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6988 -- procedure Deep_Finalize
6989 -- (Obj : in out Some_Type;
6990 -- Flag : Boolean := True)
6998 -- When Deep_Finalize is invokes for field _parent, a value of False
6999 -- is provided for the flag:
7001 -- Deep_Finalize (Obj._parent, False);
7003 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7005 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7010 if Needs_Finalization
(Par_Typ
) then
7014 Make_Selected_Component
(Loc
,
7015 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7017 Make_Identifier
(Loc
, Name_uParent
)),
7022 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
7024 -- begin -- Exceptions OK
7025 -- Deep_Finalize (V._parent, False);
7027 -- when Id : others =>
7028 -- if not Raised then
7030 -- Save_Occurrence (E,
7031 -- Get_Current_Excep.all.all);
7035 if Present
(Call
) then
7038 if Exceptions_OK
then
7040 Make_Block_Statement
(Loc
,
7041 Handled_Statement_Sequence
=>
7042 Make_Handled_Sequence_Of_Statements
(Loc
,
7043 Statements
=> New_List
(Fin_Stmt
),
7044 Exception_Handlers
=> New_List
(
7045 Build_Exception_Handler
7046 (Finalizer_Data
))));
7049 Append_To
(Bod_Stmts
, Fin_Stmt
);
7055 -- Finalize the object. This action must be performed first before
7056 -- all components have been finalized.
7058 if Is_Controlled
(Typ
) and then not Is_Local
then
7064 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
7068 -- Finalize (V); -- No_Exception_Propagation
7074 -- if not Raised then
7076 -- Save_Occurrence (E,
7077 -- Get_Current_Excep.all.all);
7082 if Present
(Proc
) then
7084 Make_Procedure_Call_Statement
(Loc
,
7085 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7086 Parameter_Associations
=> New_List
(
7087 Make_Identifier
(Loc
, Name_V
)));
7089 if Exceptions_OK
then
7091 Make_Block_Statement
(Loc
,
7092 Handled_Statement_Sequence
=>
7093 Make_Handled_Sequence_Of_Statements
(Loc
,
7094 Statements
=> New_List
(Fin_Stmt
),
7095 Exception_Handlers
=> New_List
(
7096 Build_Exception_Handler
7097 (Finalizer_Data
))));
7100 Prepend_To
(Bod_Stmts
,
7101 Make_If_Statement
(Loc
,
7102 Condition
=> Make_Identifier
(Loc
, Name_F
),
7103 Then_Statements
=> New_List
(Fin_Stmt
)));
7108 -- At this point either all finalization statements have been
7109 -- generated or the type is not controlled.
7111 if No
(Bod_Stmts
) then
7112 return New_List
(Make_Null_Statement
(Loc
));
7116 -- Abort : constant Boolean := Triggered_By_Abort;
7118 -- Abort : constant Boolean := False; -- no abort
7120 -- E : Exception_Occurence;
7121 -- Raised : Boolean := False;
7124 -- <finalize statements>
7126 -- if Raised and then not Abort then
7127 -- Raise_From_Controlled_Operation (E);
7132 if Exceptions_OK
then
7133 Append_To
(Bod_Stmts
,
7134 Build_Raise_Statement
(Finalizer_Data
));
7139 Make_Block_Statement
(Loc
,
7142 Handled_Statement_Sequence
=>
7143 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7145 end Build_Finalize_Statements
;
7147 -----------------------
7148 -- Parent_Field_Type --
7149 -----------------------
7151 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7155 Field
:= First_Entity
(Typ
);
7156 while Present
(Field
) loop
7157 if Chars
(Field
) = Name_uParent
then
7158 return Etype
(Field
);
7161 Next_Entity
(Field
);
7164 -- A derived tagged type should always have a parent field
7166 raise Program_Error
;
7167 end Parent_Field_Type
;
7169 ---------------------------
7170 -- Preprocess_Components --
7171 ---------------------------
7173 procedure Preprocess_Components
7175 Num_Comps
: out Int
;
7176 Has_POC
: out Boolean)
7186 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7187 while Present
(Decl
) loop
7188 Id
:= Defining_Identifier
(Decl
);
7191 -- Skip field _parent
7193 if Chars
(Id
) /= Name_uParent
7194 and then Needs_Finalization
(Typ
)
7196 Num_Comps
:= Num_Comps
+ 1;
7198 if Has_Access_Constraint
(Id
)
7199 and then No
(Expression
(Decl
))
7205 Next_Non_Pragma
(Decl
);
7207 end Preprocess_Components
;
7209 -- Start of processing for Make_Deep_Record_Body
7213 when Address_Case
=>
7214 return Make_Finalize_Address_Stmts
(Typ
);
7217 return Build_Adjust_Statements
(Typ
);
7219 when Finalize_Case
=>
7220 return Build_Finalize_Statements
(Typ
);
7222 when Initialize_Case
=>
7224 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7227 if Is_Controlled
(Typ
) then
7229 Make_Procedure_Call_Statement
(Loc
,
7232 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7233 Parameter_Associations
=> New_List
(
7234 Make_Identifier
(Loc
, Name_V
))));
7240 end Make_Deep_Record_Body
;
7242 ----------------------
7243 -- Make_Final_Call --
7244 ----------------------
7246 function Make_Final_Call
7249 Skip_Self
: Boolean := False) return Node_Id
7251 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7253 Fin_Id
: Entity_Id
:= Empty
;
7258 -- Recover the proper type which contains [Deep_]Finalize
7260 if Is_Class_Wide_Type
(Typ
) then
7261 Utyp
:= Root_Type
(Typ
);
7265 elsif Is_Concurrent_Type
(Typ
) then
7266 Utyp
:= Corresponding_Record_Type
(Typ
);
7268 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7270 elsif Is_Private_Type
(Typ
)
7271 and then Present
(Full_View
(Typ
))
7272 and then Is_Concurrent_Type
(Full_View
(Typ
))
7274 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7276 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7284 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7285 Set_Assignment_OK
(Ref
);
7287 -- Deal with untagged derivation of private views. If the parent type
7288 -- is a protected type, Deep_Finalize is found on the corresponding
7289 -- record of the ancestor.
7291 if Is_Untagged_Derivation
(Typ
) then
7292 if Is_Protected_Type
(Typ
) then
7293 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7295 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7297 if Is_Protected_Type
(Utyp
) then
7298 Utyp
:= Corresponding_Record_Type
(Utyp
);
7302 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7303 Set_Assignment_OK
(Ref
);
7306 -- Deal with derived private types which do not inherit primitives from
7307 -- their parents. In this case, [Deep_]Finalize can be found in the full
7308 -- view of the parent type.
7310 if Is_Tagged_Type
(Utyp
)
7311 and then Is_Derived_Type
(Utyp
)
7312 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7313 and then Is_Private_Type
(Etype
(Utyp
))
7314 and then Present
(Full_View
(Etype
(Utyp
)))
7316 Utyp
:= Full_View
(Etype
(Utyp
));
7317 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7318 Set_Assignment_OK
(Ref
);
7321 -- When dealing with the completion of a private type, use the base type
7324 if Utyp
/= Base_Type
(Utyp
) then
7325 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7327 Utyp
:= Base_Type
(Utyp
);
7328 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7329 Set_Assignment_OK
(Ref
);
7333 if Has_Controlled_Component
(Utyp
) then
7334 if Is_Tagged_Type
(Utyp
) then
7335 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7337 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7341 -- Class-wide types, interfaces and types with controlled components
7343 elsif Is_Class_Wide_Type
(Typ
)
7344 or else Is_Interface
(Typ
)
7345 or else Has_Controlled_Component
(Utyp
)
7347 if Is_Tagged_Type
(Utyp
) then
7348 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7350 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7353 -- Derivations from [Limited_]Controlled
7355 elsif Is_Controlled
(Utyp
) then
7356 if Has_Controlled_Component
(Utyp
) then
7357 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7359 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7364 elsif Is_Tagged_Type
(Utyp
) then
7365 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7368 raise Program_Error
;
7371 if Present
(Fin_Id
) then
7373 -- When finalizing a class-wide object, do not convert to the root
7374 -- type in order to produce a dispatching call.
7376 if Is_Class_Wide_Type
(Typ
) then
7379 -- Ensure that a finalization routine is at least decorated in order
7380 -- to inspect the object parameter.
7382 elsif Analyzed
(Fin_Id
)
7383 or else Ekind
(Fin_Id
) = E_Procedure
7385 -- In certain cases, such as the creation of Stream_Read, the
7386 -- visible entity of the type is its full view. Since Stream_Read
7387 -- will have to create an object of type Typ, the local object
7388 -- will be finalzed by the scope finalizer generated later on. The
7389 -- object parameter of Deep_Finalize will always use the private
7390 -- view of the type. To avoid such a clash between a private and a
7391 -- full view, perform an unchecked conversion of the object
7392 -- reference to the private view.
7395 Formal_Typ
: constant Entity_Id
:=
7396 Etype
(First_Formal
(Fin_Id
));
7398 if Is_Private_Type
(Formal_Typ
)
7399 and then Present
(Full_View
(Formal_Typ
))
7400 and then Full_View
(Formal_Typ
) = Utyp
7402 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7406 Ref
:= Convert_View
(Fin_Id
, Ref
);
7412 Param
=> New_Copy_Tree
(Ref
),
7413 Skip_Self
=> Skip_Self
);
7417 end Make_Final_Call
;
7419 --------------------------------
7420 -- Make_Finalize_Address_Body --
7421 --------------------------------
7423 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7424 Is_Task
: constant Boolean :=
7425 Ekind
(Typ
) = E_Record_Type
7426 and then Is_Concurrent_Record_Type
(Typ
)
7427 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7429 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7430 Proc_Id
: Entity_Id
;
7434 -- The corresponding records of task types are not controlled by design.
7435 -- For the sake of completeness, create an empty Finalize_Address to be
7436 -- used in task class-wide allocations.
7441 -- Nothing to do if the type is not controlled or it already has a
7442 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7443 -- come from source. These are usually generated for completeness and
7444 -- do not need the Finalize_Address primitive.
7446 elsif not Needs_Finalization
(Typ
)
7447 or else Is_Abstract_Type
(Typ
)
7448 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7450 (Is_Class_Wide_Type
(Typ
)
7451 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7452 and then not Comes_From_Source
(Root_Type
(Typ
)))
7458 Make_Defining_Identifier
(Loc
,
7459 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7463 -- procedure <Typ>FD (V : System.Address) is
7465 -- null; -- for tasks
7467 -- declare -- for all other types
7468 -- type Pnn is access all Typ;
7469 -- for Pnn'Storage_Size use 0;
7471 -- [Deep_]Finalize (Pnn (V).all);
7476 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7478 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7482 Make_Subprogram_Body
(Loc
,
7484 Make_Procedure_Specification
(Loc
,
7485 Defining_Unit_Name
=> Proc_Id
,
7487 Parameter_Specifications
=> New_List
(
7488 Make_Parameter_Specification
(Loc
,
7489 Defining_Identifier
=>
7490 Make_Defining_Identifier
(Loc
, Name_V
),
7492 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7494 Declarations
=> No_List
,
7496 Handled_Statement_Sequence
=>
7497 Make_Handled_Sequence_Of_Statements
(Loc
,
7498 Statements
=> Stmts
)));
7500 Set_TSS
(Typ
, Proc_Id
);
7501 end Make_Finalize_Address_Body
;
7503 ---------------------------------
7504 -- Make_Finalize_Address_Stmts --
7505 ---------------------------------
7507 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7508 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7509 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7511 Desg_Typ
: Entity_Id
;
7515 if Is_Array_Type
(Typ
) then
7516 if Is_Constrained
(First_Subtype
(Typ
)) then
7517 Desg_Typ
:= First_Subtype
(Typ
);
7519 Desg_Typ
:= Base_Type
(Typ
);
7522 -- Class-wide types of constrained root types
7524 elsif Is_Class_Wide_Type
(Typ
)
7525 and then Has_Discriminants
(Root_Type
(Typ
))
7527 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7530 Parent_Typ
: Entity_Id
;
7533 -- Climb the parent type chain looking for a non-constrained type
7535 Parent_Typ
:= Root_Type
(Typ
);
7536 while Parent_Typ
/= Etype
(Parent_Typ
)
7537 and then Has_Discriminants
(Parent_Typ
)
7539 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7541 Parent_Typ
:= Etype
(Parent_Typ
);
7544 -- Handle views created for tagged types with unknown
7547 if Is_Underlying_Record_View
(Parent_Typ
) then
7548 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7551 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7561 -- type Ptr_Typ is access all Typ;
7562 -- for Ptr_Typ'Storage_Size use 0;
7565 Make_Full_Type_Declaration
(Loc
,
7566 Defining_Identifier
=> Ptr_Typ
,
7568 Make_Access_To_Object_Definition
(Loc
,
7569 All_Present
=> True,
7570 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7572 Make_Attribute_Definition_Clause
(Loc
,
7573 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7574 Chars
=> Name_Storage_Size
,
7575 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7577 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7579 -- Unconstrained arrays require special processing in order to retrieve
7580 -- the elements. To achieve this, we have to skip the dope vector which
7581 -- lays in front of the elements and then use a thin pointer to perform
7582 -- the address-to-access conversion.
7584 if Is_Array_Type
(Typ
)
7585 and then not Is_Constrained
(First_Subtype
(Typ
))
7588 Dope_Id
: Entity_Id
;
7591 -- Ensure that Ptr_Typ a thin pointer, generate:
7592 -- for Ptr_Typ'Size use System.Address'Size;
7595 Make_Attribute_Definition_Clause
(Loc
,
7596 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7599 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7602 -- Dnn : constant Storage_Offset :=
7603 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7605 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7608 Make_Object_Declaration
(Loc
,
7609 Defining_Identifier
=> Dope_Id
,
7610 Constant_Present
=> True,
7611 Object_Definition
=>
7612 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7614 Make_Op_Divide
(Loc
,
7616 Make_Attribute_Reference
(Loc
,
7617 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7618 Attribute_Name
=> Name_Descriptor_Size
),
7620 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7622 -- Shift the address from the start of the dope vector to the
7623 -- start of the elements:
7627 -- Note that this is done through a wrapper routine since RTSfind
7628 -- cannot retrieve operations with string names of the form "+".
7631 Make_Function_Call
(Loc
,
7633 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7634 Parameter_Associations
=> New_List
(
7636 New_Occurrence_Of
(Dope_Id
, Loc
)));
7640 -- Create the block and the finalization call
7643 Make_Block_Statement
(Loc
,
7644 Declarations
=> Decls
,
7646 Handled_Statement_Sequence
=>
7647 Make_Handled_Sequence_Of_Statements
(Loc
,
7648 Statements
=> New_List
(
7651 Make_Explicit_Dereference
(Loc
,
7652 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7653 Typ
=> Desg_Typ
)))));
7654 end Make_Finalize_Address_Stmts
;
7656 -------------------------------------
7657 -- Make_Handler_For_Ctrl_Operation --
7658 -------------------------------------
7662 -- when E : others =>
7663 -- Raise_From_Controlled_Operation (E);
7668 -- raise Program_Error [finalize raised exception];
7670 -- depending on whether Raise_From_Controlled_Operation is available
7672 function Make_Handler_For_Ctrl_Operation
7673 (Loc
: Source_Ptr
) return Node_Id
7676 -- Choice parameter (for the first case above)
7678 Raise_Node
: Node_Id
;
7679 -- Procedure call or raise statement
7682 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7683 -- it to Raise_From_Controlled_Operation so that the original exception
7684 -- name and message can be recorded in the exception message for
7687 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7688 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7690 Make_Procedure_Call_Statement
(Loc
,
7693 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7694 Parameter_Associations
=> New_List
(
7695 New_Occurrence_Of
(E_Occ
, Loc
)));
7697 -- Restricted run-time: exception messages are not supported
7702 Make_Raise_Program_Error
(Loc
,
7703 Reason
=> PE_Finalize_Raised_Exception
);
7707 Make_Implicit_Exception_Handler
(Loc
,
7708 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7709 Choice_Parameter
=> E_Occ
,
7710 Statements
=> New_List
(Raise_Node
));
7711 end Make_Handler_For_Ctrl_Operation
;
7713 --------------------
7714 -- Make_Init_Call --
7715 --------------------
7717 function Make_Init_Call
7719 Typ
: Entity_Id
) return Node_Id
7721 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7728 -- Deal with the type and object reference. Depending on the context, an
7729 -- object reference may need several conversions.
7731 if Is_Concurrent_Type
(Typ
) then
7733 Utyp
:= Corresponding_Record_Type
(Typ
);
7734 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7736 elsif Is_Private_Type
(Typ
)
7737 and then Present
(Full_View
(Typ
))
7738 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7741 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7742 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7750 Set_Assignment_OK
(Ref
);
7752 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7754 -- Deal with untagged derivation of private views
7756 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
7757 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7758 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7760 -- The following is to prevent problems with UC see 1.156 RH ???
7762 Set_Assignment_OK
(Ref
);
7765 -- If the underlying_type is a subtype, then we are dealing with the
7766 -- completion of a private type. We need to access the base type and
7767 -- generate a conversion to it.
7769 if Utyp
/= Base_Type
(Utyp
) then
7770 pragma Assert
(Is_Private_Type
(Typ
));
7771 Utyp
:= Base_Type
(Utyp
);
7772 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7775 -- Select the appropriate version of initialize
7777 if Has_Controlled_Component
(Utyp
) then
7778 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7780 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7781 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7784 -- The object reference may need another conversion depending on the
7785 -- type of the formal and that of the actual.
7787 Ref
:= Convert_View
(Proc
, Ref
);
7790 -- [Deep_]Initialize (Ref);
7793 Make_Procedure_Call_Statement
(Loc
,
7795 New_Occurrence_Of
(Proc
, Loc
),
7796 Parameter_Associations
=> New_List
(Ref
));
7799 ------------------------------
7800 -- Make_Local_Deep_Finalize --
7801 ------------------------------
7803 function Make_Local_Deep_Finalize
7805 Nam
: Entity_Id
) return Node_Id
7807 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7811 Formals
:= New_List
(
7815 Make_Parameter_Specification
(Loc
,
7816 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7818 Out_Present
=> True,
7819 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
7821 -- F : Boolean := True
7823 Make_Parameter_Specification
(Loc
,
7824 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7825 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7826 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
7828 -- Add the necessary number of counters to represent the initialization
7829 -- state of an object.
7832 Make_Subprogram_Body
(Loc
,
7834 Make_Procedure_Specification
(Loc
,
7835 Defining_Unit_Name
=> Nam
,
7836 Parameter_Specifications
=> Formals
),
7838 Declarations
=> No_List
,
7840 Handled_Statement_Sequence
=>
7841 Make_Handled_Sequence_Of_Statements
(Loc
,
7842 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7843 end Make_Local_Deep_Finalize
;
7845 ------------------------------------
7846 -- Make_Set_Finalize_Address_Call --
7847 ------------------------------------
7849 function Make_Set_Finalize_Address_Call
7852 Ptr_Typ
: Entity_Id
) return Node_Id
7854 Desig_Typ
: constant Entity_Id
:=
7855 Available_View
(Designated_Type
(Ptr_Typ
));
7856 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7857 Fin_Mas_Ref
: Node_Id
;
7861 -- If the context is a class-wide allocator, we use the class-wide type
7862 -- to obtain the proper Finalize_Address routine.
7864 if Is_Class_Wide_Type
(Desig_Typ
) then
7870 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7871 Utyp
:= Full_View
(Utyp
);
7874 if Is_Concurrent_Type
(Utyp
) then
7875 Utyp
:= Corresponding_Record_Type
(Utyp
);
7879 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7881 -- Deal with untagged derivation of private views. If the parent is
7882 -- now known to be protected, the finalization routine is the one
7883 -- defined on the corresponding record of the ancestor (corresponding
7884 -- records do not automatically inherit operations, but maybe they
7887 if Is_Untagged_Derivation
(Typ
) then
7888 if Is_Protected_Type
(Typ
) then
7889 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7891 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7893 if Is_Protected_Type
(Utyp
) then
7894 Utyp
:= Corresponding_Record_Type
(Utyp
);
7899 -- If the underlying_type is a subtype, we are dealing with the
7900 -- completion of a private type. We need to access the base type and
7901 -- generate a conversion to it.
7903 if Utyp
/= Base_Type
(Utyp
) then
7904 pragma Assert
(Is_Private_Type
(Typ
));
7906 Utyp
:= Base_Type
(Utyp
);
7909 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7911 -- If the call is from a build-in-place function, the Master parameter
7912 -- is actually a pointer. Dereference it for the call.
7914 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7915 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7919 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7922 Make_Procedure_Call_Statement
(Loc
,
7924 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
7925 Parameter_Associations
=> New_List
(
7927 Make_Attribute_Reference
(Loc
,
7929 New_Occurrence_Of
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7930 Attribute_Name
=> Name_Unrestricted_Access
)));
7931 end Make_Set_Finalize_Address_Call
;
7933 --------------------------
7934 -- Make_Transient_Block --
7935 --------------------------
7937 function Make_Transient_Block
7940 Par
: Node_Id
) return Node_Id
7942 Decls
: constant List_Id
:= New_List
;
7943 Instrs
: constant List_Id
:= New_List
(Action
);
7948 -- Case where only secondary stack use is involved
7950 if VM_Target
= No_VM
7951 and then Uses_Sec_Stack
(Current_Scope
)
7952 and then Nkind
(Action
) /= N_Simple_Return_Statement
7953 and then Nkind
(Par
) /= N_Exception_Handler
7959 S
:= Scope
(Current_Scope
);
7961 -- At the outer level, no need to release the sec stack
7963 if S
= Standard_Standard
then
7964 Set_Uses_Sec_Stack
(Current_Scope
, False);
7967 -- In a function, only release the sec stack if the function
7968 -- does not return on the sec stack otherwise the result may
7969 -- be lost. The caller is responsible for releasing.
7971 elsif Ekind
(S
) = E_Function
then
7972 Set_Uses_Sec_Stack
(Current_Scope
, False);
7974 if not Requires_Transient_Scope
(Etype
(S
)) then
7975 Set_Uses_Sec_Stack
(S
, True);
7976 Check_Restriction
(No_Secondary_Stack
, Action
);
7981 -- In a loop or entry we should install a block encompassing
7982 -- all the construct. For now just release right away.
7984 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7987 -- In a procedure or a block, we release on exit of the
7988 -- procedure or block. ??? memory leak can be created by
7991 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7992 Set_Uses_Sec_Stack
(S
, True);
7993 Check_Restriction
(No_Secondary_Stack
, Action
);
7994 Set_Uses_Sec_Stack
(Current_Scope
, False);
8004 -- Create the transient block. Set the parent now since the block itself
8005 -- is not part of the tree. The current scope is the E_Block entity
8006 -- that has been pushed by Establish_Transient_Scope.
8008 pragma Assert
(Ekind
(Current_Scope
) = E_Block
);
8010 Make_Block_Statement
(Loc
,
8011 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
8012 Declarations
=> Decls
,
8013 Handled_Statement_Sequence
=>
8014 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8015 Has_Created_Identifier
=> True);
8016 Set_Parent
(Block
, Par
);
8018 -- Insert actions stuck in the transient scopes as well as all freezing
8019 -- nodes needed by those actions. Do not insert cleanup actions here,
8020 -- they will be transferred to the newly created block.
8022 Insert_Actions_In_Scope_Around
8023 (Action
, Clean
=> False, Manage_SS
=> False);
8025 Insert
:= Prev
(Action
);
8026 if Present
(Insert
) then
8027 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
8030 -- Transfer cleanup actions to the newly created block
8033 Cleanup_Actions
: List_Id
8034 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8035 Actions_To_Be_Wrapped
(Cleanup
);
8037 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8038 Cleanup_Actions
:= No_List
;
8041 -- When the transient scope was established, we pushed the entry for the
8042 -- transient scope onto the scope stack, so that the scope was active
8043 -- for the installation of finalizable entities etc. Now we must remove
8044 -- this entry, since we have constructed a proper block.
8049 end Make_Transient_Block
;
8051 ------------------------
8052 -- Node_To_Be_Wrapped --
8053 ------------------------
8055 function Node_To_Be_Wrapped
return Node_Id
is
8057 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8058 end Node_To_Be_Wrapped
;
8060 ----------------------------
8061 -- Set_Node_To_Be_Wrapped --
8062 ----------------------------
8064 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8066 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8067 end Set_Node_To_Be_Wrapped
;
8069 ----------------------------
8070 -- Store_Actions_In_Scope --
8071 ----------------------------
8073 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8074 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8075 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8078 if No
(Actions
) then
8081 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8082 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8084 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8089 elsif AK
= Before
then
8090 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8093 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8095 end Store_Actions_In_Scope
;
8097 ----------------------------------
8098 -- Store_After_Actions_In_Scope --
8099 ----------------------------------
8101 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8103 Store_Actions_In_Scope
(After
, L
);
8104 end Store_After_Actions_In_Scope
;
8106 -----------------------------------
8107 -- Store_Before_Actions_In_Scope --
8108 -----------------------------------
8110 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8112 Store_Actions_In_Scope
(Before
, L
);
8113 end Store_Before_Actions_In_Scope
;
8115 -----------------------------------
8116 -- Store_Cleanup_Actions_In_Scope --
8117 -----------------------------------
8119 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8121 Store_Actions_In_Scope
(Cleanup
, L
);
8122 end Store_Cleanup_Actions_In_Scope
;
8124 --------------------------------
8125 -- Wrap_Transient_Declaration --
8126 --------------------------------
8128 -- If a transient scope has been established during the processing of the
8129 -- Expression of an Object_Declaration, it is not possible to wrap the
8130 -- declaration into a transient block as usual case, otherwise the object
8131 -- would be itself declared in the wrong scope. Therefore, all entities (if
8132 -- any) defined in the transient block are moved to the proper enclosing
8133 -- scope. Furthermore, if they are controlled variables they are finalized
8134 -- right after the declaration. The finalization list of the transient
8135 -- scope is defined as a renaming of the enclosing one so during their
8136 -- initialization they will be attached to the proper finalization list.
8137 -- For instance, the following declaration :
8139 -- X : Typ := F (G (A), G (B));
8141 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8142 -- is expanded into :
8144 -- X : Typ := [ complex Expression-Action ];
8145 -- [Deep_]Finalize (_v1);
8146 -- [Deep_]Finalize (_v2);
8148 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8153 Curr_S
:= Current_Scope
;
8154 Encl_S
:= Scope
(Curr_S
);
8156 -- Insert all actions inluding cleanup generated while analyzing or
8157 -- expanding the transient context back into the tree. Manage the
8158 -- secondary stack when the object declaration appears in a library
8159 -- level package [body]. This is not needed for .NET/JVM as those do
8160 -- not support the secondary stack.
8162 Insert_Actions_In_Scope_Around
8167 and then Uses_Sec_Stack
(Curr_S
)
8168 and then Nkind
(N
) = N_Object_Declaration
8169 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8170 and then Is_Library_Level_Entity
(Encl_S
));
8173 -- Relocate local entities declared within the transient scope to the
8174 -- enclosing scope. This action sets their Is_Public flag accordingly.
8176 Transfer_Entities
(Curr_S
, Encl_S
);
8178 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8179 -- is properly released upon exiting the said scope. This is not needed
8180 -- for .NET/JVM as those do not support the secondary stack.
8182 if VM_Target
= No_VM
and then Uses_Sec_Stack
(Curr_S
) then
8183 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8185 -- Do not mark a function that returns on the secondary stack as the
8186 -- reclamation is done by the caller.
8188 if Ekind
(Curr_S
) = E_Function
8189 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8193 -- Otherwise mark the enclosing dynamic scope
8196 Set_Uses_Sec_Stack
(Curr_S
);
8197 Check_Restriction
(No_Secondary_Stack
, N
);
8200 end Wrap_Transient_Declaration
;
8202 -------------------------------
8203 -- Wrap_Transient_Expression --
8204 -------------------------------
8206 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8207 Loc
: constant Source_Ptr
:= Sloc
(N
);
8208 Expr
: Node_Id
:= Relocate_Node
(N
);
8209 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8210 Typ
: constant Entity_Id
:= Etype
(N
);
8217 -- M : constant Mark_Id := SS_Mark;
8218 -- procedure Finalizer is ... (See Build_Finalizer)
8221 -- Temp := <Expr>; -- general case
8222 -- Temp := (if <Expr> then True else False); -- boolean case
8228 -- A special case is made for Boolean expressions so that the back-end
8229 -- knows to generate a conditional branch instruction, if running with
8230 -- -fpreserve-control-flow. This ensures that a control flow change
8231 -- signalling the decision outcome occurs before the cleanup actions.
8233 if Opt
.Suppress_Control_Flow_Optimizations
8234 and then Is_Boolean_Type
(Typ
)
8237 Make_If_Expression
(Loc
,
8238 Expressions
=> New_List
(
8240 New_Occurrence_Of
(Standard_True
, Loc
),
8241 New_Occurrence_Of
(Standard_False
, Loc
)));
8244 Insert_Actions
(N
, New_List
(
8245 Make_Object_Declaration
(Loc
,
8246 Defining_Identifier
=> Temp
,
8247 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8249 Make_Transient_Block
(Loc
,
8251 Make_Assignment_Statement
(Loc
,
8252 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8253 Expression
=> Expr
),
8254 Par
=> Parent
(N
))));
8256 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8257 Analyze_And_Resolve
(N
, Typ
);
8258 end Wrap_Transient_Expression
;
8260 ------------------------------
8261 -- Wrap_Transient_Statement --
8262 ------------------------------
8264 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8265 Loc
: constant Source_Ptr
:= Sloc
(N
);
8266 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8271 -- M : constant Mark_Id := SS_Mark;
8272 -- procedure Finalizer is ... (See Build_Finalizer)
8282 Make_Transient_Block
(Loc
,
8284 Par
=> Parent
(N
)));
8286 -- With the scope stack back to normal, we can call analyze on the
8287 -- resulting block. At this point, the transient scope is being
8288 -- treated like a perfectly normal scope, so there is nothing
8289 -- special about it.
8291 -- Note: Wrap_Transient_Statement is called with the node already
8292 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8293 -- otherwise we would get a recursive processing of the node when
8294 -- we do this Analyze call.
8297 end Wrap_Transient_Statement
;