1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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
(N
: Node_Id
);
134 -- Insert the before-actions kept in the scope stack before N, and the
135 -- after-actions after N, which must be a member of a list.
137 function Make_Transient_Block
140 Par
: Node_Id
) return Node_Id
;
141 -- Action is a single statement or object declaration. Par is the proper
142 -- parent of the generated block. Create a transient block whose name is
143 -- the current scope and the only handled statement is Action. If Action
144 -- involves controlled objects or secondary stack usage, the corresponding
145 -- cleanup actions are performed at the end of the block.
147 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
148 -- Set the field Node_To_Be_Wrapped of the current scope
150 -- ??? The entire comment needs to be rewritten
151 -- ??? which entire comment?
153 -----------------------------
154 -- Finalization Management --
155 -----------------------------
157 -- This part describe how Initialization/Adjustment/Finalization procedures
158 -- are generated and called. Two cases must be considered, types that are
159 -- Controlled (Is_Controlled flag set) and composite types that contain
160 -- controlled components (Has_Controlled_Component flag set). In the first
161 -- case the procedures to call are the user-defined primitive operations
162 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
163 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
164 -- of calling the former procedures on the controlled components.
166 -- For records with Has_Controlled_Component set, a hidden "controller"
167 -- component is inserted. This controller component contains its own
168 -- finalization list on which all controlled components are attached
169 -- creating an indirection on the upper-level Finalization list. This
170 -- technique facilitates the management of objects whose number of
171 -- controlled components changes during execution. This controller
172 -- component is itself controlled and is attached to the upper-level
173 -- finalization chain. Its adjust primitive is in charge of calling adjust
174 -- on the components and adjusting the finalization pointer to match their
175 -- new location (see a-finali.adb).
177 -- It is not possible to use a similar technique for arrays that have
178 -- Has_Controlled_Component set. In this case, deep procedures are
179 -- generated that call initialize/adjust/finalize + attachment or
180 -- detachment on the finalization list for all component.
182 -- Initialize calls: they are generated for declarations or dynamic
183 -- allocations of Controlled objects with no initial value. They are always
184 -- followed by an attachment to the current Finalization Chain. For the
185 -- dynamic allocation case this the chain attached to the scope of the
186 -- access type definition otherwise, this is the chain of the current
189 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
190 -- or dynamic allocations of Controlled objects with an initial value.
191 -- (2) after an assignment. In the first case they are followed by an
192 -- attachment to the final chain, in the second case they are not.
194 -- Finalization Calls: They are generated on (1) scope exit, (2)
195 -- assignments, (3) unchecked deallocations. In case (3) they have to
196 -- be detached from the final chain, in case (2) they must not and in
197 -- case (1) this is not important since we are exiting the scope anyway.
201 -- Type extensions will have a new record controller at each derivation
202 -- level containing controlled components. The record controller for
203 -- the parent/ancestor is attached to the finalization list of the
204 -- extension's record controller (i.e. the parent is like a component
205 -- of the extension).
207 -- For types that are both Is_Controlled and Has_Controlled_Components,
208 -- the record controller and the object itself are handled separately.
209 -- It could seem simpler to attach the object at the end of its record
210 -- controller but this would not tackle view conversions properly.
212 -- A classwide type can always potentially have controlled components
213 -- but the record controller of the corresponding actual type may not
214 -- be known at compile time so the dispatch table contains a special
215 -- field that allows to compute the offset of the record controller
216 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
218 -- Here is a simple example of the expansion of a controlled block :
222 -- Y : Controlled := Init;
228 -- Z : R := (C => X);
238 -- _L : System.FI.Finalizable_Ptr;
240 -- procedure _Clean is
243 -- System.FI.Finalize_List (_L);
251 -- Attach_To_Final_List (_L, Finalizable (X), 1);
252 -- at end: Abort_Undefer;
253 -- Y : Controlled := Init;
255 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
263 -- Deep_Initialize (W, _L, 1);
264 -- at end: Abort_Under;
265 -- Z : R := (C => X);
266 -- Deep_Adjust (Z, _L, 1);
270 -- Deep_Finalize (W, False);
271 -- <save W's final pointers>
273 -- <restore W's final pointers>
274 -- Deep_Adjust (W, _L, 0);
279 type Final_Primitives
is
280 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
281 -- This enumeration type is defined in order to ease sharing code for
282 -- building finalization procedures for composite types.
284 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
285 (Initialize_Case
=> Name_Initialize
,
286 Adjust_Case
=> Name_Adjust
,
287 Finalize_Case
=> Name_Finalize
,
288 Address_Case
=> Name_Finalize_Address
);
289 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
290 (Initialize_Case
=> TSS_Deep_Initialize
,
291 Adjust_Case
=> TSS_Deep_Adjust
,
292 Finalize_Case
=> TSS_Deep_Finalize
,
293 Address_Case
=> TSS_Finalize_Address
);
295 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
296 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
297 -- Has_Controlled_Component set and store them using the TSS mechanism.
299 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
;
300 -- Create the clean up calls for an asynchronous call block, task master,
301 -- protected subprogram body, task allocation block or task body. If the
302 -- context does not contain the above constructs, the routine returns an
305 procedure Build_Finalizer
307 Clean_Stmts
: List_Id
;
310 Defer_Abort
: Boolean;
311 Fin_Id
: out Entity_Id
);
312 -- N may denote an accept statement, block, entry body, package body,
313 -- package spec, protected body, subprogram body, or a task body. Create
314 -- a procedure which contains finalization calls for all controlled objects
315 -- declared in the declarative or statement region of N. The calls are
316 -- built in reverse order relative to the original declarations. In the
317 -- case of a task body, the routine delays the creation of the finalizer
318 -- until all statements have been moved to the task body procedure.
319 -- Clean_Stmts may contain additional context-dependent code used to abort
320 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
321 -- Mark_Id is the secondary stack used in the current context or Empty if
322 -- missing. Top_Decls is the list on which the declaration of the finalizer
323 -- is attached in the non-package case. Defer_Abort indicates that the
324 -- statements passed in perform actions that require abort to be deferred,
325 -- such as for task termination. Fin_Id is the finalizer declaration
328 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
329 -- N is a construct which contains a handled sequence of statements, Fin_Id
330 -- is the entity of a finalizer. Create an At_End handler which covers the
331 -- statements of N and calls Fin_Id. If the handled statement sequence has
332 -- an exception handler, the statements will be wrapped in a block to avoid
333 -- unwanted interaction with the new At_End handler.
335 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
336 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
337 -- Has_Component_Component set and store them using the TSS mechanism.
339 procedure Check_Visibly_Controlled
340 (Prim
: Final_Primitives
;
342 E
: in out Entity_Id
;
343 Cref
: in out Node_Id
);
344 -- The controlled operation declared for a derived type may not be
345 -- overriding, if the controlled operations of the parent type are hidden,
346 -- for example when the parent is a private type whose full view is
347 -- controlled. For other primitive operations we modify the name of the
348 -- operation to indicate that it is not overriding, but this is not
349 -- possible for Initialize, etc. because they have to be retrievable by
350 -- name. Before generating the proper call to one of these operations we
351 -- check whether Typ is known to be controlled at the point of definition.
352 -- If it is not then we must retrieve the hidden operation of the parent
353 -- and use it instead. This is one case that might be solved more cleanly
354 -- once Overriding pragmas or declarations are in place.
356 function Convert_View
359 Ind
: Pos
:= 1) return Node_Id
;
360 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
361 -- argument being passed to it. Ind indicates which formal of procedure
362 -- Proc we are trying to match. This function will, if necessary, generate
363 -- a conversion between the partial and full view of Arg to match the type
364 -- of the formal of Proc, or force a conversion to the class-wide type in
365 -- the case where the operation is abstract.
367 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
368 -- Given an arbitrary entity, traverse the scope chain looking for the
369 -- first enclosing function. Return Empty if no function was found.
371 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
);
372 -- Subsidiary to the expansion of package specs and bodies. Generate a
373 -- runtime check needed to verify the assumption introduced by pragma
374 -- Initial_Condition. N denotes the package spec or body.
380 For_Parent
: Boolean := False) return Node_Id
;
381 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
382 -- routine [Deep_]Adjust / Finalize and an object parameter, create an
383 -- adjust / finalization call. Flag For_Parent should be set when field
384 -- _parent is being processed.
386 function Make_Deep_Proc
387 (Prim
: Final_Primitives
;
389 Stmts
: List_Id
) return Node_Id
;
390 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
391 -- Deep_Finalize procedures according to the first parameter, these
392 -- procedures operate on the type Typ. The Stmts parameter gives the body
395 function Make_Deep_Array_Body
396 (Prim
: Final_Primitives
;
397 Typ
: Entity_Id
) return List_Id
;
398 -- This function generates the list of statements for implementing
399 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
400 -- the first parameter, these procedures operate on the array type Typ.
402 function Make_Deep_Record_Body
403 (Prim
: Final_Primitives
;
405 Is_Local
: Boolean := False) return List_Id
;
406 -- This function generates the list of statements for implementing
407 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
408 -- the first parameter, these procedures operate on the record type Typ.
409 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
410 -- whether the inner logic should be dictated by state counters.
412 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
413 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
414 -- Make_Deep_Record_Body. Generate the following statements:
417 -- type Acc_Typ is access all Typ;
418 -- for Acc_Typ'Storage_Size use 0;
420 -- [Deep_]Finalize (Acc_Typ (V).all);
423 ----------------------------
424 -- Build_Array_Deep_Procs --
425 ----------------------------
427 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
431 (Prim
=> Initialize_Case
,
433 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
435 if not Is_Limited_View
(Typ
) then
438 (Prim
=> Adjust_Case
,
440 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
443 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
444 -- suppressed since these routine will not be used.
446 if not Restriction_Active
(No_Finalization
) then
449 (Prim
=> Finalize_Case
,
451 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
453 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
454 -- .NET do not support address arithmetic and unchecked conversions.
456 if VM_Target
= No_VM
then
459 (Prim
=> Address_Case
,
461 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
464 end Build_Array_Deep_Procs
;
466 ------------------------------
467 -- Build_Cleanup_Statements --
468 ------------------------------
470 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
is
471 Is_Asynchronous_Call
: constant Boolean :=
472 Nkind
(N
) = N_Block_Statement
473 and then Is_Asynchronous_Call_Block
(N
);
474 Is_Master
: constant Boolean :=
475 Nkind
(N
) /= N_Entry_Body
476 and then Is_Task_Master
(N
);
477 Is_Protected_Body
: constant Boolean :=
478 Nkind
(N
) = N_Subprogram_Body
479 and then Is_Protected_Subprogram_Body
(N
);
480 Is_Task_Allocation
: constant Boolean :=
481 Nkind
(N
) = N_Block_Statement
482 and then Is_Task_Allocation_Block
(N
);
483 Is_Task_Body
: constant Boolean :=
484 Nkind
(Original_Node
(N
)) = N_Task_Body
;
486 Loc
: constant Source_Ptr
:= Sloc
(N
);
487 Stmts
: constant List_Id
:= New_List
;
491 if Restricted_Profile
then
493 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
495 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
499 if Restriction_Active
(No_Task_Hierarchy
) = False then
500 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
503 -- Add statements to unlock the protected object parameter and to
504 -- undefer abort. If the context is a protected procedure and the object
505 -- has entries, call the entry service routine.
507 -- NOTE: The generated code references _object, a parameter to the
510 elsif Is_Protected_Body
then
512 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
513 Conc_Typ
: Entity_Id
;
516 Param_Typ
: Entity_Id
;
519 -- Find the _object parameter representing the protected object
521 Param
:= First
(Parameter_Specifications
(Spec
));
523 Param_Typ
:= Etype
(Parameter_Type
(Param
));
525 if Ekind
(Param_Typ
) = E_Record_Type
then
526 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
529 exit when No
(Param
) or else Present
(Conc_Typ
);
533 pragma Assert
(Present
(Param
));
535 -- If the associated protected object has entries, a protected
536 -- procedure has to service entry queues. In this case generate:
538 -- Service_Entries (_object._object'Access);
540 if Nkind
(Specification
(N
)) = N_Procedure_Specification
541 and then Has_Entries
(Conc_Typ
)
543 case Corresponding_Runtime_Package
(Conc_Typ
) is
544 when System_Tasking_Protected_Objects_Entries
=>
545 Nam
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
547 when System_Tasking_Protected_Objects_Single_Entry
=>
548 Nam
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
555 Make_Procedure_Call_Statement
(Loc
,
557 Parameter_Associations
=> New_List
(
558 Make_Attribute_Reference
(Loc
,
560 Make_Selected_Component
(Loc
,
561 Prefix
=> New_Reference_To
(
562 Defining_Identifier
(Param
), Loc
),
564 Make_Identifier
(Loc
, Name_uObject
)),
565 Attribute_Name
=> Name_Unchecked_Access
))));
569 -- Unlock (_object._object'Access);
571 case Corresponding_Runtime_Package
(Conc_Typ
) is
572 when System_Tasking_Protected_Objects_Entries
=>
573 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entries
), Loc
);
575 when System_Tasking_Protected_Objects_Single_Entry
=>
576 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entry
), Loc
);
578 when System_Tasking_Protected_Objects
=>
579 Nam
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
586 Make_Procedure_Call_Statement
(Loc
,
588 Parameter_Associations
=> New_List
(
589 Make_Attribute_Reference
(Loc
,
591 Make_Selected_Component
(Loc
,
594 (Defining_Identifier
(Param
), Loc
),
596 Make_Identifier
(Loc
, Name_uObject
)),
597 Attribute_Name
=> Name_Unchecked_Access
))));
603 if Abort_Allowed
then
605 Make_Procedure_Call_Statement
(Loc
,
607 New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
608 Parameter_Associations
=> Empty_List
));
612 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
613 -- tasks. Other unactivated tasks are completed by Complete_Task or
616 -- NOTE: The generated code references _chain, a local object
618 elsif Is_Task_Allocation
then
621 -- Expunge_Unactivated_Tasks (_chain);
623 -- where _chain is the list of tasks created by the allocator but not
624 -- yet activated. This list will be empty unless the block completes
628 Make_Procedure_Call_Statement
(Loc
,
631 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
632 Parameter_Associations
=> New_List
(
633 New_Reference_To
(Activation_Chain_Entity
(N
), Loc
))));
635 -- Attempt to cancel an asynchronous entry call whenever the block which
636 -- contains the abortable part is exited.
638 -- NOTE: The generated code references Cnn, a local object
640 elsif Is_Asynchronous_Call
then
642 Cancel_Param
: constant Entity_Id
:=
643 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
646 -- If it is of type Communication_Block, this must be a protected
647 -- entry call. Generate:
649 -- if Enqueued (Cancel_Param) then
650 -- Cancel_Protected_Entry_Call (Cancel_Param);
653 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
655 Make_If_Statement
(Loc
,
657 Make_Function_Call
(Loc
,
659 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
660 Parameter_Associations
=> New_List
(
661 New_Reference_To
(Cancel_Param
, Loc
))),
663 Then_Statements
=> New_List
(
664 Make_Procedure_Call_Statement
(Loc
,
667 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
668 Parameter_Associations
=> New_List
(
669 New_Reference_To
(Cancel_Param
, Loc
))))));
671 -- Asynchronous delay, generate:
672 -- Cancel_Async_Delay (Cancel_Param);
674 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
676 Make_Procedure_Call_Statement
(Loc
,
678 New_Reference_To
(RTE
(RE_Cancel_Async_Delay
), Loc
),
679 Parameter_Associations
=> New_List
(
680 Make_Attribute_Reference
(Loc
,
682 New_Reference_To
(Cancel_Param
, Loc
),
683 Attribute_Name
=> Name_Unchecked_Access
))));
685 -- Task entry call, generate:
686 -- Cancel_Task_Entry_Call (Cancel_Param);
690 Make_Procedure_Call_Statement
(Loc
,
692 New_Reference_To
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
693 Parameter_Associations
=> New_List
(
694 New_Reference_To
(Cancel_Param
, Loc
))));
700 end Build_Cleanup_Statements
;
702 -----------------------------
703 -- Build_Controlling_Procs --
704 -----------------------------
706 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
708 if Is_Array_Type
(Typ
) then
709 Build_Array_Deep_Procs
(Typ
);
710 else pragma Assert
(Is_Record_Type
(Typ
));
711 Build_Record_Deep_Procs
(Typ
);
713 end Build_Controlling_Procs
;
715 -----------------------------
716 -- Build_Exception_Handler --
717 -----------------------------
719 function Build_Exception_Handler
720 (Data
: Finalization_Exception_Data
;
721 For_Library
: Boolean := False) return Node_Id
724 Proc_To_Call
: Entity_Id
;
729 pragma Assert
(Present
(Data
.Raised_Id
));
731 if Exception_Extra_Info
732 or else (For_Library
and not Restricted_Profile
)
734 if Exception_Extra_Info
then
738 -- Get_Current_Excep.all
741 Make_Function_Call
(Data
.Loc
,
743 Make_Explicit_Dereference
(Data
.Loc
,
746 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
753 Except
:= Make_Null
(Data
.Loc
);
756 if For_Library
and then not Restricted_Profile
then
757 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
758 Actuals
:= New_List
(Except
);
761 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
763 -- The dereference occurs only when Exception_Extra_Info is true,
764 -- and therefore Except is not null.
768 New_Reference_To
(Data
.E_Id
, Data
.Loc
),
769 Make_Explicit_Dereference
(Data
.Loc
, Except
));
775 -- if not Raised_Id then
776 -- Raised_Id := True;
778 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
780 -- Save_Library_Occurrence (Get_Current_Excep.all);
785 Make_If_Statement
(Data
.Loc
,
787 Make_Op_Not
(Data
.Loc
,
788 Right_Opnd
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
)),
790 Then_Statements
=> New_List
(
791 Make_Assignment_Statement
(Data
.Loc
,
792 Name
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
793 Expression
=> New_Reference_To
(Standard_True
, Data
.Loc
)),
795 Make_Procedure_Call_Statement
(Data
.Loc
,
797 New_Reference_To
(Proc_To_Call
, Data
.Loc
),
798 Parameter_Associations
=> Actuals
))));
803 -- Raised_Id := True;
806 Make_Assignment_Statement
(Data
.Loc
,
807 Name
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
808 Expression
=> New_Reference_To
(Standard_True
, Data
.Loc
)));
816 Make_Exception_Handler
(Data
.Loc
,
817 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
818 Statements
=> Stmts
);
819 end Build_Exception_Handler
;
821 -------------------------------
822 -- Build_Finalization_Master --
823 -------------------------------
825 procedure Build_Finalization_Master
827 Ins_Node
: Node_Id
:= Empty
;
828 Encl_Scope
: Entity_Id
:= Empty
)
830 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
831 Ptr_Typ
: Entity_Id
:= Root_Type
(Base_Type
(Typ
));
833 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
834 -- Determine whether entity E is inside a wrapper package created for
835 -- an instance of Ada.Unchecked_Deallocation.
837 ------------------------------
838 -- In_Deallocation_Instance --
839 ------------------------------
841 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
842 Pkg
: constant Entity_Id
:= Scope
(E
);
843 Par
: Node_Id
:= Empty
;
846 if Ekind
(Pkg
) = E_Package
847 and then Present
(Related_Instance
(Pkg
))
848 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
850 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
854 and then Chars
(Par
) = Name_Unchecked_Deallocation
855 and then Chars
(Scope
(Par
)) = Name_Ada
856 and then Scope
(Scope
(Par
)) = Standard_Standard
;
860 end In_Deallocation_Instance
;
862 -- Start of processing for Build_Finalization_Master
865 if Is_Private_Type
(Ptr_Typ
)
866 and then Present
(Full_View
(Ptr_Typ
))
868 Ptr_Typ
:= Full_View
(Ptr_Typ
);
871 -- Certain run-time configurations and targets do not provide support
872 -- for controlled types.
874 if Restriction_Active
(No_Finalization
) then
877 -- Do not process C, C++, CIL and Java types since it is assumend that
878 -- the non-Ada side will handle their clean up.
880 elsif Convention
(Desig_Typ
) = Convention_C
881 or else Convention
(Desig_Typ
) = Convention_CIL
882 or else Convention
(Desig_Typ
) = Convention_CPP
883 or else Convention
(Desig_Typ
) = Convention_Java
887 -- Various machinery such as freezing may have already created a
888 -- finalization master.
890 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
893 -- Do not process types that return on the secondary stack
895 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
896 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
900 -- Do not process types which may never allocate an object
902 elsif No_Pool_Assigned
(Ptr_Typ
) then
905 -- Do not process access types coming from Ada.Unchecked_Deallocation
906 -- instances. Even though the designated type may be controlled, the
907 -- access type will never participate in allocation.
909 elsif In_Deallocation_Instance
(Ptr_Typ
) then
912 -- Ignore the general use of anonymous access types unless the context
913 -- requires a finalization master.
915 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
916 and then No
(Ins_Node
)
920 -- Do not process non-library access types when restriction No_Nested_
921 -- Finalization is in effect since masters are controlled objects.
923 elsif Restriction_Active
(No_Nested_Finalization
)
924 and then not Is_Library_Level_Entity
(Ptr_Typ
)
928 -- For .NET/JVM targets, allow the processing of access-to-controlled
929 -- types where the designated type is explicitly derived from [Limited_]
932 elsif VM_Target
/= No_VM
933 and then not Is_Controlled
(Desig_Typ
)
937 -- Do not create finalization masters in SPARK mode because they result
938 -- in unwanted expansion.
940 elsif SPARK_Mode
then
945 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
946 Actions
: constant List_Id
:= New_List
;
947 Fin_Mas_Id
: Entity_Id
;
952 -- Fnn : aliased Finalization_Master;
954 -- Source access types use fixed master names since the master is
955 -- inserted in the same source unit only once. The only exception to
956 -- this are instances using the same access type as generic actual.
958 if Comes_From_Source
(Ptr_Typ
)
959 and then not Inside_A_Generic
962 Make_Defining_Identifier
(Loc
,
963 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
965 -- Internally generated access types use temporaries as their names
966 -- due to possible collision with identical names coming from other
970 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
974 Make_Object_Declaration
(Loc
,
975 Defining_Identifier
=> Fin_Mas_Id
,
976 Aliased_Present
=> True,
978 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
)));
980 -- Storage pool selection and attribute decoration of the generated
981 -- master. Since .NET/JVM compilers do not support pools, this step
984 if VM_Target
= No_VM
then
986 -- If the access type has a user-defined pool, use it as the base
987 -- storage medium for the finalization pool.
989 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
990 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
992 -- The default choice is the global pool
995 Pool_Id
:= Get_Global_Pool_For_Access_Type
(Ptr_Typ
);
996 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1000 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
1003 Make_Procedure_Call_Statement
(Loc
,
1005 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
1006 Parameter_Associations
=> New_List
(
1007 New_Reference_To
(Fin_Mas_Id
, Loc
),
1008 Make_Attribute_Reference
(Loc
,
1009 Prefix
=> New_Reference_To
(Pool_Id
, Loc
),
1010 Attribute_Name
=> Name_Unrestricted_Access
))));
1013 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1015 -- A finalization master created for an anonymous access type must be
1016 -- inserted before a context-dependent node.
1018 if Present
(Ins_Node
) then
1019 Push_Scope
(Encl_Scope
);
1021 -- Treat use clauses as declarations and insert directly in front
1024 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
1027 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
1029 Insert_Actions
(Ins_Node
, Actions
);
1034 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
1035 and then Has_Completion_In_Body
(Desig_Typ
)
1037 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1039 -- If the designated type is not yet frozen, then append the actions
1040 -- to that type's freeze actions. The actions need to be appended to
1041 -- whichever type is frozen later, similarly to what Freeze_Type does
1042 -- for appending the storage pool declaration for an access type.
1043 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
1044 -- pool object before it's declared. However, it's not clear that
1045 -- this is exactly the right test to accomplish that here. ???
1047 elsif Present
(Freeze_Node
(Desig_Typ
))
1048 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
1050 Append_Freeze_Actions
(Desig_Typ
, Actions
);
1052 elsif Present
(Freeze_Node
(Ptr_Typ
))
1053 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
1055 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1057 -- If there's a pool created locally for the access type, then we
1058 -- need to ensure that the master gets created after the pool object,
1059 -- because otherwise we can have a forward reference, so we force the
1060 -- master actions to be inserted and analyzed after the pool entity.
1061 -- Note that both the access type and its designated type may have
1062 -- already been frozen and had their freezing actions analyzed at
1063 -- this point. (This seems a little unclean.???)
1065 elsif VM_Target
= No_VM
1066 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1068 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1071 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1074 end Build_Finalization_Master
;
1076 ---------------------
1077 -- Build_Finalizer --
1078 ---------------------
1080 procedure Build_Finalizer
1082 Clean_Stmts
: List_Id
;
1083 Mark_Id
: Entity_Id
;
1084 Top_Decls
: List_Id
;
1085 Defer_Abort
: Boolean;
1086 Fin_Id
: out Entity_Id
)
1088 Acts_As_Clean
: constant Boolean :=
1091 (Present
(Clean_Stmts
)
1092 and then Is_Non_Empty_List
(Clean_Stmts
));
1093 Exceptions_OK
: constant Boolean :=
1094 not Restriction_Active
(No_Exception_Propagation
);
1095 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1096 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1097 For_Package
: constant Boolean :=
1098 For_Package_Body
or else For_Package_Spec
;
1099 Loc
: constant Source_Ptr
:= Sloc
(N
);
1101 -- NOTE: Local variable declarations are conservative and do not create
1102 -- structures right from the start. Entities and lists are created once
1103 -- it has been established that N has at least one controlled object.
1105 Components_Built
: Boolean := False;
1106 -- A flag used to avoid double initialization of entities and lists. If
1107 -- the flag is set then the following variables have been initialized:
1113 Counter_Id
: Entity_Id
:= Empty
;
1114 Counter_Val
: Int
:= 0;
1115 -- Name and value of the state counter
1117 Decls
: List_Id
:= No_List
;
1118 -- Declarative region of N (if available). If N is a package declaration
1119 -- Decls denotes the visible declarations.
1121 Finalizer_Data
: Finalization_Exception_Data
;
1122 -- Data for the exception
1124 Finalizer_Decls
: List_Id
:= No_List
;
1125 -- Local variable declarations. This list holds the label declarations
1126 -- of all jump block alternatives as well as the declaration of the
1127 -- local exception occurence and the raised flag:
1128 -- E : Exception_Occurrence;
1129 -- Raised : Boolean := False;
1130 -- L<counter value> : label;
1132 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1133 -- Insertion point for the finalizer body. Depending on the context
1134 -- (Nkind of N) and the individual grouping of controlled objects, this
1135 -- node may denote a package declaration or body, package instantiation,
1136 -- block statement or a counter update statement.
1138 Finalizer_Stmts
: List_Id
:= No_List
;
1139 -- The statement list of the finalizer body. It contains the following:
1141 -- Abort_Defer; -- Added if abort is allowed
1142 -- <call to Prev_At_End> -- Added if exists
1143 -- <cleanup statements> -- Added if Acts_As_Clean
1144 -- <jump block> -- Added if Has_Ctrl_Objs
1145 -- <finalization statements> -- Added if Has_Ctrl_Objs
1146 -- <stack release> -- Added if Mark_Id exists
1147 -- Abort_Undefer; -- Added if abort is allowed
1149 Has_Ctrl_Objs
: Boolean := False;
1150 -- A general flag which denotes whether N has at least one controlled
1153 Has_Tagged_Types
: Boolean := False;
1154 -- A general flag which indicates whether N has at least one library-
1155 -- level tagged type declaration.
1157 HSS
: Node_Id
:= Empty
;
1158 -- The sequence of statements of N (if available)
1160 Jump_Alts
: List_Id
:= No_List
;
1161 -- Jump block alternatives. Depending on the value of the state counter,
1162 -- the control flow jumps to a sequence of finalization statements. This
1163 -- list contains the following:
1165 -- when <counter value> =>
1166 -- goto L<counter value>;
1168 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1169 -- Specific point in the finalizer statements where the jump block is
1172 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1173 -- The last controlled construct encountered when processing the top
1174 -- level lists of N. This can be a nested package, an instantiation or
1175 -- an object declaration.
1177 Prev_At_End
: Entity_Id
:= Empty
;
1178 -- The previous at end procedure of the handled statements block of N
1180 Priv_Decls
: List_Id
:= No_List
;
1181 -- The private declarations of N if N is a package declaration
1183 Spec_Id
: Entity_Id
:= Empty
;
1184 Spec_Decls
: List_Id
:= Top_Decls
;
1185 Stmts
: List_Id
:= No_List
;
1187 Tagged_Type_Stmts
: List_Id
:= No_List
;
1188 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1189 -- tagged types found in N.
1191 -----------------------
1192 -- Local subprograms --
1193 -----------------------
1195 procedure Build_Components
;
1196 -- Create all entites and initialize all lists used in the creation of
1199 procedure Create_Finalizer
;
1200 -- Create the spec and body of the finalizer and insert them in the
1201 -- proper place in the tree depending on the context.
1203 procedure Process_Declarations
1205 Preprocess
: Boolean := False;
1206 Top_Level
: Boolean := False);
1207 -- Inspect a list of declarations or statements which may contain
1208 -- objects that need finalization. When flag Preprocess is set, the
1209 -- routine will simply count the total number of controlled objects in
1210 -- Decls. Flag Top_Level denotes whether the processing is done for
1211 -- objects in nested package declarations or instances.
1213 procedure Process_Object_Declaration
1215 Has_No_Init
: Boolean := False;
1216 Is_Protected
: Boolean := False);
1217 -- Generate all the machinery associated with the finalization of a
1218 -- single object. Flag Has_No_Init is used to denote certain contexts
1219 -- where Decl does not have initialization call(s). Flag Is_Protected
1220 -- is set when Decl denotes a simple protected object.
1222 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1223 -- Generate all the code necessary to unregister the external tag of a
1226 ----------------------
1227 -- Build_Components --
1228 ----------------------
1230 procedure Build_Components
is
1231 Counter_Decl
: Node_Id
;
1232 Counter_Typ
: Entity_Id
;
1233 Counter_Typ_Decl
: Node_Id
;
1236 pragma Assert
(Present
(Decls
));
1238 -- This routine might be invoked several times when dealing with
1239 -- constructs that have two lists (either two declarative regions
1240 -- or declarations and statements). Avoid double initialization.
1242 if Components_Built
then
1246 Components_Built
:= True;
1248 if Has_Ctrl_Objs
then
1250 -- Create entities for the counter, its type, the local exception
1251 -- and the raised flag.
1253 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1254 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1256 Finalizer_Decls
:= New_List
;
1258 Build_Object_Declarations
1259 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1261 -- Since the total number of controlled objects is always known,
1262 -- build a subtype of Natural with precise bounds. This allows
1263 -- the backend to optimize the case statement. Generate:
1265 -- subtype Tnn is Natural range 0 .. Counter_Val;
1268 Make_Subtype_Declaration
(Loc
,
1269 Defining_Identifier
=> Counter_Typ
,
1270 Subtype_Indication
=>
1271 Make_Subtype_Indication
(Loc
,
1272 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
1274 Make_Range_Constraint
(Loc
,
1278 Make_Integer_Literal
(Loc
, Uint_0
),
1280 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1282 -- Generate the declaration of the counter itself:
1284 -- Counter : Integer := 0;
1287 Make_Object_Declaration
(Loc
,
1288 Defining_Identifier
=> Counter_Id
,
1289 Object_Definition
=> New_Reference_To
(Counter_Typ
, Loc
),
1290 Expression
=> Make_Integer_Literal
(Loc
, 0));
1292 -- Set the type of the counter explicitly to prevent errors when
1293 -- examining object declarations later on.
1295 Set_Etype
(Counter_Id
, Counter_Typ
);
1297 -- The counter and its type are inserted before the source
1298 -- declarations of N.
1300 Prepend_To
(Decls
, Counter_Decl
);
1301 Prepend_To
(Decls
, Counter_Typ_Decl
);
1303 -- The counter and its associated type must be manually analized
1304 -- since N has already been analyzed. Use the scope of the spec
1305 -- when inserting in a package.
1308 Push_Scope
(Spec_Id
);
1309 Analyze
(Counter_Typ_Decl
);
1310 Analyze
(Counter_Decl
);
1314 Analyze
(Counter_Typ_Decl
);
1315 Analyze
(Counter_Decl
);
1318 Jump_Alts
:= New_List
;
1321 -- If the context requires additional clean up, the finalization
1322 -- machinery is added after the clean up code.
1324 if Acts_As_Clean
then
1325 Finalizer_Stmts
:= Clean_Stmts
;
1326 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1328 Finalizer_Stmts
:= New_List
;
1331 if Has_Tagged_Types
then
1332 Tagged_Type_Stmts
:= New_List
;
1334 end Build_Components
;
1336 ----------------------
1337 -- Create_Finalizer --
1338 ----------------------
1340 procedure Create_Finalizer
is
1341 Body_Id
: Entity_Id
;
1344 Jump_Block
: Node_Id
;
1346 Label_Id
: Entity_Id
;
1348 function New_Finalizer_Name
return Name_Id
;
1349 -- Create a fully qualified name of a package spec or body finalizer.
1350 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1352 ------------------------
1353 -- New_Finalizer_Name --
1354 ------------------------
1356 function New_Finalizer_Name
return Name_Id
is
1357 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1358 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1359 -- has a non-standard scope, process the scope first.
1361 ------------------------
1362 -- New_Finalizer_Name --
1363 ------------------------
1365 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1367 if Scope
(Id
) = Standard_Standard
then
1368 Get_Name_String
(Chars
(Id
));
1371 New_Finalizer_Name
(Scope
(Id
));
1372 Add_Str_To_Name_Buffer
("__");
1373 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1375 end New_Finalizer_Name
;
1377 -- Start of processing for New_Finalizer_Name
1380 -- Create the fully qualified name of the enclosing scope
1382 New_Finalizer_Name
(Spec_Id
);
1385 -- __finalize_[spec|body]
1387 Add_Str_To_Name_Buffer
("__finalize_");
1389 if For_Package_Spec
then
1390 Add_Str_To_Name_Buffer
("spec");
1392 Add_Str_To_Name_Buffer
("body");
1396 end New_Finalizer_Name
;
1398 -- Start of processing for Create_Finalizer
1401 -- Step 1: Creation of the finalizer name
1403 -- Packages must use a distinct name for their finalizers since the
1404 -- binder will have to generate calls to them by name. The name is
1405 -- of the following form:
1407 -- xx__yy__finalize_[spec|body]
1410 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1411 Set_Has_Qualified_Name
(Fin_Id
);
1412 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1414 -- The default name is _finalizer
1418 Make_Defining_Identifier
(Loc
,
1419 Chars
=> New_External_Name
(Name_uFinalizer
));
1421 -- The visibility semantics of AT_END handlers force a strange
1422 -- separation of spec and body for stack-related finalizers:
1424 -- declare : Enclosing_Scope
1425 -- procedure _finalizer;
1427 -- <controlled objects>
1428 -- procedure _finalizer is
1434 -- Both spec and body are within the same construct and scope, but
1435 -- the body is part of the handled sequence of statements. This
1436 -- placement confuses the elaboration mechanism on targets where
1437 -- AT_END handlers are expanded into "when all others" handlers:
1440 -- when all others =>
1441 -- _finalizer; -- appears to require elab checks
1446 -- Since the compiler guarantees that the body of a _finalizer is
1447 -- always inserted in the same construct where the AT_END handler
1448 -- resides, there is no need for elaboration checks.
1450 Set_Kill_Elaboration_Checks
(Fin_Id
);
1453 -- Step 2: Creation of the finalizer specification
1456 -- procedure Fin_Id;
1459 Make_Subprogram_Declaration
(Loc
,
1461 Make_Procedure_Specification
(Loc
,
1462 Defining_Unit_Name
=> Fin_Id
));
1464 -- Step 3: Creation of the finalizer body
1466 if Has_Ctrl_Objs
then
1468 -- Add L0, the default destination to the jump block
1470 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1471 Set_Entity
(Label_Id
,
1472 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1473 Label
:= Make_Label
(Loc
, Label_Id
);
1478 Prepend_To
(Finalizer_Decls
,
1479 Make_Implicit_Label_Declaration
(Loc
,
1480 Defining_Identifier
=> Entity
(Label_Id
),
1481 Label_Construct
=> Label
));
1487 Append_To
(Jump_Alts
,
1488 Make_Case_Statement_Alternative
(Loc
,
1489 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1490 Statements
=> New_List
(
1491 Make_Goto_Statement
(Loc
,
1492 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
1497 Append_To
(Finalizer_Stmts
, Label
);
1499 -- Create the jump block which controls the finalization flow
1500 -- depending on the value of the state counter.
1503 Make_Case_Statement
(Loc
,
1504 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1505 Alternatives
=> Jump_Alts
);
1508 and then Present
(Jump_Block_Insert_Nod
)
1510 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1512 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1516 -- Add the library-level tagged type unregistration machinery before
1517 -- the jump block circuitry. This ensures that external tags will be
1518 -- removed even if a finalization exception occurs at some point.
1520 if Has_Tagged_Types
then
1521 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1524 -- Add a call to the previous At_End handler if it exists. The call
1525 -- must always precede the jump block.
1527 if Present
(Prev_At_End
) then
1528 Prepend_To
(Finalizer_Stmts
,
1529 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1531 -- Clear the At_End handler since we have already generated the
1532 -- proper replacement call for it.
1534 Set_At_End_Proc
(HSS
, Empty
);
1537 -- Release the secondary stack mark
1539 if Present
(Mark_Id
) then
1540 Append_To
(Finalizer_Stmts
,
1541 Make_Procedure_Call_Statement
(Loc
,
1543 New_Reference_To
(RTE
(RE_SS_Release
), Loc
),
1544 Parameter_Associations
=> New_List
(
1545 New_Reference_To
(Mark_Id
, Loc
))));
1548 -- Protect the statements with abort defer/undefer. This is only when
1549 -- aborts are allowed and the clean up statements require deferral or
1550 -- there are controlled objects to be finalized.
1554 (Defer_Abort
or else Has_Ctrl_Objs
)
1556 Prepend_To
(Finalizer_Stmts
,
1557 Make_Procedure_Call_Statement
(Loc
,
1558 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
)));
1560 Append_To
(Finalizer_Stmts
,
1561 Make_Procedure_Call_Statement
(Loc
,
1562 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
1565 -- The local exception does not need to be reraised for library-level
1566 -- finalizers. Note that this action must be carried out after object
1567 -- clean up, secondary stack release and abort undeferral. Generate:
1569 -- if Raised and then not Abort then
1570 -- Raise_From_Controlled_Operation (E);
1574 and then Exceptions_OK
1575 and then not For_Package
1577 Append_To
(Finalizer_Stmts
,
1578 Build_Raise_Statement
(Finalizer_Data
));
1582 -- procedure Fin_Id is
1583 -- Abort : constant Boolean := Triggered_By_Abort;
1585 -- Abort : constant Boolean := False; -- no abort
1587 -- E : Exception_Occurrence; -- All added if flag
1588 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1594 -- Abort_Defer; -- Added if abort is allowed
1595 -- <call to Prev_At_End> -- Added if exists
1596 -- <cleanup statements> -- Added if Acts_As_Clean
1597 -- <jump block> -- Added if Has_Ctrl_Objs
1598 -- <finalization statements> -- Added if Has_Ctrl_Objs
1599 -- <stack release> -- Added if Mark_Id exists
1600 -- Abort_Undefer; -- Added if abort is allowed
1601 -- <exception propagation> -- Added if Has_Ctrl_Objs
1604 -- Create the body of the finalizer
1606 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1609 Set_Has_Qualified_Name
(Body_Id
);
1610 Set_Has_Fully_Qualified_Name
(Body_Id
);
1614 Make_Subprogram_Body
(Loc
,
1616 Make_Procedure_Specification
(Loc
,
1617 Defining_Unit_Name
=> Body_Id
),
1618 Declarations
=> Finalizer_Decls
,
1619 Handled_Statement_Sequence
=>
1620 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1622 -- Step 4: Spec and body insertion, analysis
1626 -- If the package spec has private declarations, the finalizer
1627 -- body must be added to the end of the list in order to have
1628 -- visibility of all private controlled objects.
1630 if For_Package_Spec
then
1631 if Present
(Priv_Decls
) then
1632 Append_To
(Priv_Decls
, Fin_Spec
);
1633 Append_To
(Priv_Decls
, Fin_Body
);
1635 Append_To
(Decls
, Fin_Spec
);
1636 Append_To
(Decls
, Fin_Body
);
1639 -- For package bodies, both the finalizer spec and body are
1640 -- inserted at the end of the package declarations.
1643 Append_To
(Decls
, Fin_Spec
);
1644 Append_To
(Decls
, Fin_Body
);
1647 -- Push the name of the package
1649 Push_Scope
(Spec_Id
);
1657 -- Create the spec for the finalizer. The At_End handler must be
1658 -- able to call the body which resides in a nested structure.
1662 -- procedure Fin_Id; -- Spec
1664 -- <objects and possibly statements>
1665 -- procedure Fin_Id is ... -- Body
1668 -- Fin_Id; -- At_End handler
1671 pragma Assert
(Present
(Spec_Decls
));
1673 Append_To
(Spec_Decls
, Fin_Spec
);
1676 -- When the finalizer acts solely as a clean up routine, the body
1677 -- is inserted right after the spec.
1680 and then not Has_Ctrl_Objs
1682 Insert_After
(Fin_Spec
, Fin_Body
);
1684 -- In all other cases the body is inserted after either:
1686 -- 1) The counter update statement of the last controlled object
1687 -- 2) The last top level nested controlled package
1688 -- 3) The last top level controlled instantiation
1691 -- Manually freeze the spec. This is somewhat of a hack because
1692 -- a subprogram is frozen when its body is seen and the freeze
1693 -- node appears right before the body. However, in this case,
1694 -- the spec must be frozen earlier since the At_End handler
1695 -- must be able to call it.
1698 -- procedure Fin_Id; -- Spec
1699 -- [Fin_Id] -- Freeze node
1703 -- Fin_Id; -- At_End handler
1706 Ensure_Freeze_Node
(Fin_Id
);
1707 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1708 Set_Is_Frozen
(Fin_Id
);
1710 -- In the case where the last construct to contain a controlled
1711 -- object is either a nested package, an instantiation or a
1712 -- freeze node, the body must be inserted directly after the
1715 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1717 N_Package_Declaration
,
1720 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1723 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1728 end Create_Finalizer
;
1730 --------------------------
1731 -- Process_Declarations --
1732 --------------------------
1734 procedure Process_Declarations
1736 Preprocess
: Boolean := False;
1737 Top_Level
: Boolean := False)
1742 Obj_Typ
: Entity_Id
;
1743 Pack_Id
: Entity_Id
;
1747 Old_Counter_Val
: Int
;
1748 -- This variable is used to determine whether a nested package or
1749 -- instance contains at least one controlled object.
1751 procedure Processing_Actions
1752 (Has_No_Init
: Boolean := False;
1753 Is_Protected
: Boolean := False);
1754 -- Depending on the mode of operation of Process_Declarations, either
1755 -- increment the controlled object counter, set the controlled object
1756 -- flag and store the last top level construct or process the current
1757 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1758 -- the current declaration may not have initialization proc(s). Flag
1759 -- Is_Protected should be set when the current declaration denotes a
1760 -- simple protected object.
1762 ------------------------
1763 -- Processing_Actions --
1764 ------------------------
1766 procedure Processing_Actions
1767 (Has_No_Init
: Boolean := False;
1768 Is_Protected
: Boolean := False)
1771 -- Library-level tagged type
1773 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1775 Has_Tagged_Types
:= True;
1778 and then No
(Last_Top_Level_Ctrl_Construct
)
1780 Last_Top_Level_Ctrl_Construct
:= Decl
;
1784 Process_Tagged_Type_Declaration
(Decl
);
1787 -- Controlled object declaration
1791 Counter_Val
:= Counter_Val
+ 1;
1792 Has_Ctrl_Objs
:= True;
1795 and then No
(Last_Top_Level_Ctrl_Construct
)
1797 Last_Top_Level_Ctrl_Construct
:= Decl
;
1801 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1804 end Processing_Actions
;
1806 -- Start of processing for Process_Declarations
1809 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1813 -- Process all declarations in reverse order
1815 Decl
:= Last_Non_Pragma
(Decls
);
1816 while Present
(Decl
) loop
1818 -- Library-level tagged types
1820 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1821 Typ
:= Defining_Identifier
(Decl
);
1823 if Is_Tagged_Type
(Typ
)
1824 and then Is_Library_Level_Entity
(Typ
)
1825 and then Convention
(Typ
) = Convention_Ada
1826 and then Present
(Access_Disp_Table
(Typ
))
1827 and then RTE_Available
(RE_Register_Tag
)
1828 and then not No_Run_Time_Mode
1829 and then not Is_Abstract_Type
(Typ
)
1834 -- Regular object declarations
1836 elsif Nkind
(Decl
) = N_Object_Declaration
then
1837 Obj_Id
:= Defining_Identifier
(Decl
);
1838 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1839 Expr
:= Expression
(Decl
);
1841 -- Bypass any form of processing for objects which have their
1842 -- finalization disabled. This applies only to objects at the
1846 and then Finalize_Storage_Only
(Obj_Typ
)
1850 -- Transient variables are treated separately in order to
1851 -- minimize the size of the generated code. For details, see
1852 -- Process_Transient_Objects.
1854 elsif Is_Processed_Transient
(Obj_Id
) then
1857 -- The object is of the form:
1858 -- Obj : Typ [:= Expr];
1860 -- Do not process the incomplete view of a deferred constant.
1861 -- Do not consider tag-to-class-wide conversions.
1863 elsif not Is_Imported
(Obj_Id
)
1864 and then Needs_Finalization
(Obj_Typ
)
1865 and then not (Ekind
(Obj_Id
) = E_Constant
1866 and then not Has_Completion
(Obj_Id
))
1867 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1871 -- The object is of the form:
1872 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1874 -- Obj : Access_Typ :=
1875 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1877 elsif Is_Access_Type
(Obj_Typ
)
1878 and then Needs_Finalization
1879 (Available_View
(Designated_Type
(Obj_Typ
)))
1880 and then Present
(Expr
)
1882 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1884 (Is_Non_BIP_Func_Call
(Expr
)
1885 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1887 Processing_Actions
(Has_No_Init
=> True);
1889 -- Processing for "hook" objects generated for controlled
1890 -- transients declared inside an Expression_With_Actions.
1892 elsif Is_Access_Type
(Obj_Typ
)
1893 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1894 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1895 N_Object_Declaration
1896 and then Is_Finalizable_Transient
1897 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Decl
)
1899 Processing_Actions
(Has_No_Init
=> True);
1901 -- Process intermediate results of an if expression with one
1902 -- of the alternatives using a controlled function call.
1904 elsif Is_Access_Type
(Obj_Typ
)
1905 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1906 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1907 N_Defining_Identifier
1908 and then Present
(Expr
)
1909 and then Nkind
(Expr
) = N_Null
1911 Processing_Actions
(Has_No_Init
=> True);
1913 -- Simple protected objects which use type System.Tasking.
1914 -- Protected_Objects.Protection to manage their locks should
1915 -- be treated as controlled since they require manual cleanup.
1916 -- The only exception is illustrated in the following example:
1919 -- type Ctrl is new Controlled ...
1920 -- procedure Finalize (Obj : in out Ctrl);
1924 -- package body Pkg is
1925 -- protected Prot is
1926 -- procedure Do_Something (Obj : in out Ctrl);
1929 -- protected body Prot is
1930 -- procedure Do_Something (Obj : in out Ctrl) is ...
1933 -- procedure Finalize (Obj : in out Ctrl) is
1935 -- Prot.Do_Something (Obj);
1939 -- Since for the most part entities in package bodies depend on
1940 -- those in package specs, Prot's lock should be cleaned up
1941 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1942 -- This act however attempts to invoke Do_Something and fails
1943 -- because the lock has disappeared.
1945 elsif Ekind
(Obj_Id
) = E_Variable
1946 and then not In_Library_Level_Package_Body
(Obj_Id
)
1948 (Is_Simple_Protected_Type
(Obj_Typ
)
1949 or else Has_Simple_Protected_Object
(Obj_Typ
))
1951 Processing_Actions
(Is_Protected
=> True);
1954 -- Specific cases of object renamings
1956 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1957 Obj_Id
:= Defining_Identifier
(Decl
);
1958 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1960 -- Bypass any form of processing for objects which have their
1961 -- finalization disabled. This applies only to objects at the
1965 and then Finalize_Storage_Only
(Obj_Typ
)
1969 -- Return object of a build-in-place function. This case is
1970 -- recognized and marked by the expansion of an extended return
1971 -- statement (see Expand_N_Extended_Return_Statement).
1973 elsif Needs_Finalization
(Obj_Typ
)
1974 and then Is_Return_Object
(Obj_Id
)
1975 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1977 Processing_Actions
(Has_No_Init
=> True);
1979 -- Detect a case where a source object has been initialized by
1980 -- a controlled function call or another object which was later
1981 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1983 -- Obj1 : CW_Type := Src_Obj;
1984 -- Obj2 : CW_Type := Function_Call (...);
1986 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1987 -- Tmp : ... := Function_Call (...)'reference;
1988 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1990 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1991 Processing_Actions
(Has_No_Init
=> True);
1994 -- Inspect the freeze node of an access-to-controlled type and
1995 -- look for a delayed finalization master. This case arises when
1996 -- the freeze actions are inserted at a later time than the
1997 -- expansion of the context. Since Build_Finalizer is never called
1998 -- on a single construct twice, the master will be ultimately
1999 -- left out and never finalized. This is also needed for freeze
2000 -- actions of designated types themselves, since in some cases the
2001 -- finalization master is associated with a designated type's
2002 -- freeze node rather than that of the access type (see handling
2003 -- for freeze actions in Build_Finalization_Master).
2005 elsif Nkind
(Decl
) = N_Freeze_Entity
2006 and then Present
(Actions
(Decl
))
2008 Typ
:= Entity
(Decl
);
2010 if (Is_Access_Type
(Typ
)
2011 and then not Is_Access_Subprogram_Type
(Typ
)
2012 and then Needs_Finalization
2013 (Available_View
(Designated_Type
(Typ
))))
2014 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2016 Old_Counter_Val
:= Counter_Val
;
2018 -- Freeze nodes are considered to be identical to packages
2019 -- and blocks in terms of nesting. The difference is that
2020 -- a finalization master created inside the freeze node is
2021 -- at the same nesting level as the node itself.
2023 Process_Declarations
(Actions
(Decl
), Preprocess
);
2025 -- The freeze node contains a finalization master
2029 and then No
(Last_Top_Level_Ctrl_Construct
)
2030 and then Counter_Val
> Old_Counter_Val
2032 Last_Top_Level_Ctrl_Construct
:= Decl
;
2036 -- Nested package declarations, avoid generics
2038 elsif Nkind
(Decl
) = N_Package_Declaration
then
2039 Spec
:= Specification
(Decl
);
2040 Pack_Id
:= Defining_Unit_Name
(Spec
);
2042 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
2043 Pack_Id
:= Defining_Identifier
(Pack_Id
);
2046 if Ekind
(Pack_Id
) /= E_Generic_Package
then
2047 Old_Counter_Val
:= Counter_Val
;
2048 Process_Declarations
2049 (Private_Declarations
(Spec
), Preprocess
);
2050 Process_Declarations
2051 (Visible_Declarations
(Spec
), Preprocess
);
2053 -- Either the visible or the private declarations contain a
2054 -- controlled object. The nested package declaration is the
2055 -- last such construct.
2059 and then No
(Last_Top_Level_Ctrl_Construct
)
2060 and then Counter_Val
> Old_Counter_Val
2062 Last_Top_Level_Ctrl_Construct
:= Decl
;
2066 -- Nested package bodies, avoid generics
2068 elsif Nkind
(Decl
) = N_Package_Body
then
2069 Spec
:= Corresponding_Spec
(Decl
);
2071 if Ekind
(Spec
) /= E_Generic_Package
then
2072 Old_Counter_Val
:= Counter_Val
;
2073 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2075 -- The nested package body is the last construct to contain
2076 -- a controlled object.
2080 and then No
(Last_Top_Level_Ctrl_Construct
)
2081 and then Counter_Val
> Old_Counter_Val
2083 Last_Top_Level_Ctrl_Construct
:= Decl
;
2087 -- Handle a rare case caused by a controlled transient variable
2088 -- created as part of a record init proc. The variable is wrapped
2089 -- in a block, but the block is not associated with a transient
2092 elsif Nkind
(Decl
) = N_Block_Statement
2093 and then Inside_Init_Proc
2095 Old_Counter_Val
:= Counter_Val
;
2097 if Present
(Handled_Statement_Sequence
(Decl
)) then
2098 Process_Declarations
2099 (Statements
(Handled_Statement_Sequence
(Decl
)),
2103 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2105 -- Either the declaration or statement list of the block has a
2106 -- controlled object.
2110 and then No
(Last_Top_Level_Ctrl_Construct
)
2111 and then Counter_Val
> Old_Counter_Val
2113 Last_Top_Level_Ctrl_Construct
:= Decl
;
2116 -- Handle the case where the original context has been wrapped in
2117 -- a block to avoid interference between exception handlers and
2118 -- At_End handlers. Treat the block as transparent and process its
2121 elsif Nkind
(Decl
) = N_Block_Statement
2122 and then Is_Finalization_Wrapper
(Decl
)
2124 if Present
(Handled_Statement_Sequence
(Decl
)) then
2125 Process_Declarations
2126 (Statements
(Handled_Statement_Sequence
(Decl
)),
2130 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2133 Prev_Non_Pragma
(Decl
);
2135 end Process_Declarations
;
2137 --------------------------------
2138 -- Process_Object_Declaration --
2139 --------------------------------
2141 procedure Process_Object_Declaration
2143 Has_No_Init
: Boolean := False;
2144 Is_Protected
: Boolean := False)
2146 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2147 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2149 Count_Ins
: Node_Id
;
2151 Fin_Stmts
: List_Id
;
2154 Label_Id
: Entity_Id
;
2156 Obj_Typ
: Entity_Id
;
2158 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2159 -- Once it has been established that the current object is in fact a
2160 -- return object of build-in-place function Func_Id, generate the
2161 -- following cleanup code:
2163 -- if BIPallocfrom > Secondary_Stack'Pos
2164 -- and then BIPfinalizationmaster /= null
2167 -- type Ptr_Typ is access Obj_Typ;
2168 -- for Ptr_Typ'Storage_Pool
2169 -- use Base_Pool (BIPfinalizationmaster);
2171 -- Free (Ptr_Typ (Temp));
2175 -- Obj_Typ is the type of the current object, Temp is the original
2176 -- allocation which Obj_Id renames.
2178 procedure Find_Last_Init
2181 Last_Init
: out Node_Id
;
2182 Body_Insert
: out Node_Id
);
2183 -- An object declaration has at least one and at most two init calls:
2184 -- that of the type and the user-defined initialize. Given an object
2185 -- declaration, Last_Init denotes the last initialization call which
2186 -- follows the declaration. Body_Insert denotes the place where the
2187 -- finalizer body could be potentially inserted.
2189 -----------------------------
2190 -- Build_BIP_Cleanup_Stmts --
2191 -----------------------------
2193 function Build_BIP_Cleanup_Stmts
2194 (Func_Id
: Entity_Id
) return Node_Id
2196 Decls
: constant List_Id
:= New_List
;
2197 Fin_Mas_Id
: constant Entity_Id
:=
2198 Build_In_Place_Formal
2199 (Func_Id
, BIP_Finalization_Master
);
2200 Obj_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2201 Temp_Id
: constant Entity_Id
:=
2202 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2206 Free_Stmt
: Node_Id
;
2207 Pool_Id
: Entity_Id
;
2208 Ptr_Typ
: Entity_Id
;
2212 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2214 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2217 Make_Object_Renaming_Declaration
(Loc
,
2218 Defining_Identifier
=> Pool_Id
,
2220 New_Reference_To
(RTE
(RE_Root_Storage_Pool
), Loc
),
2222 Make_Explicit_Dereference
(Loc
,
2224 Make_Function_Call
(Loc
,
2226 New_Reference_To
(RTE
(RE_Base_Pool
), Loc
),
2227 Parameter_Associations
=> New_List
(
2228 Make_Explicit_Dereference
(Loc
,
2229 Prefix
=> New_Reference_To
(Fin_Mas_Id
, Loc
)))))));
2231 -- Create an access type which uses the storage pool of the
2232 -- caller's finalization master.
2235 -- type Ptr_Typ is access Obj_Typ;
2237 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2240 Make_Full_Type_Declaration
(Loc
,
2241 Defining_Identifier
=> Ptr_Typ
,
2243 Make_Access_To_Object_Definition
(Loc
,
2244 Subtype_Indication
=> New_Reference_To
(Obj_Typ
, Loc
))));
2246 -- Perform minor decoration in order to set the master and the
2247 -- storage pool attributes.
2249 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2250 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2251 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2253 -- Create an explicit free statement. Note that the free uses the
2254 -- caller's pool expressed as a renaming.
2257 Make_Free_Statement
(Loc
,
2259 Unchecked_Convert_To
(Ptr_Typ
,
2260 New_Reference_To
(Temp_Id
, Loc
)));
2262 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2264 -- Create a block to house the dummy type and the instantiation as
2265 -- well as to perform the cleanup the temporary.
2271 -- Free (Ptr_Typ (Temp_Id));
2275 Make_Block_Statement
(Loc
,
2276 Declarations
=> Decls
,
2277 Handled_Statement_Sequence
=>
2278 Make_Handled_Sequence_Of_Statements
(Loc
,
2279 Statements
=> New_List
(Free_Stmt
)));
2282 -- if BIPfinalizationmaster /= null then
2286 Left_Opnd
=> New_Reference_To
(Fin_Mas_Id
, Loc
),
2287 Right_Opnd
=> Make_Null
(Loc
));
2289 -- For constrained or tagged results escalate the condition to
2290 -- include the allocation format. Generate:
2292 -- if BIPallocform > Secondary_Stack'Pos
2293 -- and then BIPfinalizationmaster /= null
2296 if not Is_Constrained
(Obj_Typ
)
2297 or else Is_Tagged_Type
(Obj_Typ
)
2300 Alloc
: constant Entity_Id
:=
2301 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2307 Left_Opnd
=> New_Reference_To
(Alloc
, Loc
),
2309 Make_Integer_Literal
(Loc
,
2311 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2313 Right_Opnd
=> Cond
);
2323 Make_If_Statement
(Loc
,
2325 Then_Statements
=> New_List
(Free_Blk
));
2326 end Build_BIP_Cleanup_Stmts
;
2328 --------------------
2329 -- Find_Last_Init --
2330 --------------------
2332 procedure Find_Last_Init
2335 Last_Init
: out Node_Id
;
2336 Body_Insert
: out Node_Id
)
2338 Nod_1
: Node_Id
:= Empty
;
2339 Nod_2
: Node_Id
:= Empty
;
2342 function Is_Init_Call
2344 Typ
: Entity_Id
) return Boolean;
2345 -- Given an arbitrary node, determine whether N is a procedure
2346 -- call and if it is, try to match the name of the call with the
2347 -- [Deep_]Initialize proc of Typ.
2349 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2350 -- Given a statement which is part of a list, return the next
2351 -- real statement while skipping over dynamic elab checks.
2357 function Is_Init_Call
2359 Typ
: Entity_Id
) return Boolean
2362 -- A call to [Deep_]Initialize is always direct
2364 if Nkind
(N
) = N_Procedure_Call_Statement
2365 and then Nkind
(Name
(N
)) = N_Identifier
2368 Call_Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2369 Deep_Init
: constant Entity_Id
:=
2370 TSS
(Typ
, TSS_Deep_Initialize
);
2371 Init
: Entity_Id
:= Empty
;
2374 -- A type may have controlled components but not be
2377 if Is_Controlled
(Typ
) then
2378 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2380 if Present
(Init
) then
2381 Init
:= Ultimate_Alias
(Init
);
2386 (Present
(Deep_Init
) and then Call_Ent
= Deep_Init
)
2388 (Present
(Init
) and then Call_Ent
= Init
);
2395 -----------------------------
2396 -- Next_Suitable_Statement --
2397 -----------------------------
2399 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2400 Result
: Node_Id
:= Next
(Stmt
);
2403 -- Skip over access-before-elaboration checks
2405 if Dynamic_Elaboration_Checks
2406 and then Nkind
(Result
) = N_Raise_Program_Error
2408 Result
:= Next
(Result
);
2412 end Next_Suitable_Statement
;
2414 -- Start of processing for Find_Last_Init
2418 Body_Insert
:= Empty
;
2420 -- Object renamings and objects associated with controlled
2421 -- function results do not have initialization calls.
2427 if Is_Concurrent_Type
(Typ
) then
2428 Utyp
:= Corresponding_Record_Type
(Typ
);
2433 if Is_Private_Type
(Utyp
)
2434 and then Present
(Full_View
(Utyp
))
2436 Utyp
:= Full_View
(Utyp
);
2439 -- The init procedures are arranged as follows:
2441 -- Object : Controlled_Type;
2442 -- Controlled_TypeIP (Object);
2443 -- [[Deep_]Initialize (Object);]
2445 -- where the user-defined initialize may be optional or may appear
2446 -- inside a block when abort deferral is needed.
2448 Nod_1
:= Next_Suitable_Statement
(Decl
);
2449 if Present
(Nod_1
) then
2450 Nod_2
:= Next_Suitable_Statement
(Nod_1
);
2452 -- The statement following an object declaration is always a
2453 -- call to the type init proc.
2458 -- Optional user-defined init or deep init processing
2460 if Present
(Nod_2
) then
2462 -- The statement following the type init proc may be a block
2463 -- statement in cases where abort deferral is required.
2465 if Nkind
(Nod_2
) = N_Block_Statement
then
2467 HSS
: constant Node_Id
:=
2468 Handled_Statement_Sequence
(Nod_2
);
2473 and then Present
(Statements
(HSS
))
2475 Stmt
:= First
(Statements
(HSS
));
2477 -- Examine individual block statements and locate the
2478 -- call to [Deep_]Initialze.
2480 while Present
(Stmt
) loop
2481 if Is_Init_Call
(Stmt
, Utyp
) then
2483 Body_Insert
:= Nod_2
;
2493 elsif Is_Init_Call
(Nod_2
, Utyp
) then
2499 -- Start of processing for Process_Object_Declaration
2502 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
2503 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2505 -- Handle access types
2507 if Is_Access_Type
(Obj_Typ
) then
2508 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2509 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2512 Set_Etype
(Obj_Ref
, Obj_Typ
);
2514 -- Set a new value for the state counter and insert the statement
2515 -- after the object declaration. Generate:
2517 -- Counter := <value>;
2520 Make_Assignment_Statement
(Loc
,
2521 Name
=> New_Reference_To
(Counter_Id
, Loc
),
2522 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2524 -- Insert the counter after all initialization has been done. The
2525 -- place of insertion depends on the context. When dealing with a
2526 -- controlled function, the counter is inserted directly after the
2527 -- declaration because such objects lack init calls.
2529 Find_Last_Init
(Decl
, Obj_Typ
, Count_Ins
, Body_Ins
);
2531 Insert_After
(Count_Ins
, Inc_Decl
);
2534 -- If the current declaration is the last in the list, the finalizer
2535 -- body needs to be inserted after the set counter statement for the
2536 -- current object declaration. This is complicated by the fact that
2537 -- the set counter statement may appear in abort deferred block. In
2538 -- that case, the proper insertion place is after the block.
2540 if No
(Finalizer_Insert_Nod
) then
2542 -- Insertion after an abort deffered block
2544 if Present
(Body_Ins
) then
2545 Finalizer_Insert_Nod
:= Body_Ins
;
2547 Finalizer_Insert_Nod
:= Inc_Decl
;
2551 -- Create the associated label with this object, generate:
2553 -- L<counter> : label;
2556 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2558 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2559 Label
:= Make_Label
(Loc
, Label_Id
);
2561 Prepend_To
(Finalizer_Decls
,
2562 Make_Implicit_Label_Declaration
(Loc
,
2563 Defining_Identifier
=> Entity
(Label_Id
),
2564 Label_Construct
=> Label
));
2566 -- Create the associated jump with this object, generate:
2568 -- when <counter> =>
2571 Prepend_To
(Jump_Alts
,
2572 Make_Case_Statement_Alternative
(Loc
,
2573 Discrete_Choices
=> New_List
(
2574 Make_Integer_Literal
(Loc
, Counter_Val
)),
2575 Statements
=> New_List
(
2576 Make_Goto_Statement
(Loc
,
2577 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
2579 -- Insert the jump destination, generate:
2583 Append_To
(Finalizer_Stmts
, Label
);
2585 -- Processing for simple protected objects. Such objects require
2586 -- manual finalization of their lock managers.
2588 if Is_Protected
then
2589 Fin_Stmts
:= No_List
;
2591 if Is_Simple_Protected_Type
(Obj_Typ
) then
2592 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2594 if Present
(Fin_Call
) then
2595 Fin_Stmts
:= New_List
(Fin_Call
);
2598 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2599 if Is_Record_Type
(Obj_Typ
) then
2600 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2601 elsif Is_Array_Type
(Obj_Typ
) then
2602 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2608 -- System.Tasking.Protected_Objects.Finalize_Protection
2616 if Present
(Fin_Stmts
) then
2617 Append_To
(Finalizer_Stmts
,
2618 Make_Block_Statement
(Loc
,
2619 Handled_Statement_Sequence
=>
2620 Make_Handled_Sequence_Of_Statements
(Loc
,
2621 Statements
=> Fin_Stmts
,
2623 Exception_Handlers
=> New_List
(
2624 Make_Exception_Handler
(Loc
,
2625 Exception_Choices
=> New_List
(
2626 Make_Others_Choice
(Loc
)),
2628 Statements
=> New_List
(
2629 Make_Null_Statement
(Loc
)))))));
2632 -- Processing for regular controlled objects
2636 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2638 -- begin -- Exception handlers allowed
2639 -- [Deep_]Finalize (Obj);
2642 -- when Id : others =>
2643 -- if not Raised then
2645 -- Save_Occurrence (E, Id);
2654 -- For CodePeer, the exception handlers normally generated here
2655 -- generate complex flowgraphs which result in capacity problems.
2656 -- Omitting these handlers for CodePeer is justified as follows:
2658 -- If a handler is dead, then omitting it is surely ok
2660 -- If a handler is live, then CodePeer should flag the
2661 -- potentially-exception-raising construct that causes it
2662 -- to be live. That is what we are interested in, not what
2663 -- happens after the exception is raised.
2665 if Exceptions_OK
and not CodePeer_Mode
then
2666 Fin_Stmts
:= New_List
(
2667 Make_Block_Statement
(Loc
,
2668 Handled_Statement_Sequence
=>
2669 Make_Handled_Sequence_Of_Statements
(Loc
,
2670 Statements
=> New_List
(Fin_Call
),
2672 Exception_Handlers
=> New_List
(
2673 Build_Exception_Handler
2674 (Finalizer_Data
, For_Package
)))));
2676 -- When exception handlers are prohibited, the finalization call
2677 -- appears unprotected. Any exception raised during finalization
2678 -- will bypass the circuitry which ensures the cleanup of all
2679 -- remaining objects.
2682 Fin_Stmts
:= New_List
(Fin_Call
);
2685 -- If we are dealing with a return object of a build-in-place
2686 -- function, generate the following cleanup statements:
2688 -- if BIPallocfrom > Secondary_Stack'Pos
2689 -- and then BIPfinalizationmaster /= null
2692 -- type Ptr_Typ is access Obj_Typ;
2693 -- for Ptr_Typ'Storage_Pool use
2694 -- Base_Pool (BIPfinalizationmaster.all).all;
2696 -- Free (Ptr_Typ (Temp));
2700 -- The generated code effectively detaches the temporary from the
2701 -- caller finalization master and deallocates the object. This is
2702 -- disabled on .NET/JVM because pools are not supported.
2704 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2706 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2708 if Is_Build_In_Place_Function
(Func_Id
)
2709 and then Needs_BIP_Finalization_Master
(Func_Id
)
2711 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2716 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2717 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2719 -- Temporaries created for the purpose of "exporting" a
2720 -- controlled transient out of an Expression_With_Actions (EWA)
2721 -- need guards. The following illustrates the usage of such
2724 -- Access_Typ : access [all] Obj_Typ;
2725 -- Temp : Access_Typ := null;
2726 -- <Counter> := ...;
2729 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2730 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2732 -- Temp := Ctrl_Trans'Unchecked_Access;
2735 -- The finalization machinery does not process EWA nodes as
2736 -- this may lead to premature finalization of expressions. Note
2737 -- that Temp is marked as being properly initialized regardless
2738 -- of whether the initialization of Ctrl_Trans succeeded. Since
2739 -- a failed initialization may leave Temp with a value of null,
2740 -- add a guard to handle this case:
2742 -- if Obj /= null then
2743 -- <object finalization statements>
2746 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2747 N_Object_Declaration
2749 Fin_Stmts
:= New_List
(
2750 Make_If_Statement
(Loc
,
2753 Left_Opnd
=> New_Reference_To
(Obj_Id
, Loc
),
2754 Right_Opnd
=> Make_Null
(Loc
)),
2755 Then_Statements
=> Fin_Stmts
));
2757 -- Return objects use a flag to aid in processing their
2758 -- potential finalization when the enclosing function fails
2759 -- to return properly. Generate:
2762 -- <object finalization statements>
2766 Fin_Stmts
:= New_List
(
2767 Make_If_Statement
(Loc
,
2772 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2774 Then_Statements
=> Fin_Stmts
));
2779 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2781 -- Since the declarations are examined in reverse, the state counter
2782 -- must be decremented in order to keep with the true position of
2785 Counter_Val
:= Counter_Val
- 1;
2786 end Process_Object_Declaration
;
2788 -------------------------------------
2789 -- Process_Tagged_Type_Declaration --
2790 -------------------------------------
2792 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2793 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2794 DT_Ptr
: constant Entity_Id
:=
2795 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2798 -- Ada.Tags.Unregister_Tag (<Typ>P);
2800 Append_To
(Tagged_Type_Stmts
,
2801 Make_Procedure_Call_Statement
(Loc
,
2803 New_Reference_To
(RTE
(RE_Unregister_Tag
), Loc
),
2804 Parameter_Associations
=> New_List
(
2805 New_Reference_To
(DT_Ptr
, Loc
))));
2806 end Process_Tagged_Type_Declaration
;
2808 -- Start of processing for Build_Finalizer
2813 -- Do not perform this expansion in SPARK mode because it is not
2820 -- Step 1: Extract all lists which may contain controlled objects or
2821 -- library-level tagged types.
2823 if For_Package_Spec
then
2824 Decls
:= Visible_Declarations
(Specification
(N
));
2825 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2827 -- Retrieve the package spec id
2829 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2831 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2832 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2835 -- Accept statement, block, entry body, package body, protected body,
2836 -- subprogram body or task body.
2839 Decls
:= Declarations
(N
);
2840 HSS
:= Handled_Statement_Sequence
(N
);
2842 if Present
(HSS
) then
2843 if Present
(Statements
(HSS
)) then
2844 Stmts
:= Statements
(HSS
);
2847 if Present
(At_End_Proc
(HSS
)) then
2848 Prev_At_End
:= At_End_Proc
(HSS
);
2852 -- Retrieve the package spec id for package bodies
2854 if For_Package_Body
then
2855 Spec_Id
:= Corresponding_Spec
(N
);
2859 -- Do not process nested packages since those are handled by the
2860 -- enclosing scope's finalizer. Do not process non-expanded package
2861 -- instantiations since those will be re-analyzed and re-expanded.
2865 (not Is_Library_Level_Entity
(Spec_Id
)
2867 -- Nested packages are considered to be library level entities,
2868 -- but do not need to be processed separately. True library level
2869 -- packages have a scope value of 1.
2871 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2872 or else (Is_Generic_Instance
(Spec_Id
)
2873 and then Package_Instantiation
(Spec_Id
) /= N
))
2878 -- Step 2: Object [pre]processing
2882 -- Preprocess the visible declarations now in order to obtain the
2883 -- correct number of controlled object by the time the private
2884 -- declarations are processed.
2886 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2888 -- From all the possible contexts, only package specifications may
2889 -- have private declarations.
2891 if For_Package_Spec
then
2892 Process_Declarations
2893 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2896 -- The current context may lack controlled objects, but require some
2897 -- other form of completion (task termination for instance). In such
2898 -- cases, the finalizer must be created and carry the additional
2901 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2905 -- The preprocessing has determined that the context has controlled
2906 -- objects or library-level tagged types.
2908 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2910 -- Private declarations are processed first in order to preserve
2911 -- possible dependencies between public and private objects.
2913 if For_Package_Spec
then
2914 Process_Declarations
(Priv_Decls
);
2917 Process_Declarations
(Decls
);
2923 -- Preprocess both declarations and statements
2925 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2926 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
2928 -- At this point it is known that N has controlled objects. Ensure
2929 -- that N has a declarative list since the finalizer spec will be
2932 if Has_Ctrl_Objs
and then No
(Decls
) then
2933 Set_Declarations
(N
, New_List
);
2934 Decls
:= Declarations
(N
);
2935 Spec_Decls
:= Decls
;
2938 -- The current context may lack controlled objects, but require some
2939 -- other form of completion (task termination for instance). In such
2940 -- cases, the finalizer must be created and carry the additional
2943 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2947 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2948 Process_Declarations
(Stmts
);
2949 Process_Declarations
(Decls
);
2953 -- Step 3: Finalizer creation
2955 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2958 end Build_Finalizer
;
2960 --------------------------
2961 -- Build_Finalizer_Call --
2962 --------------------------
2964 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
2965 Is_Prot_Body
: constant Boolean :=
2966 Nkind
(N
) = N_Subprogram_Body
2967 and then Is_Protected_Subprogram_Body
(N
);
2968 -- Determine whether N denotes the protected version of a subprogram
2969 -- which belongs to a protected type.
2971 Loc
: constant Source_Ptr
:= Sloc
(N
);
2975 -- Do not perform this expansion in SPARK mode because we do not create
2976 -- finalizers in the first place.
2982 -- The At_End handler should have been assimilated by the finalizer
2984 HSS
:= Handled_Statement_Sequence
(N
);
2985 pragma Assert
(No
(At_End_Proc
(HSS
)));
2987 -- If the construct to be cleaned up is a protected subprogram body, the
2988 -- finalizer call needs to be associated with the block which wraps the
2989 -- unprotected version of the subprogram. The following illustrates this
2992 -- procedure Prot_SubpP is
2993 -- procedure finalizer is
2995 -- Service_Entries (Prot_Obj);
3002 -- Prot_SubpN (Prot_Obj);
3008 if Is_Prot_Body
then
3009 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3011 -- An At_End handler and regular exception handlers cannot coexist in
3012 -- the same statement sequence. Wrap the original statements in a block.
3014 elsif Present
(Exception_Handlers
(HSS
)) then
3016 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3021 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3023 Set_Handled_Statement_Sequence
(N
,
3024 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3026 HSS
:= Handled_Statement_Sequence
(N
);
3027 Set_End_Label
(HSS
, End_Lab
);
3031 Set_At_End_Proc
(HSS
, New_Reference_To
(Fin_Id
, Loc
));
3033 Analyze
(At_End_Proc
(HSS
));
3034 Expand_At_End_Handler
(HSS
, Empty
);
3035 end Build_Finalizer_Call
;
3037 ---------------------
3038 -- Build_Late_Proc --
3039 ---------------------
3041 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3043 for Final_Prim
in Name_Of
'Range loop
3044 if Name_Of
(Final_Prim
) = Nam
then
3047 (Prim
=> Final_Prim
,
3049 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3052 end Build_Late_Proc
;
3054 -------------------------------
3055 -- Build_Object_Declarations --
3056 -------------------------------
3058 procedure Build_Object_Declarations
3059 (Data
: out Finalization_Exception_Data
;
3062 For_Package
: Boolean := False)
3068 pragma Assert
(Decls
/= No_List
);
3070 -- Always set the proper location as it may be needed even when
3071 -- exception propagation is forbidden.
3075 if Restriction_Active
(No_Exception_Propagation
) then
3076 Data
.Abort_Id
:= Empty
;
3078 Data
.Raised_Id
:= Empty
;
3082 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3084 -- In certain scenarios, finalization can be triggered by an abort. If
3085 -- the finalization itself fails and raises an exception, the resulting
3086 -- Program_Error must be supressed and replaced by an abort signal. In
3087 -- order to detect this scenario, save the state of entry into the
3088 -- finalization code.
3090 -- No need to do this for VM case, since VM version of Ada.Exceptions
3091 -- does not include routine Raise_From_Controlled_Operation which is the
3092 -- the sole user of flag Abort.
3094 -- This is not needed for library-level finalizers as they are called
3095 -- by the environment task and cannot be aborted.
3098 and then VM_Target
= No_VM
3099 and then not For_Package
3101 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3103 A_Expr
:= New_Reference_To
(RTE
(RE_Triggered_By_Abort
), Loc
);
3107 -- Abort_Id : constant Boolean := <A_Expr>;
3110 Make_Object_Declaration
(Loc
,
3111 Defining_Identifier
=> Data
.Abort_Id
,
3112 Constant_Present
=> True,
3113 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3114 Expression
=> A_Expr
));
3117 -- No abort, .NET/JVM or library-level finalizers
3119 Data
.Abort_Id
:= Empty
;
3122 if Exception_Extra_Info
then
3123 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3127 -- E_Id : Exception_Occurrence;
3130 Make_Object_Declaration
(Loc
,
3131 Defining_Identifier
=> Data
.E_Id
,
3132 Object_Definition
=>
3133 New_Reference_To
(RTE
(RE_Exception_Occurrence
), Loc
));
3134 Set_No_Initialization
(E_Decl
);
3136 Append_To
(Decls
, E_Decl
);
3144 -- Raised_Id : Boolean := False;
3147 Make_Object_Declaration
(Loc
,
3148 Defining_Identifier
=> Data
.Raised_Id
,
3149 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3150 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
3151 end Build_Object_Declarations
;
3153 ---------------------------
3154 -- Build_Raise_Statement --
3155 ---------------------------
3157 function Build_Raise_Statement
3158 (Data
: Finalization_Exception_Data
) return Node_Id
3164 -- Standard run-time and .NET/JVM targets use the specialized routine
3165 -- Raise_From_Controlled_Operation.
3167 if Exception_Extra_Info
3168 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3171 Make_Procedure_Call_Statement
(Data
.Loc
,
3174 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3175 Parameter_Associations
=>
3176 New_List
(New_Reference_To
(Data
.E_Id
, Data
.Loc
)));
3178 -- Restricted run-time: exception messages are not supported and hence
3179 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3184 Make_Raise_Program_Error
(Data
.Loc
,
3185 Reason
=> PE_Finalize_Raised_Exception
);
3190 -- Raised_Id and then not Abort_Id
3194 Expr
:= New_Reference_To
(Data
.Raised_Id
, Data
.Loc
);
3196 if Present
(Data
.Abort_Id
) then
3197 Expr
:= Make_And_Then
(Data
.Loc
,
3200 Make_Op_Not
(Data
.Loc
,
3201 Right_Opnd
=> New_Reference_To
(Data
.Abort_Id
, Data
.Loc
)));
3206 -- if Raised_Id and then not Abort_Id then
3207 -- Raise_From_Controlled_Operation (E_Id);
3209 -- raise Program_Error; -- restricted runtime
3213 Make_If_Statement
(Data
.Loc
,
3215 Then_Statements
=> New_List
(Stmt
));
3216 end Build_Raise_Statement
;
3218 -----------------------------
3219 -- Build_Record_Deep_Procs --
3220 -----------------------------
3222 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3226 (Prim
=> Initialize_Case
,
3228 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3230 if not Is_Limited_View
(Typ
) then
3233 (Prim
=> Adjust_Case
,
3235 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3238 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3239 -- suppressed since these routine will not be used.
3241 if not Restriction_Active
(No_Finalization
) then
3244 (Prim
=> Finalize_Case
,
3246 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3248 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3249 -- .NET do not support address arithmetic and unchecked conversions.
3251 if VM_Target
= No_VM
then
3254 (Prim
=> Address_Case
,
3256 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3259 end Build_Record_Deep_Procs
;
3265 function Cleanup_Array
3268 Typ
: Entity_Id
) return List_Id
3270 Loc
: constant Source_Ptr
:= Sloc
(N
);
3271 Index_List
: constant List_Id
:= New_List
;
3273 function Free_Component
return List_Id
;
3274 -- Generate the code to finalize the task or protected subcomponents
3275 -- of a single component of the array.
3277 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3278 -- Generate a loop over one dimension of the array
3280 --------------------
3281 -- Free_Component --
3282 --------------------
3284 function Free_Component
return List_Id
is
3285 Stmts
: List_Id
:= New_List
;
3287 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3290 -- Component type is known to contain tasks or protected objects
3293 Make_Indexed_Component
(Loc
,
3294 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3295 Expressions
=> Index_List
);
3297 Set_Etype
(Tsk
, C_Typ
);
3299 if Is_Task_Type
(C_Typ
) then
3300 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3302 elsif Is_Simple_Protected_Type
(C_Typ
) then
3303 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3305 elsif Is_Record_Type
(C_Typ
) then
3306 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3308 elsif Is_Array_Type
(C_Typ
) then
3309 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3315 ------------------------
3316 -- Free_One_Dimension --
3317 ------------------------
3319 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3323 if Dim
> Number_Dimensions
(Typ
) then
3324 return Free_Component
;
3326 -- Here we generate the required loop
3329 Index
:= Make_Temporary
(Loc
, 'J');
3330 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
3333 Make_Implicit_Loop_Statement
(N
,
3334 Identifier
=> Empty
,
3336 Make_Iteration_Scheme
(Loc
,
3337 Loop_Parameter_Specification
=>
3338 Make_Loop_Parameter_Specification
(Loc
,
3339 Defining_Identifier
=> Index
,
3340 Discrete_Subtype_Definition
=>
3341 Make_Attribute_Reference
(Loc
,
3342 Prefix
=> Duplicate_Subexpr
(Obj
),
3343 Attribute_Name
=> Name_Range
,
3344 Expressions
=> New_List
(
3345 Make_Integer_Literal
(Loc
, Dim
))))),
3346 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3348 end Free_One_Dimension
;
3350 -- Start of processing for Cleanup_Array
3353 return Free_One_Dimension
(1);
3356 --------------------
3357 -- Cleanup_Record --
3358 --------------------
3360 function Cleanup_Record
3363 Typ
: Entity_Id
) return List_Id
3365 Loc
: constant Source_Ptr
:= Sloc
(N
);
3368 Stmts
: constant List_Id
:= New_List
;
3369 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3372 if Has_Discriminants
(U_Typ
)
3373 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3375 Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3378 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3380 -- For now, do not attempt to free a component that may appear in a
3381 -- variant, and instead issue a warning. Doing this "properly" would
3382 -- require building a case statement and would be quite a mess. Note
3383 -- that the RM only requires that free "work" for the case of a task
3384 -- access value, so already we go way beyond this in that we deal
3385 -- with the array case and non-discriminated record cases.
3388 ("task/protected object in variant record will not be freed??", N
);
3389 return New_List
(Make_Null_Statement
(Loc
));
3392 Comp
:= First_Component
(Typ
);
3393 while Present
(Comp
) loop
3394 if Has_Task
(Etype
(Comp
))
3395 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3398 Make_Selected_Component
(Loc
,
3399 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3400 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3401 Set_Etype
(Tsk
, Etype
(Comp
));
3403 if Is_Task_Type
(Etype
(Comp
)) then
3404 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3406 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3407 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3409 elsif Is_Record_Type
(Etype
(Comp
)) then
3411 -- Recurse, by generating the prefix of the argument to
3412 -- the eventual cleanup call.
3414 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3416 elsif Is_Array_Type
(Etype
(Comp
)) then
3417 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3421 Next_Component
(Comp
);
3427 ------------------------------
3428 -- Cleanup_Protected_Object --
3429 ------------------------------
3431 function Cleanup_Protected_Object
3433 Ref
: Node_Id
) return Node_Id
3435 Loc
: constant Source_Ptr
:= Sloc
(N
);
3438 -- For restricted run-time libraries (Ravenscar), tasks are
3439 -- non-terminating, and protected objects can only appear at library
3440 -- level, so we do not want finalization of protected objects.
3442 if Restricted_Profile
then
3447 Make_Procedure_Call_Statement
(Loc
,
3449 New_Reference_To
(RTE
(RE_Finalize_Protection
), Loc
),
3450 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3452 end Cleanup_Protected_Object
;
3458 function Cleanup_Task
3460 Ref
: Node_Id
) return Node_Id
3462 Loc
: constant Source_Ptr
:= Sloc
(N
);
3465 -- For restricted run-time libraries (Ravenscar), tasks are
3466 -- non-terminating and they can only appear at library level, so we do
3467 -- not want finalization of task objects.
3469 if Restricted_Profile
then
3474 Make_Procedure_Call_Statement
(Loc
,
3476 New_Reference_To
(RTE
(RE_Free_Task
), Loc
),
3477 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3481 ------------------------------
3482 -- Check_Visibly_Controlled --
3483 ------------------------------
3485 procedure Check_Visibly_Controlled
3486 (Prim
: Final_Primitives
;
3488 E
: in out Entity_Id
;
3489 Cref
: in out Node_Id
)
3491 Parent_Type
: Entity_Id
;
3495 if Is_Derived_Type
(Typ
)
3496 and then Comes_From_Source
(E
)
3497 and then not Present
(Overridden_Operation
(E
))
3499 -- We know that the explicit operation on the type does not override
3500 -- the inherited operation of the parent, and that the derivation
3501 -- is from a private type that is not visibly controlled.
3503 Parent_Type
:= Etype
(Typ
);
3504 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3506 if Present
(Op
) then
3509 -- Wrap the object to be initialized into the proper
3510 -- unchecked conversion, to be compatible with the operation
3513 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3514 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3516 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3520 end Check_Visibly_Controlled
;
3522 -------------------------------
3523 -- CW_Or_Has_Controlled_Part --
3524 -------------------------------
3526 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3528 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3529 end CW_Or_Has_Controlled_Part
;
3535 function Convert_View
3538 Ind
: Pos
:= 1) return Node_Id
3540 Fent
: Entity_Id
:= First_Entity
(Proc
);
3545 for J
in 2 .. Ind
loop
3549 Ftyp
:= Etype
(Fent
);
3551 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3552 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3554 Atyp
:= Etype
(Arg
);
3557 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3558 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3561 and then Present
(Atyp
)
3562 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3563 and then Base_Type
(Underlying_Type
(Atyp
)) =
3564 Base_Type
(Underlying_Type
(Ftyp
))
3566 return Unchecked_Convert_To
(Ftyp
, Arg
);
3568 -- If the argument is already a conversion, as generated by
3569 -- Make_Init_Call, set the target type to the type of the formal
3570 -- directly, to avoid spurious typing problems.
3572 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3573 and then not Is_Class_Wide_Type
(Atyp
)
3575 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3576 Set_Etype
(Arg
, Ftyp
);
3584 ------------------------
3585 -- Enclosing_Function --
3586 ------------------------
3588 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3589 Func_Id
: Entity_Id
;
3593 while Present
(Func_Id
)
3594 and then Func_Id
/= Standard_Standard
3596 if Ekind
(Func_Id
) = E_Function
then
3600 Func_Id
:= Scope
(Func_Id
);
3604 end Enclosing_Function
;
3606 -------------------------------
3607 -- Establish_Transient_Scope --
3608 -------------------------------
3610 -- This procedure is called each time a transient block has to be inserted
3611 -- that is to say for each call to a function with unconstrained or tagged
3612 -- result. It creates a new scope on the stack scope in order to enclose
3613 -- all transient variables generated
3615 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3616 Loc
: constant Source_Ptr
:= Sloc
(N
);
3617 Wrap_Node
: Node_Id
;
3620 -- Do not create a transient scope if we are already inside one
3622 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3623 if Scope_Stack
.Table
(S
).Is_Transient
then
3625 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3630 -- If we have encountered Standard there are no enclosing
3631 -- transient scopes.
3633 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3638 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3640 -- Case of no wrap node, false alert, no transient scope needed
3642 if No
(Wrap_Node
) then
3645 -- If the node to wrap is an iteration_scheme, the expression is
3646 -- one of the bounds, and the expansion will make an explicit
3647 -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3648 -- so do not apply any transformations here. Same for an Ada 2012
3649 -- iterator specification, where a block is created for the expression
3650 -- that build the container.
3652 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3653 N_Iterator_Specification
)
3657 -- In formal verification mode, if the node to wrap is a pragma check,
3658 -- this node and enclosed expression are not expanded, so do not apply
3659 -- any transformations here.
3662 and then Nkind
(Wrap_Node
) = N_Pragma
3663 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3668 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3669 Set_Scope_Is_Transient
;
3672 Set_Uses_Sec_Stack
(Current_Scope
);
3673 Check_Restriction
(No_Secondary_Stack
, N
);
3676 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3677 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3679 if Debug_Flag_W
then
3680 Write_Str
(" <Transient>");
3684 end Establish_Transient_Scope
;
3686 ----------------------------
3687 -- Expand_Cleanup_Actions --
3688 ----------------------------
3690 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3691 Scop
: constant Entity_Id
:= Current_Scope
;
3693 Is_Asynchronous_Call
: constant Boolean :=
3694 Nkind
(N
) = N_Block_Statement
3695 and then Is_Asynchronous_Call_Block
(N
);
3696 Is_Master
: constant Boolean :=
3697 Nkind
(N
) /= N_Entry_Body
3698 and then Is_Task_Master
(N
);
3699 Is_Protected_Body
: constant Boolean :=
3700 Nkind
(N
) = N_Subprogram_Body
3701 and then Is_Protected_Subprogram_Body
(N
);
3702 Is_Task_Allocation
: constant Boolean :=
3703 Nkind
(N
) = N_Block_Statement
3704 and then Is_Task_Allocation_Block
(N
);
3705 Is_Task_Body
: constant Boolean :=
3706 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3707 Needs_Sec_Stack_Mark
: constant Boolean :=
3708 Uses_Sec_Stack
(Scop
)
3710 not Sec_Stack_Needed_For_Return
(Scop
)
3711 and then VM_Target
= No_VM
;
3713 Actions_Required
: constant Boolean :=
3714 Requires_Cleanup_Actions
(N
, True)
3715 or else Is_Asynchronous_Call
3717 or else Is_Protected_Body
3718 or else Is_Task_Allocation
3719 or else Is_Task_Body
3720 or else Needs_Sec_Stack_Mark
;
3722 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3725 procedure Wrap_HSS_In_Block
;
3726 -- Move HSS inside a new block along with the original exception
3727 -- handlers. Make the newly generated block the sole statement of HSS.
3729 -----------------------
3730 -- Wrap_HSS_In_Block --
3731 -----------------------
3733 procedure Wrap_HSS_In_Block
is
3738 -- Preserve end label to provide proper cross-reference information
3740 End_Lab
:= End_Label
(HSS
);
3742 Make_Block_Statement
(Loc
,
3743 Handled_Statement_Sequence
=> HSS
);
3745 -- Signal the finalization machinery that this particular block
3746 -- contains the original context.
3748 Set_Is_Finalization_Wrapper
(Block
);
3750 Set_Handled_Statement_Sequence
(N
,
3751 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3752 HSS
:= Handled_Statement_Sequence
(N
);
3754 Set_First_Real_Statement
(HSS
, Block
);
3755 Set_End_Label
(HSS
, End_Lab
);
3757 -- Comment needed here, see RH for 1.306 ???
3759 if Nkind
(N
) = N_Subprogram_Body
then
3760 Set_Has_Nested_Block_With_Handler
(Scop
);
3762 end Wrap_HSS_In_Block
;
3764 -- Start of processing for Expand_Cleanup_Actions
3767 -- The current construct does not need any form of servicing
3769 if not Actions_Required
then
3772 -- If the current node is a rewritten task body and the descriptors have
3773 -- not been delayed (due to some nested instantiations), do not generate
3774 -- redundant cleanup actions.
3777 and then Nkind
(N
) = N_Subprogram_Body
3778 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3784 Decls
: List_Id
:= Declarations
(N
);
3786 Mark
: Entity_Id
:= Empty
;
3787 New_Decls
: List_Id
;
3791 -- If we are generating expanded code for debugging purposes, use the
3792 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3793 -- be updated subsequently to reference the proper line in .dg files.
3794 -- If we are not debugging generated code, use No_Location instead,
3795 -- so that no debug information is generated for the cleanup code.
3796 -- This makes the behavior of the NEXT command in GDB monotonic, and
3797 -- makes the placement of breakpoints more accurate.
3799 if Debug_Generated_Code
then
3805 -- Set polling off. The finalization and cleanup code is executed
3806 -- with aborts deferred.
3808 Old_Poll
:= Polling_Required
;
3809 Polling_Required
:= False;
3811 -- A task activation call has already been built for a task
3812 -- allocation block.
3814 if not Is_Task_Allocation
then
3815 Build_Task_Activation_Call
(N
);
3819 Establish_Task_Master
(N
);
3822 New_Decls
:= New_List
;
3824 -- If secondary stack is in use, generate:
3826 -- Mnn : constant Mark_Id := SS_Mark;
3828 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3829 -- secondary stack is never used on a VM.
3831 if Needs_Sec_Stack_Mark
then
3832 Mark
:= Make_Temporary
(Loc
, 'M');
3834 Append_To
(New_Decls
,
3835 Make_Object_Declaration
(Loc
,
3836 Defining_Identifier
=> Mark
,
3837 Object_Definition
=>
3838 New_Reference_To
(RTE
(RE_Mark_Id
), Loc
),
3840 Make_Function_Call
(Loc
,
3841 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
))));
3843 Set_Uses_Sec_Stack
(Scop
, False);
3846 -- If exception handlers are present, wrap the sequence of statements
3847 -- in a block since it is not possible to have exception handlers and
3848 -- an At_End handler in the same construct.
3850 if Present
(Exception_Handlers
(HSS
)) then
3853 -- Ensure that the First_Real_Statement field is set
3855 elsif No
(First_Real_Statement
(HSS
)) then
3856 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3859 -- Do not move the Activation_Chain declaration in the context of
3860 -- task allocation blocks. Task allocation blocks use _chain in their
3861 -- cleanup handlers and gigi complains if it is declared in the
3862 -- sequence of statements of the scope that declares the handler.
3864 if Is_Task_Allocation
then
3866 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3870 Decl
:= First
(Decls
);
3871 while Nkind
(Decl
) /= N_Object_Declaration
3872 or else Defining_Identifier
(Decl
) /= Chain
3876 -- A task allocation block should always include a _chain
3879 pragma Assert
(Present
(Decl
));
3883 Prepend_To
(New_Decls
, Decl
);
3887 -- Ensure the presence of a declaration list in order to successfully
3888 -- append all original statements to it.
3891 Set_Declarations
(N
, New_List
);
3892 Decls
:= Declarations
(N
);
3895 -- Move the declarations into the sequence of statements in order to
3896 -- have them protected by the At_End handler. It may seem weird to
3897 -- put declarations in the sequence of statement but in fact nothing
3898 -- forbids that at the tree level.
3900 Append_List_To
(Decls
, Statements
(HSS
));
3901 Set_Statements
(HSS
, Decls
);
3903 -- Reset the Sloc of the handled statement sequence to properly
3904 -- reflect the new initial "statement" in the sequence.
3906 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
3908 -- The declarations of finalizer spec and auxiliary variables replace
3909 -- the old declarations that have been moved inward.
3911 Set_Declarations
(N
, New_Decls
);
3912 Analyze_Declarations
(New_Decls
);
3914 -- Generate finalization calls for all controlled objects appearing
3915 -- in the statements of N. Add context specific cleanup for various
3920 Clean_Stmts
=> Build_Cleanup_Statements
(N
),
3922 Top_Decls
=> New_Decls
,
3923 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
3927 if Present
(Fin_Id
) then
3928 Build_Finalizer_Call
(N
, Fin_Id
);
3931 -- Restore saved polling mode
3933 Polling_Required
:= Old_Poll
;
3935 end Expand_Cleanup_Actions
;
3937 ---------------------------
3938 -- Expand_N_Package_Body --
3939 ---------------------------
3941 -- Add call to Activate_Tasks if body is an activator (actual processing
3942 -- is in chapter 9).
3944 -- Generate subprogram descriptor for elaboration routine
3946 -- Encode entity names in package body
3948 procedure Expand_N_Package_Body
(N
: Node_Id
) is
3949 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
3953 -- This is done only for non-generic packages
3955 if Ekind
(Spec_Ent
) = E_Package
then
3956 Push_Scope
(Corresponding_Spec
(N
));
3958 -- Build dispatch tables of library level tagged types
3960 if Tagged_Type_Expansion
3961 and then Is_Library_Level_Entity
(Spec_Ent
)
3963 Build_Static_Dispatch_Tables
(N
);
3966 Build_Task_Activation_Call
(N
);
3968 -- When the package is subject to pragma Initial_Condition, the
3969 -- assertion expression must be verified at the end of the body
3972 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
3973 Expand_Pragma_Initial_Condition
(N
);
3979 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
3980 Set_In_Package_Body
(Spec_Ent
, False);
3982 -- Set to encode entity names in package body before gigi is called
3984 Qualify_Entity_Names
(N
);
3986 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
3989 Clean_Stmts
=> No_List
,
3991 Top_Decls
=> No_List
,
3992 Defer_Abort
=> False,
3995 if Present
(Fin_Id
) then
3997 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4000 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4001 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4004 Set_Finalizer
(Body_Ent
, Fin_Id
);
4008 end Expand_N_Package_Body
;
4010 ----------------------------------
4011 -- Expand_N_Package_Declaration --
4012 ----------------------------------
4014 -- Add call to Activate_Tasks if there are tasks declared and the package
4015 -- has no body. Note that in Ada 83 this may result in premature activation
4016 -- of some tasks, given that we cannot tell whether a body will eventually
4019 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4020 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4021 Spec
: constant Node_Id
:= Specification
(N
);
4025 No_Body
: Boolean := False;
4026 -- True in the case of a package declaration that is a compilation
4027 -- unit and for which no associated body will be compiled in this
4031 -- Case of a package declaration other than a compilation unit
4033 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4036 -- Case of a compilation unit that does not require a body
4038 elsif not Body_Required
(Parent
(N
))
4039 and then not Unit_Requires_Body
(Id
)
4043 -- Special case of generating calling stubs for a remote call interface
4044 -- package: even though the package declaration requires one, the body
4045 -- won't be processed in this compilation (so any stubs for RACWs
4046 -- declared in the package must be generated here, along with the spec).
4048 elsif Parent
(N
) = Cunit
(Main_Unit
)
4049 and then Is_Remote_Call_Interface
(Id
)
4050 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4055 -- For a nested instance, delay processing until freeze point
4057 if Has_Delayed_Freeze
(Id
)
4058 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4063 -- For a package declaration that implies no associated body, generate
4064 -- task activation call and RACW supporting bodies now (since we won't
4065 -- have a specific separate compilation unit for that).
4070 -- Generate RACW subprogram bodies
4072 if Has_RACW
(Id
) then
4073 Decls
:= Private_Declarations
(Spec
);
4076 Decls
:= Visible_Declarations
(Spec
);
4081 Set_Visible_Declarations
(Spec
, Decls
);
4084 Append_RACW_Bodies
(Decls
, Id
);
4085 Analyze_List
(Decls
);
4088 -- Generate task activation call as last step of elaboration
4090 if Present
(Activation_Chain_Entity
(N
)) then
4091 Build_Task_Activation_Call
(N
);
4094 -- When the package is subject to pragma Initial_Condition and lacks
4095 -- a body, the assertion expression must be verified at the end of
4096 -- the visible declarations. Otherwise the check is performed at the
4097 -- end of the body statements (see Expand_N_Package_Body).
4099 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4100 Expand_Pragma_Initial_Condition
(N
);
4106 -- Build dispatch tables of library level tagged types
4108 if Tagged_Type_Expansion
4109 and then (Is_Compilation_Unit
(Id
)
4110 or else (Is_Generic_Instance
(Id
)
4111 and then Is_Library_Level_Entity
(Id
)))
4113 Build_Static_Dispatch_Tables
(N
);
4116 -- Note: it is not necessary to worry about generating a subprogram
4117 -- descriptor, since the only way to get exception handlers into a
4118 -- package spec is to include instantiations, and that would cause
4119 -- generation of subprogram descriptors to be delayed in any case.
4121 -- Set to encode entity names in package spec before gigi is called
4123 Qualify_Entity_Names
(N
);
4125 if Ekind
(Id
) /= E_Generic_Package
then
4128 Clean_Stmts
=> No_List
,
4130 Top_Decls
=> No_List
,
4131 Defer_Abort
=> False,
4134 Set_Finalizer
(Id
, Fin_Id
);
4136 end Expand_N_Package_Declaration
;
4138 -------------------------------------
4139 -- Expand_Pragma_Initial_Condition --
4140 -------------------------------------
4142 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
) is
4143 Loc
: constant Source_Ptr
:= Sloc
(N
);
4146 Init_Cond
: Node_Id
;
4148 Pack_Id
: Entity_Id
;
4151 if Nkind
(N
) = N_Package_Body
then
4152 Pack_Id
:= Corresponding_Spec
(N
);
4154 if Present
(Handled_Statement_Sequence
(N
)) then
4155 List
:= Statements
(Handled_Statement_Sequence
(N
));
4157 -- The package body lacks statements, create an empty list
4162 Set_Handled_Statement_Sequence
(N
,
4163 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> List
));
4166 elsif Nkind
(N
) = N_Package_Declaration
then
4167 Pack_Id
:= Defining_Entity
(N
);
4169 if Present
(Visible_Declarations
(Specification
(N
))) then
4170 List
:= Visible_Declarations
(Specification
(N
));
4172 -- The package lacks visible declarations, create an empty list
4177 Set_Visible_Declarations
(Specification
(N
), List
);
4180 -- This routine should not be used on anything other than packages
4183 raise Program_Error
;
4186 Init_Cond
:= Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
4188 -- The caller should check whether the package is subject to pragma
4189 -- Initial_Condition.
4191 pragma Assert
(Present
(Init_Cond
));
4194 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Init_Cond
)));
4196 -- The assertion expression was found to be illegal, do not generate the
4197 -- runtime check as it will repeat the illegality.
4199 if Error_Posted
(Init_Cond
) or else Error_Posted
(Expr
) then
4204 -- pragma Check (Initial_Condition, <Expr>);
4208 Chars
=> Name_Check
,
4209 Pragma_Argument_Associations
=> New_List
(
4210 Make_Pragma_Argument_Association
(Loc
,
4211 Expression
=> Make_Identifier
(Loc
, Name_Initial_Condition
)),
4213 Make_Pragma_Argument_Association
(Loc
,
4214 Expression
=> New_Copy_Tree
(Expr
))));
4216 Append_To
(List
, Check
);
4218 end Expand_Pragma_Initial_Condition
;
4220 -----------------------------
4221 -- Find_Node_To_Be_Wrapped --
4222 -----------------------------
4224 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4226 The_Parent
: Node_Id
;
4232 pragma Assert
(P
/= Empty
);
4233 The_Parent
:= Parent
(P
);
4235 case Nkind
(The_Parent
) is
4237 -- Simple statement can be wrapped
4242 -- Usually assignments are good candidate for wrapping except
4243 -- when they have been generated as part of a controlled aggregate
4244 -- where the wrapping should take place more globally.
4246 when N_Assignment_Statement
=>
4247 if No_Ctrl_Actions
(The_Parent
) then
4253 -- An entry call statement is a special case if it occurs in the
4254 -- context of a Timed_Entry_Call. In this case we wrap the entire
4255 -- timed entry call.
4257 when N_Entry_Call_Statement |
4258 N_Procedure_Call_Statement
=>
4259 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4260 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4262 N_Conditional_Entry_Call
)
4264 return Parent
(Parent
(The_Parent
));
4269 -- Object declarations are also a boundary for the transient scope
4270 -- even if they are not really wrapped. For further details, see
4271 -- Wrap_Transient_Declaration.
4273 when N_Object_Declaration |
4274 N_Object_Renaming_Declaration |
4275 N_Subtype_Declaration
=>
4278 -- The expression itself is to be wrapped if its parent is a
4279 -- compound statement or any other statement where the expression
4280 -- is known to be scalar
4282 when N_Accept_Alternative |
4283 N_Attribute_Definition_Clause |
4286 N_Delay_Alternative |
4287 N_Delay_Until_Statement |
4288 N_Delay_Relative_Statement |
4289 N_Discriminant_Association |
4291 N_Entry_Body_Formal_Part |
4294 N_Iteration_Scheme |
4295 N_Terminate_Alternative
=>
4298 when N_Attribute_Reference
=>
4300 if Is_Procedure_Attribute_Name
4301 (Attribute_Name
(The_Parent
))
4306 -- A raise statement can be wrapped. This will arise when the
4307 -- expression in a raise_with_expression uses the secondary
4308 -- stack, for example.
4310 when N_Raise_Statement
=>
4313 -- If the expression is within the iteration scheme of a loop,
4314 -- we must create a declaration for it, followed by an assignment
4315 -- in order to have a usable statement to wrap.
4317 when N_Loop_Parameter_Specification
=>
4318 return Parent
(The_Parent
);
4320 -- The following nodes contains "dummy calls" which don't need to
4323 when N_Parameter_Specification |
4324 N_Discriminant_Specification |
4325 N_Component_Declaration
=>
4328 -- The return statement is not to be wrapped when the function
4329 -- itself needs wrapping at the outer-level
4331 when N_Simple_Return_Statement
=>
4333 Applies_To
: constant Entity_Id
:=
4335 (Return_Statement_Entity
(The_Parent
));
4336 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4338 if Requires_Transient_Scope
(Return_Type
) then
4345 -- If we leave a scope without having been able to find a node to
4346 -- wrap, something is going wrong but this can happen in error
4347 -- situation that are not detected yet (such as a dynamic string
4348 -- in a pragma export)
4350 when N_Subprogram_Body |
4351 N_Package_Declaration |
4353 N_Block_Statement
=>
4356 -- Otherwise continue the search
4362 end Find_Node_To_Be_Wrapped
;
4364 -------------------------------------
4365 -- Get_Global_Pool_For_Access_Type --
4366 -------------------------------------
4368 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4370 -- Access types whose size is smaller than System.Address size can exist
4371 -- only on VMS. We can't use the usual global pool which returns an
4372 -- object of type Address as truncation will make it invalid. To handle
4373 -- this case, VMS has a dedicated global pool that returns addresses
4374 -- that fit into 32 bit accesses.
4376 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4377 return RTE
(RE_Global_Pool_32_Object
);
4379 return RTE
(RE_Global_Pool_Object
);
4381 end Get_Global_Pool_For_Access_Type
;
4383 ----------------------------------
4384 -- Has_New_Controlled_Component --
4385 ----------------------------------
4387 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4391 if not Is_Tagged_Type
(E
) then
4392 return Has_Controlled_Component
(E
);
4393 elsif not Is_Derived_Type
(E
) then
4394 return Has_Controlled_Component
(E
);
4397 Comp
:= First_Component
(E
);
4398 while Present
(Comp
) loop
4399 if Chars
(Comp
) = Name_uParent
then
4402 elsif Scope
(Original_Record_Component
(Comp
)) = E
4403 and then Needs_Finalization
(Etype
(Comp
))
4408 Next_Component
(Comp
);
4412 end Has_New_Controlled_Component
;
4414 ---------------------------------
4415 -- Has_Simple_Protected_Object --
4416 ---------------------------------
4418 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4420 if Has_Task
(T
) then
4423 elsif Is_Simple_Protected_Type
(T
) then
4426 elsif Is_Array_Type
(T
) then
4427 return Has_Simple_Protected_Object
(Component_Type
(T
));
4429 elsif Is_Record_Type
(T
) then
4434 Comp
:= First_Component
(T
);
4435 while Present
(Comp
) loop
4436 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4440 Next_Component
(Comp
);
4449 end Has_Simple_Protected_Object
;
4451 ------------------------------------
4452 -- Insert_Actions_In_Scope_Around --
4453 ------------------------------------
4455 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
) is
4456 After
: constant List_Id
:=
4457 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_After
;
4458 Before
: constant List_Id
:=
4459 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_Before
;
4460 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4461 -- Last), but this was incorrect as Process_Transient_Object may
4462 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4464 procedure Process_Transient_Objects
4465 (First_Object
: Node_Id
;
4466 Last_Object
: Node_Id
;
4467 Related_Node
: Node_Id
);
4468 -- First_Object and Last_Object define a list which contains potential
4469 -- controlled transient objects. Finalization flags are inserted before
4470 -- First_Object and finalization calls are inserted after Last_Object.
4471 -- Related_Node is the node for which transient objects have been
4474 -------------------------------
4475 -- Process_Transient_Objects --
4476 -------------------------------
4478 procedure Process_Transient_Objects
4479 (First_Object
: Node_Id
;
4480 Last_Object
: Node_Id
;
4481 Related_Node
: Node_Id
)
4483 function Requires_Hooking
return Boolean;
4484 -- Determine whether the context requires transient variable export
4485 -- to the outer finalizer. This scenario arises when the context may
4486 -- raise an exception.
4488 ----------------------
4489 -- Requires_Hooking --
4490 ----------------------
4492 function Requires_Hooking
return Boolean is
4494 -- The context is either a procedure or function call or an object
4495 -- declaration initialized by a function call. Note that in the
4496 -- latter case, a function call that returns on the secondary
4497 -- stack is usually rewritten into something else. Its proper
4498 -- detection requires examination of the original initialization
4501 return Nkind
(N
) in N_Subprogram_Call
4502 or else (Nkind
(N
) = N_Object_Declaration
4503 and then Nkind
(Original_Node
(Expression
(N
))) =
4505 end Requires_Hooking
;
4509 Must_Hook
: constant Boolean := Requires_Hooking
;
4510 Built
: Boolean := False;
4511 Desig_Typ
: Entity_Id
;
4512 Fin_Block
: Node_Id
;
4513 Fin_Data
: Finalization_Exception_Data
;
4514 Fin_Decls
: List_Id
;
4515 Last_Fin
: Node_Id
:= Empty
;
4519 Obj_Typ
: Entity_Id
;
4520 Prev_Fin
: Node_Id
:= Empty
;
4523 Temp_Id
: Entity_Id
;
4525 -- Start of processing for Process_Transient_Objects
4528 -- Examine all objects in the list First_Object .. Last_Object
4530 Stmt
:= First_Object
;
4531 while Present
(Stmt
) loop
4532 if Nkind
(Stmt
) = N_Object_Declaration
4533 and then Analyzed
(Stmt
)
4534 and then Is_Finalizable_Transient
(Stmt
, N
)
4536 -- Do not process the node to be wrapped since it will be
4537 -- handled by the enclosing finalizer.
4539 and then Stmt
/= Related_Node
4542 Obj_Id
:= Defining_Identifier
(Stmt
);
4543 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4544 Desig_Typ
:= Obj_Typ
;
4546 Set_Is_Processed_Transient
(Obj_Id
);
4548 -- Handle access types
4550 if Is_Access_Type
(Desig_Typ
) then
4551 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4554 -- Create the necessary entities and declarations the first
4558 Fin_Decls
:= New_List
;
4560 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4565 -- Transient variables associated with subprogram calls need
4566 -- extra processing. These variables are usually created right
4567 -- before the call and finalized immediately after the call.
4568 -- If an exception occurs during the call, the clean up code
4569 -- is skipped due to the sudden change in control and the
4570 -- transient is never finalized.
4572 -- To handle this case, such variables are "exported" to the
4573 -- enclosing sequence of statements where their corresponding
4574 -- "hooks" are picked up by the finalization machinery.
4582 -- Step 1: Create an access type which provides a
4583 -- reference to the transient object. Generate:
4585 -- Ann : access [all] <Desig_Typ>;
4587 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4589 Insert_Action
(Stmt
,
4590 Make_Full_Type_Declaration
(Loc
,
4591 Defining_Identifier
=> Ptr_Id
,
4593 Make_Access_To_Object_Definition
(Loc
,
4595 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4596 Subtype_Indication
=>
4597 New_Reference_To
(Desig_Typ
, Loc
))));
4599 -- Step 2: Create a temporary which acts as a hook to
4600 -- the transient object. Generate:
4602 -- Temp : Ptr_Id := null;
4604 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4606 Insert_Action
(Stmt
,
4607 Make_Object_Declaration
(Loc
,
4608 Defining_Identifier
=> Temp_Id
,
4609 Object_Definition
=>
4610 New_Reference_To
(Ptr_Id
, Loc
)));
4612 -- Mark the temporary as a transient hook. This signals
4613 -- the machinery in Build_Finalizer to recognize this
4616 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4618 -- Step 3: Hook the transient object to the temporary
4620 if Is_Access_Type
(Obj_Typ
) then
4622 Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
4625 Make_Attribute_Reference
(Loc
,
4626 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
4627 Attribute_Name
=> Name_Unrestricted_Access
);
4631 -- Temp := Ptr_Id (Obj_Id);
4633 -- Temp := Obj_Id'Unrestricted_Access;
4635 Insert_After_And_Analyze
(Stmt
,
4636 Make_Assignment_Statement
(Loc
,
4637 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4638 Expression
=> Expr
));
4644 -- The transient object is about to be finalized by the clean
4645 -- up code following the subprogram call. In order to avoid
4646 -- double finalization, clear the hook.
4653 Make_Assignment_Statement
(Loc
,
4654 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4655 Expression
=> Make_Null
(Loc
)));
4659 -- [Deep_]Finalize (Obj_Ref);
4661 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
4663 if Is_Access_Type
(Obj_Typ
) then
4664 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4668 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4673 -- [Deep_]Finalize (Obj_Ref);
4677 -- if not Raised then
4680 -- (Enn, Get_Current_Excep.all.all);
4685 Make_Block_Statement
(Loc
,
4686 Handled_Statement_Sequence
=>
4687 Make_Handled_Sequence_Of_Statements
(Loc
,
4688 Statements
=> Stmts
,
4689 Exception_Handlers
=> New_List
(
4690 Build_Exception_Handler
(Fin_Data
))));
4692 -- The single raise statement must be inserted after all the
4693 -- finalization blocks, and we put everything into a wrapper
4694 -- block to clearly expose the construct to the back-end.
4696 if Present
(Prev_Fin
) then
4697 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4699 Insert_After_And_Analyze
(Last_Object
,
4700 Make_Block_Statement
(Loc
,
4701 Declarations
=> Fin_Decls
,
4702 Handled_Statement_Sequence
=>
4703 Make_Handled_Sequence_Of_Statements
(Loc
,
4704 Statements
=> New_List
(Fin_Block
))));
4706 Last_Fin
:= Fin_Block
;
4709 Prev_Fin
:= Fin_Block
;
4712 -- Terminate the scan after the last object has been processed to
4713 -- avoid touching unrelated code.
4715 if Stmt
= Last_Object
then
4723 -- if Raised and then not Abort then
4724 -- Raise_From_Controlled_Operation (E);
4728 and then Present
(Last_Fin
)
4730 Insert_After_And_Analyze
(Last_Fin
,
4731 Build_Raise_Statement
(Fin_Data
));
4733 end Process_Transient_Objects
;
4735 -- Start of processing for Insert_Actions_In_Scope_Around
4738 if No
(Before
) and then No
(After
) then
4743 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4744 First_Obj
: Node_Id
;
4749 -- If the node to be wrapped is the trigger of an asynchronous
4750 -- select, it is not part of a statement list. The actions must be
4751 -- inserted before the select itself, which is part of some list of
4752 -- statements. Note that the triggering alternative includes the
4753 -- triggering statement and an optional statement list. If the node
4754 -- to be wrapped is part of that list, the normal insertion applies.
4756 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4757 and then not Is_List_Member
(Node_To_Wrap
)
4759 Target
:= Parent
(Parent
(Node_To_Wrap
));
4764 First_Obj
:= Target
;
4767 -- Add all actions associated with a transient scope into the main
4768 -- tree. There are several scenarios here:
4770 -- +--- Before ----+ +----- After ---+
4771 -- 1) First_Obj ....... Target ........ Last_Obj
4773 -- 2) First_Obj ....... Target
4775 -- 3) Target ........ Last_Obj
4777 if Present
(Before
) then
4779 -- Flag declarations are inserted before the first object
4781 First_Obj
:= First
(Before
);
4783 Insert_List_Before
(Target
, Before
);
4786 if Present
(After
) then
4788 -- Finalization calls are inserted after the last object
4790 Last_Obj
:= Last
(After
);
4792 Insert_List_After
(Target
, After
);
4795 -- Check for transient controlled objects associated with Target and
4796 -- generate the appropriate finalization actions for them.
4798 Process_Transient_Objects
4799 (First_Object
=> First_Obj
,
4800 Last_Object
=> Last_Obj
,
4801 Related_Node
=> Target
);
4803 -- Reset the action lists
4805 if Present
(Before
) then
4806 Scope_Stack
.Table
(Scope_Stack
.Last
).
4807 Actions_To_Be_Wrapped_Before
:= No_List
;
4810 if Present
(After
) then
4811 Scope_Stack
.Table
(Scope_Stack
.Last
).
4812 Actions_To_Be_Wrapped_After
:= No_List
;
4815 end Insert_Actions_In_Scope_Around
;
4817 ------------------------------
4818 -- Is_Simple_Protected_Type --
4819 ------------------------------
4821 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4824 Is_Protected_Type
(T
)
4825 and then not Uses_Lock_Free
(T
)
4826 and then not Has_Entries
(T
)
4827 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4828 end Is_Simple_Protected_Type
;
4830 -----------------------
4831 -- Make_Adjust_Call --
4832 -----------------------
4834 function Make_Adjust_Call
4837 For_Parent
: Boolean := False) return Node_Id
4839 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4840 Adj_Id
: Entity_Id
:= Empty
;
4841 Ref
: Node_Id
:= Obj_Ref
;
4845 -- Recover the proper type which contains Deep_Adjust
4847 if Is_Class_Wide_Type
(Typ
) then
4848 Utyp
:= Root_Type
(Typ
);
4853 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4854 Set_Assignment_OK
(Ref
);
4856 -- Deal with non-tagged derivation of private views
4858 if Is_Untagged_Derivation
(Typ
) then
4859 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4860 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4861 Set_Assignment_OK
(Ref
);
4864 -- When dealing with the completion of a private type, use the base
4867 if Utyp
/= Base_Type
(Utyp
) then
4868 pragma Assert
(Is_Private_Type
(Typ
));
4870 Utyp
:= Base_Type
(Utyp
);
4871 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4874 -- Select the appropriate version of adjust
4877 if Has_Controlled_Component
(Utyp
) then
4878 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4881 -- Class-wide types, interfaces and types with controlled components
4883 elsif Is_Class_Wide_Type
(Typ
)
4884 or else Is_Interface
(Typ
)
4885 or else Has_Controlled_Component
(Utyp
)
4887 if Is_Tagged_Type
(Utyp
) then
4888 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4890 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
4893 -- Derivations from [Limited_]Controlled
4895 elsif Is_Controlled
(Utyp
) then
4896 if Has_Controlled_Component
(Utyp
) then
4897 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4899 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
4904 elsif Is_Tagged_Type
(Utyp
) then
4905 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4908 raise Program_Error
;
4911 if Present
(Adj_Id
) then
4913 -- If the object is unanalyzed, set its expected type for use in
4914 -- Convert_View in case an additional conversion is needed.
4917 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
4919 Set_Etype
(Ref
, Typ
);
4922 -- The object reference may need another conversion depending on the
4923 -- type of the formal and that of the actual.
4925 if not Is_Class_Wide_Type
(Typ
) then
4926 Ref
:= Convert_View
(Adj_Id
, Ref
);
4929 return Make_Call
(Loc
, Adj_Id
, New_Copy_Tree
(Ref
), For_Parent
);
4933 end Make_Adjust_Call
;
4935 ----------------------
4936 -- Make_Attach_Call --
4937 ----------------------
4939 function Make_Attach_Call
4941 Ptr_Typ
: Entity_Id
) return Node_Id
4943 pragma Assert
(VM_Target
/= No_VM
);
4945 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4948 Make_Procedure_Call_Statement
(Loc
,
4950 New_Reference_To
(RTE
(RE_Attach
), Loc
),
4951 Parameter_Associations
=> New_List
(
4952 New_Reference_To
(Finalization_Master
(Ptr_Typ
), Loc
),
4953 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4954 end Make_Attach_Call
;
4956 ----------------------
4957 -- Make_Detach_Call --
4958 ----------------------
4960 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
4961 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4965 Make_Procedure_Call_Statement
(Loc
,
4967 New_Reference_To
(RTE
(RE_Detach
), Loc
),
4968 Parameter_Associations
=> New_List
(
4969 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4970 end Make_Detach_Call
;
4978 Proc_Id
: Entity_Id
;
4980 For_Parent
: Boolean := False) return Node_Id
4982 Params
: constant List_Id
:= New_List
(Param
);
4985 -- When creating a call to Deep_Finalize for a _parent field of a
4986 -- derived type, disable the invocation of the nested Finalize by giving
4987 -- the corresponding flag a False value.
4990 Append_To
(Params
, New_Reference_To
(Standard_False
, Loc
));
4994 Make_Procedure_Call_Statement
(Loc
,
4995 Name
=> New_Reference_To
(Proc_Id
, Loc
),
4996 Parameter_Associations
=> Params
);
4999 --------------------------
5000 -- Make_Deep_Array_Body --
5001 --------------------------
5003 function Make_Deep_Array_Body
5004 (Prim
: Final_Primitives
;
5005 Typ
: Entity_Id
) return List_Id
5007 function Build_Adjust_Or_Finalize_Statements
5008 (Typ
: Entity_Id
) return List_Id
;
5009 -- Create the statements necessary to adjust or finalize an array of
5010 -- controlled elements. Generate:
5013 -- Abort : constant Boolean := Triggered_By_Abort;
5015 -- Abort : constant Boolean := False; -- no abort
5017 -- E : Exception_Occurrence;
5018 -- Raised : Boolean := False;
5021 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5022 -- ^-- in the finalization case
5024 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5026 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5030 -- if not Raised then
5032 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5039 -- if Raised and then not Abort then
5040 -- Raise_From_Controlled_Operation (E);
5044 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5045 -- Create the statements necessary to initialize an array of controlled
5046 -- elements. Include a mechanism to carry out partial finalization if an
5047 -- exception occurs. Generate:
5050 -- Counter : Integer := 0;
5053 -- for J1 in V'Range (1) loop
5055 -- for JN in V'Range (N) loop
5057 -- [Deep_]Initialize (V (J1, ..., JN));
5059 -- Counter := Counter + 1;
5064 -- Abort : constant Boolean := Triggered_By_Abort;
5066 -- Abort : constant Boolean := False; -- no abort
5067 -- E : Exception_Occurence;
5068 -- Raised : Boolean := False;
5075 -- V'Length (N) - Counter;
5077 -- for F1 in reverse V'Range (1) loop
5079 -- for FN in reverse V'Range (N) loop
5080 -- if Counter > 0 then
5081 -- Counter := Counter - 1;
5084 -- [Deep_]Finalize (V (F1, ..., FN));
5088 -- if not Raised then
5090 -- Save_Occurrence (E,
5091 -- Get_Current_Excep.all.all);
5100 -- if Raised and then not Abort then
5101 -- Raise_From_Controlled_Operation (E);
5110 function New_References_To
5112 Loc
: Source_Ptr
) return List_Id
;
5113 -- Given a list of defining identifiers, return a list of references to
5114 -- the original identifiers, in the same order as they appear.
5116 -----------------------------------------
5117 -- Build_Adjust_Or_Finalize_Statements --
5118 -----------------------------------------
5120 function Build_Adjust_Or_Finalize_Statements
5121 (Typ
: Entity_Id
) return List_Id
5123 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5124 Index_List
: constant List_Id
:= New_List
;
5125 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5126 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5127 Finalizer_Decls
: List_Id
:= No_List
;
5128 Finalizer_Data
: Finalization_Exception_Data
;
5131 Core_Loop
: Node_Id
;
5134 Loop_Id
: Entity_Id
;
5137 Exceptions_OK
: constant Boolean :=
5138 not Restriction_Active
(No_Exception_Propagation
);
5140 procedure Build_Indices
;
5141 -- Generate the indices used in the dimension loops
5147 procedure Build_Indices
is
5149 -- Generate the following identifiers:
5150 -- Jnn - for initialization
5152 for Dim
in 1 .. Num_Dims
loop
5153 Append_To
(Index_List
,
5154 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5158 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5161 Finalizer_Decls
:= New_List
;
5164 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5167 Make_Indexed_Component
(Loc
,
5168 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5169 Expressions
=> New_References_To
(Index_List
, Loc
));
5170 Set_Etype
(Comp_Ref
, Comp_Typ
);
5173 -- [Deep_]Adjust (V (J1, ..., JN))
5175 if Prim
= Adjust_Case
then
5176 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5179 -- [Deep_]Finalize (V (J1, ..., JN))
5181 else pragma Assert
(Prim
= Finalize_Case
);
5182 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5185 -- Generate the block which houses the adjust or finalize call:
5187 -- <adjust or finalize call>; -- No_Exception_Propagation
5189 -- begin -- Exception handlers allowed
5190 -- <adjust or finalize call>
5194 -- if not Raised then
5196 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5200 if Exceptions_OK
then
5202 Make_Block_Statement
(Loc
,
5203 Handled_Statement_Sequence
=>
5204 Make_Handled_Sequence_Of_Statements
(Loc
,
5205 Statements
=> New_List
(Call
),
5206 Exception_Handlers
=> New_List
(
5207 Build_Exception_Handler
(Finalizer_Data
))));
5212 -- Generate the dimension loops starting from the innermost one
5214 -- for Jnn in [reverse] V'Range (Dim) loop
5218 J
:= Last
(Index_List
);
5220 while Present
(J
) and then Dim
> 0 loop
5226 Make_Loop_Statement
(Loc
,
5228 Make_Iteration_Scheme
(Loc
,
5229 Loop_Parameter_Specification
=>
5230 Make_Loop_Parameter_Specification
(Loc
,
5231 Defining_Identifier
=> Loop_Id
,
5232 Discrete_Subtype_Definition
=>
5233 Make_Attribute_Reference
(Loc
,
5234 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5235 Attribute_Name
=> Name_Range
,
5236 Expressions
=> New_List
(
5237 Make_Integer_Literal
(Loc
, Dim
))),
5239 Reverse_Present
=> Prim
= Finalize_Case
)),
5241 Statements
=> New_List
(Core_Loop
),
5242 End_Label
=> Empty
);
5247 -- Generate the block which contains the core loop, the declarations
5248 -- of the abort flag, the exception occurrence, the raised flag and
5249 -- the conditional raise:
5252 -- Abort : constant Boolean := Triggered_By_Abort;
5254 -- Abort : constant Boolean := False; -- no abort
5256 -- E : Exception_Occurrence;
5257 -- Raised : Boolean := False;
5262 -- if Raised and then not Abort then -- Expection handlers OK
5263 -- Raise_From_Controlled_Operation (E);
5267 Stmts
:= New_List
(Core_Loop
);
5269 if Exceptions_OK
then
5271 Build_Raise_Statement
(Finalizer_Data
));
5276 Make_Block_Statement
(Loc
,
5279 Handled_Statement_Sequence
=>
5280 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5281 end Build_Adjust_Or_Finalize_Statements
;
5283 ---------------------------------
5284 -- Build_Initialize_Statements --
5285 ---------------------------------
5287 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5288 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5289 Final_List
: constant List_Id
:= New_List
;
5290 Index_List
: constant List_Id
:= New_List
;
5291 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5292 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5293 Counter_Id
: Entity_Id
;
5297 Final_Block
: Node_Id
;
5298 Final_Loop
: Node_Id
;
5299 Finalizer_Data
: Finalization_Exception_Data
;
5300 Finalizer_Decls
: List_Id
:= No_List
;
5301 Init_Loop
: Node_Id
;
5306 Exceptions_OK
: constant Boolean :=
5307 not Restriction_Active
(No_Exception_Propagation
);
5309 function Build_Counter_Assignment
return Node_Id
;
5310 -- Generate the following assignment:
5311 -- Counter := V'Length (1) *
5313 -- V'Length (N) - Counter;
5315 function Build_Finalization_Call
return Node_Id
;
5316 -- Generate a deep finalization call for an array element
5318 procedure Build_Indices
;
5319 -- Generate the initialization and finalization indices used in the
5322 function Build_Initialization_Call
return Node_Id
;
5323 -- Generate a deep initialization call for an array element
5325 ------------------------------
5326 -- Build_Counter_Assignment --
5327 ------------------------------
5329 function Build_Counter_Assignment
return Node_Id
is
5334 -- Start from the first dimension and generate:
5339 Make_Attribute_Reference
(Loc
,
5340 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5341 Attribute_Name
=> Name_Length
,
5342 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5344 -- Process the rest of the dimensions, generate:
5345 -- Expr * V'Length (N)
5348 while Dim
<= Num_Dims
loop
5350 Make_Op_Multiply
(Loc
,
5353 Make_Attribute_Reference
(Loc
,
5354 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5355 Attribute_Name
=> Name_Length
,
5356 Expressions
=> New_List
(
5357 Make_Integer_Literal
(Loc
, Dim
))));
5363 -- Counter := Expr - Counter;
5366 Make_Assignment_Statement
(Loc
,
5367 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5369 Make_Op_Subtract
(Loc
,
5371 Right_Opnd
=> New_Reference_To
(Counter_Id
, Loc
)));
5372 end Build_Counter_Assignment
;
5374 -----------------------------
5375 -- Build_Finalization_Call --
5376 -----------------------------
5378 function Build_Finalization_Call
return Node_Id
is
5379 Comp_Ref
: constant Node_Id
:=
5380 Make_Indexed_Component
(Loc
,
5381 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5382 Expressions
=> New_References_To
(Final_List
, Loc
));
5385 Set_Etype
(Comp_Ref
, Comp_Typ
);
5388 -- [Deep_]Finalize (V);
5390 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5391 end Build_Finalization_Call
;
5397 procedure Build_Indices
is
5399 -- Generate the following identifiers:
5400 -- Jnn - for initialization
5401 -- Fnn - for finalization
5403 for Dim
in 1 .. Num_Dims
loop
5404 Append_To
(Index_List
,
5405 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5407 Append_To
(Final_List
,
5408 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5412 -------------------------------
5413 -- Build_Initialization_Call --
5414 -------------------------------
5416 function Build_Initialization_Call
return Node_Id
is
5417 Comp_Ref
: constant Node_Id
:=
5418 Make_Indexed_Component
(Loc
,
5419 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5420 Expressions
=> New_References_To
(Index_List
, Loc
));
5423 Set_Etype
(Comp_Ref
, Comp_Typ
);
5426 -- [Deep_]Initialize (V (J1, ..., JN));
5428 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5429 end Build_Initialization_Call
;
5431 -- Start of processing for Build_Initialize_Statements
5434 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5435 Finalizer_Decls
:= New_List
;
5438 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5440 -- Generate the block which houses the finalization call, the index
5441 -- guard and the handler which triggers Program_Error later on.
5443 -- if Counter > 0 then
5444 -- Counter := Counter - 1;
5446 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5448 -- begin -- Exceptions allowed
5449 -- [Deep_]Finalize (V (F1, ..., FN));
5452 -- if not Raised then
5454 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5459 if Exceptions_OK
then
5461 Make_Block_Statement
(Loc
,
5462 Handled_Statement_Sequence
=>
5463 Make_Handled_Sequence_Of_Statements
(Loc
,
5464 Statements
=> New_List
(Build_Finalization_Call
),
5465 Exception_Handlers
=> New_List
(
5466 Build_Exception_Handler
(Finalizer_Data
))));
5468 Fin_Stmt
:= Build_Finalization_Call
;
5471 -- This is the core of the loop, the dimension iterators are added
5472 -- one by one in reverse.
5475 Make_If_Statement
(Loc
,
5478 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5479 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5481 Then_Statements
=> New_List
(
5482 Make_Assignment_Statement
(Loc
,
5483 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5485 Make_Op_Subtract
(Loc
,
5486 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5487 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5489 Else_Statements
=> New_List
(Fin_Stmt
));
5491 -- Generate all finalization loops starting from the innermost
5494 -- for Fnn in reverse V'Range (Dim) loop
5498 F
:= Last
(Final_List
);
5500 while Present
(F
) and then Dim
> 0 loop
5506 Make_Loop_Statement
(Loc
,
5508 Make_Iteration_Scheme
(Loc
,
5509 Loop_Parameter_Specification
=>
5510 Make_Loop_Parameter_Specification
(Loc
,
5511 Defining_Identifier
=> Loop_Id
,
5512 Discrete_Subtype_Definition
=>
5513 Make_Attribute_Reference
(Loc
,
5514 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5515 Attribute_Name
=> Name_Range
,
5516 Expressions
=> New_List
(
5517 Make_Integer_Literal
(Loc
, Dim
))),
5519 Reverse_Present
=> True)),
5521 Statements
=> New_List
(Final_Loop
),
5522 End_Label
=> Empty
);
5527 -- Generate the block which contains the finalization loops, the
5528 -- declarations of the abort flag, the exception occurrence, the
5529 -- raised flag and the conditional raise.
5532 -- Abort : constant Boolean := Triggered_By_Abort;
5534 -- Abort : constant Boolean := False; -- no abort
5536 -- E : Exception_Occurrence;
5537 -- Raised : Boolean := False;
5543 -- V'Length (N) - Counter;
5547 -- if Raised and then not Abort then -- Exception handlers OK
5548 -- Raise_From_Controlled_Operation (E);
5551 -- raise; -- Exception handlers OK
5554 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5556 if Exceptions_OK
then
5558 Build_Raise_Statement
(Finalizer_Data
));
5559 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5563 Make_Block_Statement
(Loc
,
5566 Handled_Statement_Sequence
=>
5567 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5569 -- Generate the block which contains the initialization call and
5570 -- the partial finalization code.
5573 -- [Deep_]Initialize (V (J1, ..., JN));
5575 -- Counter := Counter + 1;
5579 -- <finalization code>
5583 Make_Block_Statement
(Loc
,
5584 Handled_Statement_Sequence
=>
5585 Make_Handled_Sequence_Of_Statements
(Loc
,
5586 Statements
=> New_List
(Build_Initialization_Call
),
5587 Exception_Handlers
=> New_List
(
5588 Make_Exception_Handler
(Loc
,
5589 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5590 Statements
=> New_List
(Final_Block
)))));
5592 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5593 Make_Assignment_Statement
(Loc
,
5594 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5597 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5598 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5600 -- Generate all initialization loops starting from the innermost
5603 -- for Jnn in V'Range (Dim) loop
5607 J
:= Last
(Index_List
);
5609 while Present
(J
) and then Dim
> 0 loop
5615 Make_Loop_Statement
(Loc
,
5617 Make_Iteration_Scheme
(Loc
,
5618 Loop_Parameter_Specification
=>
5619 Make_Loop_Parameter_Specification
(Loc
,
5620 Defining_Identifier
=> Loop_Id
,
5621 Discrete_Subtype_Definition
=>
5622 Make_Attribute_Reference
(Loc
,
5623 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5624 Attribute_Name
=> Name_Range
,
5625 Expressions
=> New_List
(
5626 Make_Integer_Literal
(Loc
, Dim
))))),
5628 Statements
=> New_List
(Init_Loop
),
5629 End_Label
=> Empty
);
5634 -- Generate the block which contains the counter variable and the
5635 -- initialization loops.
5638 -- Counter : Integer := 0;
5645 Make_Block_Statement
(Loc
,
5646 Declarations
=> New_List
(
5647 Make_Object_Declaration
(Loc
,
5648 Defining_Identifier
=> Counter_Id
,
5649 Object_Definition
=>
5650 New_Reference_To
(Standard_Integer
, Loc
),
5651 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5653 Handled_Statement_Sequence
=>
5654 Make_Handled_Sequence_Of_Statements
(Loc
,
5655 Statements
=> New_List
(Init_Loop
))));
5656 end Build_Initialize_Statements
;
5658 -----------------------
5659 -- New_References_To --
5660 -----------------------
5662 function New_References_To
5664 Loc
: Source_Ptr
) return List_Id
5666 Refs
: constant List_Id
:= New_List
;
5671 while Present
(Id
) loop
5672 Append_To
(Refs
, New_Reference_To
(Id
, Loc
));
5677 end New_References_To
;
5679 -- Start of processing for Make_Deep_Array_Body
5683 when Address_Case
=>
5684 return Make_Finalize_Address_Stmts
(Typ
);
5688 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5690 when Initialize_Case
=>
5691 return Build_Initialize_Statements
(Typ
);
5693 end Make_Deep_Array_Body
;
5695 --------------------
5696 -- Make_Deep_Proc --
5697 --------------------
5699 function Make_Deep_Proc
5700 (Prim
: Final_Primitives
;
5702 Stmts
: List_Id
) return Entity_Id
5704 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5706 Proc_Id
: Entity_Id
;
5709 -- Create the object formal, generate:
5710 -- V : System.Address
5712 if Prim
= Address_Case
then
5713 Formals
:= New_List
(
5714 Make_Parameter_Specification
(Loc
,
5715 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5716 Parameter_Type
=> New_Reference_To
(RTE
(RE_Address
), Loc
)));
5723 Formals
:= New_List
(
5724 Make_Parameter_Specification
(Loc
,
5725 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5727 Out_Present
=> True,
5728 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5730 -- F : Boolean := True
5732 if Prim
= Adjust_Case
5733 or else Prim
= Finalize_Case
5736 Make_Parameter_Specification
(Loc
,
5737 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5739 New_Reference_To
(Standard_Boolean
, Loc
),
5741 New_Reference_To
(Standard_True
, Loc
)));
5746 Make_Defining_Identifier
(Loc
,
5747 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5750 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5753 -- exception -- Finalize and Adjust cases only
5754 -- raise Program_Error;
5755 -- end Deep_Initialize / Adjust / Finalize;
5759 -- procedure Finalize_Address (V : System.Address) is
5762 -- end Finalize_Address;
5765 Make_Subprogram_Body
(Loc
,
5767 Make_Procedure_Specification
(Loc
,
5768 Defining_Unit_Name
=> Proc_Id
,
5769 Parameter_Specifications
=> Formals
),
5771 Declarations
=> Empty_List
,
5773 Handled_Statement_Sequence
=>
5774 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5779 ---------------------------
5780 -- Make_Deep_Record_Body --
5781 ---------------------------
5783 function Make_Deep_Record_Body
5784 (Prim
: Final_Primitives
;
5786 Is_Local
: Boolean := False) return List_Id
5788 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5789 -- Build the statements necessary to adjust a record type. The type may
5790 -- have discriminants and contain variant parts. Generate:
5794 -- [Deep_]Adjust (V.Comp_1);
5796 -- when Id : others =>
5797 -- if not Raised then
5799 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5804 -- [Deep_]Adjust (V.Comp_N);
5806 -- when Id : others =>
5807 -- if not Raised then
5809 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5814 -- Deep_Adjust (V._parent, False); -- If applicable
5816 -- when Id : others =>
5817 -- if not Raised then
5819 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5825 -- Adjust (V); -- If applicable
5828 -- if not Raised then
5830 -- Save_Occurence (E, Get_Current_Excep.all.all);
5835 -- if Raised and then not Abort then
5836 -- Raise_From_Controlled_Operation (E);
5840 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5841 -- Build the statements necessary to finalize a record type. The type
5842 -- may have discriminants and contain variant parts. Generate:
5845 -- Abort : constant Boolean := Triggered_By_Abort;
5847 -- Abort : constant Boolean := False; -- no abort
5848 -- E : Exception_Occurence;
5849 -- Raised : Boolean := False;
5854 -- Finalize (V); -- If applicable
5857 -- if not Raised then
5859 -- Save_Occurence (E, Get_Current_Excep.all.all);
5864 -- case Variant_1 is
5866 -- case State_Counter_N => -- If Is_Local is enabled
5876 -- <<LN>> -- If Is_Local is enabled
5878 -- [Deep_]Finalize (V.Comp_N);
5881 -- if not Raised then
5883 -- Save_Occurence (E, Get_Current_Excep.all.all);
5889 -- [Deep_]Finalize (V.Comp_1);
5892 -- if not Raised then
5894 -- Save_Occurence (E, Get_Current_Excep.all.all);
5900 -- case State_Counter_1 => -- If Is_Local is enabled
5906 -- Deep_Finalize (V._parent, False); -- If applicable
5908 -- when Id : others =>
5909 -- if not Raised then
5911 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5915 -- if Raised and then not Abort then
5916 -- Raise_From_Controlled_Operation (E);
5920 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
5921 -- Given a derived tagged type Typ, traverse all components, find field
5922 -- _parent and return its type.
5924 procedure Preprocess_Components
5926 Num_Comps
: out Int
;
5927 Has_POC
: out Boolean);
5928 -- Examine all components in component list Comps, count all controlled
5929 -- components and determine whether at least one of them is per-object
5930 -- constrained. Component _parent is always skipped.
5932 -----------------------------
5933 -- Build_Adjust_Statements --
5934 -----------------------------
5936 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
5937 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5938 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
5939 Bod_Stmts
: List_Id
;
5940 Finalizer_Data
: Finalization_Exception_Data
;
5941 Finalizer_Decls
: List_Id
:= No_List
;
5945 Exceptions_OK
: constant Boolean :=
5946 not Restriction_Active
(No_Exception_Propagation
);
5948 function Process_Component_List_For_Adjust
5949 (Comps
: Node_Id
) return List_Id
;
5950 -- Build all necessary adjust statements for a single component list
5952 ---------------------------------------
5953 -- Process_Component_List_For_Adjust --
5954 ---------------------------------------
5956 function Process_Component_List_For_Adjust
5957 (Comps
: Node_Id
) return List_Id
5959 Stmts
: constant List_Id
:= New_List
;
5961 Decl_Id
: Entity_Id
;
5962 Decl_Typ
: Entity_Id
;
5966 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
5967 -- Process the declaration of a single controlled component
5969 ----------------------------------
5970 -- Process_Component_For_Adjust --
5971 ----------------------------------
5973 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
5974 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
5975 Typ
: constant Entity_Id
:= Etype
(Id
);
5980 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
5982 -- begin -- Exception handlers allowed
5983 -- [Deep_]Adjust (V.Id);
5986 -- if not Raised then
5988 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5995 Make_Selected_Component
(Loc
,
5996 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5997 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6000 if Exceptions_OK
then
6002 Make_Block_Statement
(Loc
,
6003 Handled_Statement_Sequence
=>
6004 Make_Handled_Sequence_Of_Statements
(Loc
,
6005 Statements
=> New_List
(Adj_Stmt
),
6006 Exception_Handlers
=> New_List
(
6007 Build_Exception_Handler
(Finalizer_Data
))));
6010 Append_To
(Stmts
, Adj_Stmt
);
6011 end Process_Component_For_Adjust
;
6013 -- Start of processing for Process_Component_List_For_Adjust
6016 -- Perform an initial check, determine the number of controlled
6017 -- components in the current list and whether at least one of them
6018 -- is per-object constrained.
6020 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6022 -- The processing in this routine is done in the following order:
6023 -- 1) Regular components
6024 -- 2) Per-object constrained components
6027 if Num_Comps
> 0 then
6029 -- Process all regular components in order of declarations
6031 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6032 while Present
(Decl
) loop
6033 Decl_Id
:= Defining_Identifier
(Decl
);
6034 Decl_Typ
:= Etype
(Decl_Id
);
6036 -- Skip _parent as well as per-object constrained components
6038 if Chars
(Decl_Id
) /= Name_uParent
6039 and then Needs_Finalization
(Decl_Typ
)
6041 if Has_Access_Constraint
(Decl_Id
)
6042 and then No
(Expression
(Decl
))
6046 Process_Component_For_Adjust
(Decl
);
6050 Next_Non_Pragma
(Decl
);
6053 -- Process all per-object constrained components in order of
6057 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6058 while Present
(Decl
) loop
6059 Decl_Id
:= Defining_Identifier
(Decl
);
6060 Decl_Typ
:= Etype
(Decl_Id
);
6064 if Chars
(Decl_Id
) /= Name_uParent
6065 and then Needs_Finalization
(Decl_Typ
)
6066 and then Has_Access_Constraint
(Decl_Id
)
6067 and then No
(Expression
(Decl
))
6069 Process_Component_For_Adjust
(Decl
);
6072 Next_Non_Pragma
(Decl
);
6077 -- Process all variants, if any
6080 if Present
(Variant_Part
(Comps
)) then
6082 Var_Alts
: constant List_Id
:= New_List
;
6086 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6087 while Present
(Var
) loop
6090 -- when <discrete choices> =>
6091 -- <adjust statements>
6093 Append_To
(Var_Alts
,
6094 Make_Case_Statement_Alternative
(Loc
,
6096 New_Copy_List
(Discrete_Choices
(Var
)),
6098 Process_Component_List_For_Adjust
(
6099 Component_List
(Var
))));
6101 Next_Non_Pragma
(Var
);
6105 -- case V.<discriminant> is
6106 -- when <discrete choices 1> =>
6107 -- <adjust statements 1>
6109 -- when <discrete choices N> =>
6110 -- <adjust statements N>
6114 Make_Case_Statement
(Loc
,
6116 Make_Selected_Component
(Loc
,
6117 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6119 Make_Identifier
(Loc
,
6120 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6121 Alternatives
=> Var_Alts
);
6125 -- Add the variant case statement to the list of statements
6127 if Present
(Var_Case
) then
6128 Append_To
(Stmts
, Var_Case
);
6131 -- If the component list did not have any controlled components
6132 -- nor variants, return null.
6134 if Is_Empty_List
(Stmts
) then
6135 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6139 end Process_Component_List_For_Adjust
;
6141 -- Start of processing for Build_Adjust_Statements
6144 Finalizer_Decls
:= New_List
;
6145 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6147 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6148 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6153 -- Create an adjust sequence for all record components
6155 if Present
(Component_List
(Rec_Def
)) then
6157 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6160 -- A derived record type must adjust all inherited components. This
6161 -- action poses the following problem:
6163 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6168 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6170 -- Deep_Adjust (Obj._parent);
6175 -- Adjusting the derived type will invoke Adjust of the parent and
6176 -- then that of the derived type. This is undesirable because both
6177 -- routines may modify shared components. Only the Adjust of the
6178 -- derived type should be invoked.
6180 -- To prevent this double adjustment of shared components,
6181 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6183 -- procedure Deep_Adjust
6184 -- (Obj : in out Some_Type;
6185 -- Flag : Boolean := True)
6193 -- When Deep_Adjust is invokes for field _parent, a value of False is
6194 -- provided for the flag:
6196 -- Deep_Adjust (Obj._parent, False);
6198 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6200 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6205 if Needs_Finalization
(Par_Typ
) then
6209 Make_Selected_Component
(Loc
,
6210 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6212 Make_Identifier
(Loc
, Name_uParent
)),
6214 For_Parent
=> True);
6217 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6219 -- begin -- Exceptions OK
6220 -- Deep_Adjust (V._parent, False);
6222 -- when Id : others =>
6223 -- if not Raised then
6225 -- Save_Occurrence (E,
6226 -- Get_Current_Excep.all.all);
6230 if Present
(Call
) then
6233 if Exceptions_OK
then
6235 Make_Block_Statement
(Loc
,
6236 Handled_Statement_Sequence
=>
6237 Make_Handled_Sequence_Of_Statements
(Loc
,
6238 Statements
=> New_List
(Adj_Stmt
),
6239 Exception_Handlers
=> New_List
(
6240 Build_Exception_Handler
(Finalizer_Data
))));
6243 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6249 -- Adjust the object. This action must be performed last after all
6250 -- components have been adjusted.
6252 if Is_Controlled
(Typ
) then
6258 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6262 -- Adjust (V); -- No_Exception_Propagation
6264 -- begin -- Exception handlers allowed
6268 -- if not Raised then
6270 -- Save_Occurrence (E,
6271 -- Get_Current_Excep.all.all);
6276 if Present
(Proc
) then
6278 Make_Procedure_Call_Statement
(Loc
,
6279 Name
=> New_Reference_To
(Proc
, Loc
),
6280 Parameter_Associations
=> New_List
(
6281 Make_Identifier
(Loc
, Name_V
)));
6283 if Exceptions_OK
then
6285 Make_Block_Statement
(Loc
,
6286 Handled_Statement_Sequence
=>
6287 Make_Handled_Sequence_Of_Statements
(Loc
,
6288 Statements
=> New_List
(Adj_Stmt
),
6289 Exception_Handlers
=> New_List
(
6290 Build_Exception_Handler
6291 (Finalizer_Data
))));
6294 Append_To
(Bod_Stmts
,
6295 Make_If_Statement
(Loc
,
6296 Condition
=> Make_Identifier
(Loc
, Name_F
),
6297 Then_Statements
=> New_List
(Adj_Stmt
)));
6302 -- At this point either all adjustment statements have been generated
6303 -- or the type is not controlled.
6305 if Is_Empty_List
(Bod_Stmts
) then
6306 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6312 -- Abort : constant Boolean := Triggered_By_Abort;
6314 -- Abort : constant Boolean := False; -- no abort
6316 -- E : Exception_Occurence;
6317 -- Raised : Boolean := False;
6320 -- <adjust statements>
6322 -- if Raised and then not Abort then
6323 -- Raise_From_Controlled_Operation (E);
6328 if Exceptions_OK
then
6329 Append_To
(Bod_Stmts
,
6330 Build_Raise_Statement
(Finalizer_Data
));
6335 Make_Block_Statement
(Loc
,
6338 Handled_Statement_Sequence
=>
6339 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6341 end Build_Adjust_Statements
;
6343 -------------------------------
6344 -- Build_Finalize_Statements --
6345 -------------------------------
6347 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6348 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6349 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6350 Bod_Stmts
: List_Id
;
6352 Finalizer_Data
: Finalization_Exception_Data
;
6353 Finalizer_Decls
: List_Id
:= No_List
;
6357 Exceptions_OK
: constant Boolean :=
6358 not Restriction_Active
(No_Exception_Propagation
);
6360 function Process_Component_List_For_Finalize
6361 (Comps
: Node_Id
) return List_Id
;
6362 -- Build all necessary finalization statements for a single component
6363 -- list. The statements may include a jump circuitry if flag Is_Local
6366 -----------------------------------------
6367 -- Process_Component_List_For_Finalize --
6368 -----------------------------------------
6370 function Process_Component_List_For_Finalize
6371 (Comps
: Node_Id
) return List_Id
6374 Counter_Id
: Entity_Id
;
6376 Decl_Id
: Entity_Id
;
6377 Decl_Typ
: Entity_Id
;
6380 Jump_Block
: Node_Id
;
6382 Label_Id
: Entity_Id
;
6386 procedure Process_Component_For_Finalize
6391 -- Process the declaration of a single controlled component. If
6392 -- flag Is_Local is enabled, create the corresponding label and
6393 -- jump circuitry. Alts is the list of case alternatives, Decls
6394 -- is the top level declaration list where labels are declared
6395 -- and Stmts is the list of finalization actions.
6397 ------------------------------------
6398 -- Process_Component_For_Finalize --
6399 ------------------------------------
6401 procedure Process_Component_For_Finalize
6407 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6408 Typ
: constant Entity_Id
:= Etype
(Id
);
6415 Label_Id
: Entity_Id
;
6422 Make_Identifier
(Loc
,
6423 Chars
=> New_External_Name
('L', Num_Comps
));
6424 Set_Entity
(Label_Id
,
6425 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6426 Label
:= Make_Label
(Loc
, Label_Id
);
6429 Make_Implicit_Label_Declaration
(Loc
,
6430 Defining_Identifier
=> Entity
(Label_Id
),
6431 Label_Construct
=> Label
));
6438 Make_Case_Statement_Alternative
(Loc
,
6439 Discrete_Choices
=> New_List
(
6440 Make_Integer_Literal
(Loc
, Num_Comps
)),
6442 Statements
=> New_List
(
6443 Make_Goto_Statement
(Loc
,
6445 New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6450 Append_To
(Stmts
, Label
);
6452 -- Decrease the number of components to be processed.
6453 -- This action yields a new Label_Id in future calls.
6455 Num_Comps
:= Num_Comps
- 1;
6460 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6462 -- begin -- Exception handlers allowed
6463 -- [Deep_]Finalize (V.Id);
6466 -- if not Raised then
6468 -- Save_Occurrence (E,
6469 -- Get_Current_Excep.all.all);
6476 Make_Selected_Component
(Loc
,
6477 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6478 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6481 if not Restriction_Active
(No_Exception_Propagation
) then
6483 Make_Block_Statement
(Loc
,
6484 Handled_Statement_Sequence
=>
6485 Make_Handled_Sequence_Of_Statements
(Loc
,
6486 Statements
=> New_List
(Fin_Stmt
),
6487 Exception_Handlers
=> New_List
(
6488 Build_Exception_Handler
(Finalizer_Data
))));
6491 Append_To
(Stmts
, Fin_Stmt
);
6492 end Process_Component_For_Finalize
;
6494 -- Start of processing for Process_Component_List_For_Finalize
6497 -- Perform an initial check, look for controlled and per-object
6498 -- constrained components.
6500 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6502 -- Create a state counter to service the current component list.
6503 -- This step is performed before the variants are inspected in
6504 -- order to generate the same state counter names as those from
6505 -- Build_Initialize_Statements.
6510 Counter
:= Counter
+ 1;
6513 Make_Defining_Identifier
(Loc
,
6514 Chars
=> New_External_Name
('C', Counter
));
6517 -- Process the component in the following order:
6519 -- 2) Per-object constrained components
6520 -- 3) Regular components
6522 -- Start with the variant parts
6525 if Present
(Variant_Part
(Comps
)) then
6527 Var_Alts
: constant List_Id
:= New_List
;
6531 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6532 while Present
(Var
) loop
6535 -- when <discrete choices> =>
6536 -- <finalize statements>
6538 Append_To
(Var_Alts
,
6539 Make_Case_Statement_Alternative
(Loc
,
6541 New_Copy_List
(Discrete_Choices
(Var
)),
6543 Process_Component_List_For_Finalize
(
6544 Component_List
(Var
))));
6546 Next_Non_Pragma
(Var
);
6550 -- case V.<discriminant> is
6551 -- when <discrete choices 1> =>
6552 -- <finalize statements 1>
6554 -- when <discrete choices N> =>
6555 -- <finalize statements N>
6559 Make_Case_Statement
(Loc
,
6561 Make_Selected_Component
(Loc
,
6562 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6564 Make_Identifier
(Loc
,
6565 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6566 Alternatives
=> Var_Alts
);
6570 -- The current component list does not have a single controlled
6571 -- component, however it may contain variants. Return the case
6572 -- statement for the variants or nothing.
6574 if Num_Comps
= 0 then
6575 if Present
(Var_Case
) then
6576 return New_List
(Var_Case
);
6578 return New_List
(Make_Null_Statement
(Loc
));
6582 -- Prepare all lists
6588 -- Process all per-object constrained components in reverse order
6591 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6592 while Present
(Decl
) loop
6593 Decl_Id
:= Defining_Identifier
(Decl
);
6594 Decl_Typ
:= Etype
(Decl_Id
);
6598 if Chars
(Decl_Id
) /= Name_uParent
6599 and then Needs_Finalization
(Decl_Typ
)
6600 and then Has_Access_Constraint
(Decl_Id
)
6601 and then No
(Expression
(Decl
))
6603 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6606 Prev_Non_Pragma
(Decl
);
6610 -- Process the rest of the components in reverse order
6612 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6613 while Present
(Decl
) loop
6614 Decl_Id
:= Defining_Identifier
(Decl
);
6615 Decl_Typ
:= Etype
(Decl_Id
);
6619 if Chars
(Decl_Id
) /= Name_uParent
6620 and then Needs_Finalization
(Decl_Typ
)
6622 -- Skip per-object constrained components since they were
6623 -- handled in the above step.
6625 if Has_Access_Constraint
(Decl_Id
)
6626 and then No
(Expression
(Decl
))
6630 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6634 Prev_Non_Pragma
(Decl
);
6639 -- LN : label; -- If Is_Local is enabled
6644 -- case CounterX is .
6654 -- <<LN>> -- If Is_Local is enabled
6656 -- [Deep_]Finalize (V.CompY);
6658 -- when Id : others =>
6659 -- if not Raised then
6661 -- Save_Occurrence (E,
6662 -- Get_Current_Excep.all.all);
6666 -- <<L0>> -- If Is_Local is enabled
6671 -- Add the declaration of default jump location L0, its
6672 -- corresponding alternative and its place in the statements.
6674 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6675 Set_Entity
(Label_Id
,
6676 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6677 Label
:= Make_Label
(Loc
, Label_Id
);
6679 Append_To
(Decls
, -- declaration
6680 Make_Implicit_Label_Declaration
(Loc
,
6681 Defining_Identifier
=> Entity
(Label_Id
),
6682 Label_Construct
=> Label
));
6684 Append_To
(Alts
, -- alternative
6685 Make_Case_Statement_Alternative
(Loc
,
6686 Discrete_Choices
=> New_List
(
6687 Make_Others_Choice
(Loc
)),
6689 Statements
=> New_List
(
6690 Make_Goto_Statement
(Loc
,
6691 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6693 Append_To
(Stmts
, Label
); -- statement
6695 -- Create the jump block
6698 Make_Case_Statement
(Loc
,
6699 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6700 Alternatives
=> Alts
));
6704 Make_Block_Statement
(Loc
,
6705 Declarations
=> Decls
,
6706 Handled_Statement_Sequence
=>
6707 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6709 if Present
(Var_Case
) then
6710 return New_List
(Var_Case
, Jump_Block
);
6712 return New_List
(Jump_Block
);
6714 end Process_Component_List_For_Finalize
;
6716 -- Start of processing for Build_Finalize_Statements
6719 Finalizer_Decls
:= New_List
;
6720 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6722 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6723 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6728 -- Create a finalization sequence for all record components
6730 if Present
(Component_List
(Rec_Def
)) then
6732 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6735 -- A derived record type must finalize all inherited components. This
6736 -- action poses the following problem:
6738 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6743 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6745 -- Deep_Finalize (Obj._parent);
6750 -- Finalizing the derived type will invoke Finalize of the parent and
6751 -- then that of the derived type. This is undesirable because both
6752 -- routines may modify shared components. Only the Finalize of the
6753 -- derived type should be invoked.
6755 -- To prevent this double adjustment of shared components,
6756 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6758 -- procedure Deep_Finalize
6759 -- (Obj : in out Some_Type;
6760 -- Flag : Boolean := True)
6768 -- When Deep_Finalize is invokes for field _parent, a value of False
6769 -- is provided for the flag:
6771 -- Deep_Finalize (Obj._parent, False);
6773 if Is_Tagged_Type
(Typ
)
6774 and then Is_Derived_Type
(Typ
)
6777 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6782 if Needs_Finalization
(Par_Typ
) then
6786 Make_Selected_Component
(Loc
,
6787 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6789 Make_Identifier
(Loc
, Name_uParent
)),
6791 For_Parent
=> True);
6794 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6796 -- begin -- Exceptions OK
6797 -- Deep_Finalize (V._parent, False);
6799 -- when Id : others =>
6800 -- if not Raised then
6802 -- Save_Occurrence (E,
6803 -- Get_Current_Excep.all.all);
6807 if Present
(Call
) then
6810 if Exceptions_OK
then
6812 Make_Block_Statement
(Loc
,
6813 Handled_Statement_Sequence
=>
6814 Make_Handled_Sequence_Of_Statements
(Loc
,
6815 Statements
=> New_List
(Fin_Stmt
),
6816 Exception_Handlers
=> New_List
(
6817 Build_Exception_Handler
6818 (Finalizer_Data
))));
6821 Append_To
(Bod_Stmts
, Fin_Stmt
);
6827 -- Finalize the object. This action must be performed first before
6828 -- all components have been finalized.
6830 if Is_Controlled
(Typ
)
6831 and then not Is_Local
6838 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6842 -- Finalize (V); -- No_Exception_Propagation
6848 -- if not Raised then
6850 -- Save_Occurrence (E,
6851 -- Get_Current_Excep.all.all);
6856 if Present
(Proc
) then
6858 Make_Procedure_Call_Statement
(Loc
,
6859 Name
=> New_Reference_To
(Proc
, Loc
),
6860 Parameter_Associations
=> New_List
(
6861 Make_Identifier
(Loc
, Name_V
)));
6863 if Exceptions_OK
then
6865 Make_Block_Statement
(Loc
,
6866 Handled_Statement_Sequence
=>
6867 Make_Handled_Sequence_Of_Statements
(Loc
,
6868 Statements
=> New_List
(Fin_Stmt
),
6869 Exception_Handlers
=> New_List
(
6870 Build_Exception_Handler
6871 (Finalizer_Data
))));
6874 Prepend_To
(Bod_Stmts
,
6875 Make_If_Statement
(Loc
,
6876 Condition
=> Make_Identifier
(Loc
, Name_F
),
6877 Then_Statements
=> New_List
(Fin_Stmt
)));
6882 -- At this point either all finalization statements have been
6883 -- generated or the type is not controlled.
6885 if No
(Bod_Stmts
) then
6886 return New_List
(Make_Null_Statement
(Loc
));
6890 -- Abort : constant Boolean := Triggered_By_Abort;
6892 -- Abort : constant Boolean := False; -- no abort
6894 -- E : Exception_Occurence;
6895 -- Raised : Boolean := False;
6898 -- <finalize statements>
6900 -- if Raised and then not Abort then
6901 -- Raise_From_Controlled_Operation (E);
6906 if Exceptions_OK
then
6907 Append_To
(Bod_Stmts
,
6908 Build_Raise_Statement
(Finalizer_Data
));
6913 Make_Block_Statement
(Loc
,
6916 Handled_Statement_Sequence
=>
6917 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6919 end Build_Finalize_Statements
;
6921 -----------------------
6922 -- Parent_Field_Type --
6923 -----------------------
6925 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
6929 Field
:= First_Entity
(Typ
);
6930 while Present
(Field
) loop
6931 if Chars
(Field
) = Name_uParent
then
6932 return Etype
(Field
);
6935 Next_Entity
(Field
);
6938 -- A derived tagged type should always have a parent field
6940 raise Program_Error
;
6941 end Parent_Field_Type
;
6943 ---------------------------
6944 -- Preprocess_Components --
6945 ---------------------------
6947 procedure Preprocess_Components
6949 Num_Comps
: out Int
;
6950 Has_POC
: out Boolean)
6960 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6961 while Present
(Decl
) loop
6962 Id
:= Defining_Identifier
(Decl
);
6965 -- Skip field _parent
6967 if Chars
(Id
) /= Name_uParent
6968 and then Needs_Finalization
(Typ
)
6970 Num_Comps
:= Num_Comps
+ 1;
6972 if Has_Access_Constraint
(Id
)
6973 and then No
(Expression
(Decl
))
6979 Next_Non_Pragma
(Decl
);
6981 end Preprocess_Components
;
6983 -- Start of processing for Make_Deep_Record_Body
6987 when Address_Case
=>
6988 return Make_Finalize_Address_Stmts
(Typ
);
6991 return Build_Adjust_Statements
(Typ
);
6993 when Finalize_Case
=>
6994 return Build_Finalize_Statements
(Typ
);
6996 when Initialize_Case
=>
6998 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7001 if Is_Controlled
(Typ
) then
7003 Make_Procedure_Call_Statement
(Loc
,
7006 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7007 Parameter_Associations
=> New_List
(
7008 Make_Identifier
(Loc
, Name_V
))));
7014 end Make_Deep_Record_Body
;
7016 ----------------------
7017 -- Make_Final_Call --
7018 ----------------------
7020 function Make_Final_Call
7023 For_Parent
: Boolean := False) return Node_Id
7025 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7027 Fin_Id
: Entity_Id
:= Empty
;
7032 -- Recover the proper type which contains [Deep_]Finalize
7034 if Is_Class_Wide_Type
(Typ
) then
7035 Utyp
:= Root_Type
(Typ
);
7039 elsif Is_Concurrent_Type
(Typ
) then
7040 Utyp
:= Corresponding_Record_Type
(Typ
);
7042 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7044 elsif Is_Private_Type
(Typ
)
7045 and then Present
(Full_View
(Typ
))
7046 and then Is_Concurrent_Type
(Full_View
(Typ
))
7048 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7050 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7058 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7059 Set_Assignment_OK
(Ref
);
7061 -- Deal with non-tagged derivation of private views. If the parent type
7062 -- is a protected type, Deep_Finalize is found on the corresponding
7063 -- record of the ancestor.
7065 if Is_Untagged_Derivation
(Typ
) then
7066 if Is_Protected_Type
(Typ
) then
7067 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7069 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7071 if Is_Protected_Type
(Utyp
) then
7072 Utyp
:= Corresponding_Record_Type
(Utyp
);
7076 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7077 Set_Assignment_OK
(Ref
);
7080 -- Deal with derived private types which do not inherit primitives from
7081 -- their parents. In this case, [Deep_]Finalize can be found in the full
7082 -- view of the parent type.
7084 if Is_Tagged_Type
(Utyp
)
7085 and then Is_Derived_Type
(Utyp
)
7086 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7087 and then Is_Private_Type
(Etype
(Utyp
))
7088 and then Present
(Full_View
(Etype
(Utyp
)))
7090 Utyp
:= Full_View
(Etype
(Utyp
));
7091 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7092 Set_Assignment_OK
(Ref
);
7095 -- When dealing with the completion of a private type, use the base type
7098 if Utyp
/= Base_Type
(Utyp
) then
7099 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7101 Utyp
:= Base_Type
(Utyp
);
7102 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7103 Set_Assignment_OK
(Ref
);
7106 -- Select the appropriate version of Finalize
7109 if Has_Controlled_Component
(Utyp
) then
7110 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7113 -- Class-wide types, interfaces and types with controlled components
7115 elsif Is_Class_Wide_Type
(Typ
)
7116 or else Is_Interface
(Typ
)
7117 or else Has_Controlled_Component
(Utyp
)
7119 if Is_Tagged_Type
(Utyp
) then
7120 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7122 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7125 -- Derivations from [Limited_]Controlled
7127 elsif Is_Controlled
(Utyp
) then
7128 if Has_Controlled_Component
(Utyp
) then
7129 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7131 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7136 elsif Is_Tagged_Type
(Utyp
) then
7137 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7140 raise Program_Error
;
7143 if Present
(Fin_Id
) then
7145 -- When finalizing a class-wide object, do not convert to the root
7146 -- type in order to produce a dispatching call.
7148 if Is_Class_Wide_Type
(Typ
) then
7151 -- Ensure that a finalization routine is at least decorated in order
7152 -- to inspect the object parameter.
7154 elsif Analyzed
(Fin_Id
)
7155 or else Ekind
(Fin_Id
) = E_Procedure
7157 -- In certain cases, such as the creation of Stream_Read, the
7158 -- visible entity of the type is its full view. Since Stream_Read
7159 -- will have to create an object of type Typ, the local object
7160 -- will be finalzed by the scope finalizer generated later on. The
7161 -- object parameter of Deep_Finalize will always use the private
7162 -- view of the type. To avoid such a clash between a private and a
7163 -- full view, perform an unchecked conversion of the object
7164 -- reference to the private view.
7167 Formal_Typ
: constant Entity_Id
:=
7168 Etype
(First_Formal
(Fin_Id
));
7170 if Is_Private_Type
(Formal_Typ
)
7171 and then Present
(Full_View
(Formal_Typ
))
7172 and then Full_View
(Formal_Typ
) = Utyp
7174 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7178 Ref
:= Convert_View
(Fin_Id
, Ref
);
7181 return Make_Call
(Loc
, Fin_Id
, New_Copy_Tree
(Ref
), For_Parent
);
7185 end Make_Final_Call
;
7187 --------------------------------
7188 -- Make_Finalize_Address_Body --
7189 --------------------------------
7191 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7192 Is_Task
: constant Boolean :=
7193 Ekind
(Typ
) = E_Record_Type
7194 and then Is_Concurrent_Record_Type
(Typ
)
7195 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7197 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7198 Proc_Id
: Entity_Id
;
7202 -- The corresponding records of task types are not controlled by design.
7203 -- For the sake of completeness, create an empty Finalize_Address to be
7204 -- used in task class-wide allocations.
7209 -- Nothing to do if the type is not controlled or it already has a
7210 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7211 -- come from source. These are usually generated for completeness and
7212 -- do not need the Finalize_Address primitive.
7214 elsif not Needs_Finalization
(Typ
)
7215 or else Is_Abstract_Type
(Typ
)
7216 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7218 (Is_Class_Wide_Type
(Typ
)
7219 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7220 and then not Comes_From_Source
(Root_Type
(Typ
)))
7226 Make_Defining_Identifier
(Loc
,
7227 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7231 -- procedure <Typ>FD (V : System.Address) is
7233 -- null; -- for tasks
7235 -- declare -- for all other types
7236 -- type Pnn is access all Typ;
7237 -- for Pnn'Storage_Size use 0;
7239 -- [Deep_]Finalize (Pnn (V).all);
7244 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7246 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7250 Make_Subprogram_Body
(Loc
,
7252 Make_Procedure_Specification
(Loc
,
7253 Defining_Unit_Name
=> Proc_Id
,
7255 Parameter_Specifications
=> New_List
(
7256 Make_Parameter_Specification
(Loc
,
7257 Defining_Identifier
=>
7258 Make_Defining_Identifier
(Loc
, Name_V
),
7260 New_Reference_To
(RTE
(RE_Address
), Loc
)))),
7262 Declarations
=> No_List
,
7264 Handled_Statement_Sequence
=>
7265 Make_Handled_Sequence_Of_Statements
(Loc
,
7266 Statements
=> Stmts
)));
7268 Set_TSS
(Typ
, Proc_Id
);
7269 end Make_Finalize_Address_Body
;
7271 ---------------------------------
7272 -- Make_Finalize_Address_Stmts --
7273 ---------------------------------
7275 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7276 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7277 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7279 Desg_Typ
: Entity_Id
;
7283 if Is_Array_Type
(Typ
) then
7284 if Is_Constrained
(First_Subtype
(Typ
)) then
7285 Desg_Typ
:= First_Subtype
(Typ
);
7287 Desg_Typ
:= Base_Type
(Typ
);
7290 -- Class-wide types of constrained root types
7292 elsif Is_Class_Wide_Type
(Typ
)
7293 and then Has_Discriminants
(Root_Type
(Typ
))
7295 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7298 Parent_Typ
: Entity_Id
;
7301 -- Climb the parent type chain looking for a non-constrained type
7303 Parent_Typ
:= Root_Type
(Typ
);
7304 while Parent_Typ
/= Etype
(Parent_Typ
)
7305 and then Has_Discriminants
(Parent_Typ
)
7307 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7309 Parent_Typ
:= Etype
(Parent_Typ
);
7312 -- Handle views created for tagged types with unknown
7315 if Is_Underlying_Record_View
(Parent_Typ
) then
7316 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7319 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7329 -- type Ptr_Typ is access all Typ;
7330 -- for Ptr_Typ'Storage_Size use 0;
7333 Make_Full_Type_Declaration
(Loc
,
7334 Defining_Identifier
=> Ptr_Typ
,
7336 Make_Access_To_Object_Definition
(Loc
,
7337 All_Present
=> True,
7338 Subtype_Indication
=> New_Reference_To
(Desg_Typ
, Loc
))),
7340 Make_Attribute_Definition_Clause
(Loc
,
7341 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7342 Chars
=> Name_Storage_Size
,
7343 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7345 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7347 -- Unconstrained arrays require special processing in order to retrieve
7348 -- the elements. To achieve this, we have to skip the dope vector which
7349 -- lays in front of the elements and then use a thin pointer to perform
7350 -- the address-to-access conversion.
7352 if Is_Array_Type
(Typ
)
7353 and then not Is_Constrained
(First_Subtype
(Typ
))
7356 Dope_Id
: Entity_Id
;
7359 -- Ensure that Ptr_Typ a thin pointer, generate:
7360 -- for Ptr_Typ'Size use System.Address'Size;
7363 Make_Attribute_Definition_Clause
(Loc
,
7364 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7367 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7370 -- Dnn : constant Storage_Offset :=
7371 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7373 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7376 Make_Object_Declaration
(Loc
,
7377 Defining_Identifier
=> Dope_Id
,
7378 Constant_Present
=> True,
7379 Object_Definition
=>
7380 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
7382 Make_Op_Divide
(Loc
,
7384 Make_Attribute_Reference
(Loc
,
7385 Prefix
=> New_Reference_To
(Desg_Typ
, Loc
),
7386 Attribute_Name
=> Name_Descriptor_Size
),
7388 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7390 -- Shift the address from the start of the dope vector to the
7391 -- start of the elements:
7395 -- Note that this is done through a wrapper routine since RTSfind
7396 -- cannot retrieve operations with string names of the form "+".
7399 Make_Function_Call
(Loc
,
7401 New_Reference_To
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7402 Parameter_Associations
=> New_List
(
7404 New_Reference_To
(Dope_Id
, Loc
)));
7408 -- Create the block and the finalization call
7411 Make_Block_Statement
(Loc
,
7412 Declarations
=> Decls
,
7414 Handled_Statement_Sequence
=>
7415 Make_Handled_Sequence_Of_Statements
(Loc
,
7416 Statements
=> New_List
(
7419 Make_Explicit_Dereference
(Loc
,
7420 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7421 Typ
=> Desg_Typ
)))));
7422 end Make_Finalize_Address_Stmts
;
7424 -------------------------------------
7425 -- Make_Handler_For_Ctrl_Operation --
7426 -------------------------------------
7430 -- when E : others =>
7431 -- Raise_From_Controlled_Operation (E);
7436 -- raise Program_Error [finalize raised exception];
7438 -- depending on whether Raise_From_Controlled_Operation is available
7440 function Make_Handler_For_Ctrl_Operation
7441 (Loc
: Source_Ptr
) return Node_Id
7444 -- Choice parameter (for the first case above)
7446 Raise_Node
: Node_Id
;
7447 -- Procedure call or raise statement
7450 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7451 -- it to Raise_From_Controlled_Operation so that the original exception
7452 -- name and message can be recorded in the exception message for
7455 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7456 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7458 Make_Procedure_Call_Statement
(Loc
,
7461 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7462 Parameter_Associations
=> New_List
(
7463 New_Reference_To
(E_Occ
, Loc
)));
7465 -- Restricted run-time: exception messages are not supported
7470 Make_Raise_Program_Error
(Loc
,
7471 Reason
=> PE_Finalize_Raised_Exception
);
7475 Make_Implicit_Exception_Handler
(Loc
,
7476 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7477 Choice_Parameter
=> E_Occ
,
7478 Statements
=> New_List
(Raise_Node
));
7479 end Make_Handler_For_Ctrl_Operation
;
7481 --------------------
7482 -- Make_Init_Call --
7483 --------------------
7485 function Make_Init_Call
7487 Typ
: Entity_Id
) return Node_Id
7489 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7496 -- Deal with the type and object reference. Depending on the context, an
7497 -- object reference may need several conversions.
7499 if Is_Concurrent_Type
(Typ
) then
7501 Utyp
:= Corresponding_Record_Type
(Typ
);
7502 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7504 elsif Is_Private_Type
(Typ
)
7505 and then Present
(Full_View
(Typ
))
7506 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7509 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7510 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7518 Set_Assignment_OK
(Ref
);
7520 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7522 -- Deal with non-tagged derivation of private views
7524 if Is_Untagged_Derivation
(Typ
)
7525 and then not Is_Conc
7527 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7528 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7530 -- The following is to prevent problems with UC see 1.156 RH ???
7532 Set_Assignment_OK
(Ref
);
7535 -- If the underlying_type is a subtype, then we are dealing with the
7536 -- completion of a private type. We need to access the base type and
7537 -- generate a conversion to it.
7539 if Utyp
/= Base_Type
(Utyp
) then
7540 pragma Assert
(Is_Private_Type
(Typ
));
7541 Utyp
:= Base_Type
(Utyp
);
7542 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7545 -- Select the appropriate version of initialize
7547 if Has_Controlled_Component
(Utyp
) then
7548 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7550 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7551 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7554 -- The object reference may need another conversion depending on the
7555 -- type of the formal and that of the actual.
7557 Ref
:= Convert_View
(Proc
, Ref
);
7560 -- [Deep_]Initialize (Ref);
7563 Make_Procedure_Call_Statement
(Loc
,
7565 New_Reference_To
(Proc
, Loc
),
7566 Parameter_Associations
=> New_List
(Ref
));
7569 ------------------------------
7570 -- Make_Local_Deep_Finalize --
7571 ------------------------------
7573 function Make_Local_Deep_Finalize
7575 Nam
: Entity_Id
) return Node_Id
7577 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7581 Formals
:= New_List
(
7585 Make_Parameter_Specification
(Loc
,
7586 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7588 Out_Present
=> True,
7589 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7591 -- F : Boolean := True
7593 Make_Parameter_Specification
(Loc
,
7594 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7595 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
),
7596 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
7598 -- Add the necessary number of counters to represent the initialization
7599 -- state of an object.
7602 Make_Subprogram_Body
(Loc
,
7604 Make_Procedure_Specification
(Loc
,
7605 Defining_Unit_Name
=> Nam
,
7606 Parameter_Specifications
=> Formals
),
7608 Declarations
=> No_List
,
7610 Handled_Statement_Sequence
=>
7611 Make_Handled_Sequence_Of_Statements
(Loc
,
7612 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7613 end Make_Local_Deep_Finalize
;
7615 ------------------------------------
7616 -- Make_Set_Finalize_Address_Call --
7617 ------------------------------------
7619 function Make_Set_Finalize_Address_Call
7622 Ptr_Typ
: Entity_Id
) return Node_Id
7624 Desig_Typ
: constant Entity_Id
:=
7625 Available_View
(Designated_Type
(Ptr_Typ
));
7626 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7627 Fin_Mas_Ref
: Node_Id
;
7631 -- If the context is a class-wide allocator, we use the class-wide type
7632 -- to obtain the proper Finalize_Address routine.
7634 if Is_Class_Wide_Type
(Desig_Typ
) then
7640 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7641 Utyp
:= Full_View
(Utyp
);
7644 if Is_Concurrent_Type
(Utyp
) then
7645 Utyp
:= Corresponding_Record_Type
(Utyp
);
7649 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7651 -- Deal with non-tagged derivation of private views. If the parent is
7652 -- now known to be protected, the finalization routine is the one
7653 -- defined on the corresponding record of the ancestor (corresponding
7654 -- records do not automatically inherit operations, but maybe they
7657 if Is_Untagged_Derivation
(Typ
) then
7658 if Is_Protected_Type
(Typ
) then
7659 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7661 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7663 if Is_Protected_Type
(Utyp
) then
7664 Utyp
:= Corresponding_Record_Type
(Utyp
);
7669 -- If the underlying_type is a subtype, we are dealing with the
7670 -- completion of a private type. We need to access the base type and
7671 -- generate a conversion to it.
7673 if Utyp
/= Base_Type
(Utyp
) then
7674 pragma Assert
(Is_Private_Type
(Typ
));
7676 Utyp
:= Base_Type
(Utyp
);
7679 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7681 -- If the call is from a build-in-place function, the Master parameter
7682 -- is actually a pointer. Dereference it for the call.
7684 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7685 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7689 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7692 Make_Procedure_Call_Statement
(Loc
,
7694 New_Reference_To
(RTE
(RE_Set_Finalize_Address
), Loc
),
7695 Parameter_Associations
=> New_List
(
7697 Make_Attribute_Reference
(Loc
,
7699 New_Reference_To
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7700 Attribute_Name
=> Name_Unrestricted_Access
)));
7701 end Make_Set_Finalize_Address_Call
;
7703 --------------------------
7704 -- Make_Transient_Block --
7705 --------------------------
7707 function Make_Transient_Block
7710 Par
: Node_Id
) return Node_Id
7712 Decls
: constant List_Id
:= New_List
;
7713 Instrs
: constant List_Id
:= New_List
(Action
);
7718 -- Case where only secondary stack use is involved
7720 if VM_Target
= No_VM
7721 and then Uses_Sec_Stack
(Current_Scope
)
7722 and then Nkind
(Action
) /= N_Simple_Return_Statement
7723 and then Nkind
(Par
) /= N_Exception_Handler
7729 S
:= Scope
(Current_Scope
);
7731 -- At the outer level, no need to release the sec stack
7733 if S
= Standard_Standard
then
7734 Set_Uses_Sec_Stack
(Current_Scope
, False);
7737 -- In a function, only release the sec stack if the function
7738 -- does not return on the sec stack otherwise the result may
7739 -- be lost. The caller is responsible for releasing.
7741 elsif Ekind
(S
) = E_Function
then
7742 Set_Uses_Sec_Stack
(Current_Scope
, False);
7744 if not Requires_Transient_Scope
(Etype
(S
)) then
7745 Set_Uses_Sec_Stack
(S
, True);
7746 Check_Restriction
(No_Secondary_Stack
, Action
);
7751 -- In a loop or entry we should install a block encompassing
7752 -- all the construct. For now just release right away.
7754 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7757 -- In a procedure or a block, we release on exit of the
7758 -- procedure or block. ??? memory leak can be created by
7761 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7762 Set_Uses_Sec_Stack
(S
, True);
7763 Check_Restriction
(No_Secondary_Stack
, Action
);
7764 Set_Uses_Sec_Stack
(Current_Scope
, False);
7774 -- Create the transient block. Set the parent now since the block itself
7775 -- is not part of the tree.
7778 Make_Block_Statement
(Loc
,
7779 Identifier
=> New_Reference_To
(Current_Scope
, Loc
),
7780 Declarations
=> Decls
,
7781 Handled_Statement_Sequence
=>
7782 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7783 Has_Created_Identifier
=> True);
7784 Set_Parent
(Block
, Par
);
7786 -- Insert actions stuck in the transient scopes as well as all freezing
7787 -- nodes needed by those actions.
7789 Insert_Actions_In_Scope_Around
(Action
);
7791 Insert
:= Prev
(Action
);
7792 if Present
(Insert
) then
7793 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7796 -- When the transient scope was established, we pushed the entry for the
7797 -- transient scope onto the scope stack, so that the scope was active
7798 -- for the installation of finalizable entities etc. Now we must remove
7799 -- this entry, since we have constructed a proper block.
7804 end Make_Transient_Block
;
7806 ------------------------
7807 -- Node_To_Be_Wrapped --
7808 ------------------------
7810 function Node_To_Be_Wrapped
return Node_Id
is
7812 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7813 end Node_To_Be_Wrapped
;
7815 ----------------------------
7816 -- Set_Node_To_Be_Wrapped --
7817 ----------------------------
7819 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7821 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7822 end Set_Node_To_Be_Wrapped
;
7824 ----------------------------------
7825 -- Store_After_Actions_In_Scope --
7826 ----------------------------------
7828 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
7829 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7832 if Present
(SE
.Actions_To_Be_Wrapped_After
) then
7833 Insert_List_Before_And_Analyze
(
7834 First
(SE
.Actions_To_Be_Wrapped_After
), L
);
7837 SE
.Actions_To_Be_Wrapped_After
:= L
;
7839 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7840 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7842 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7847 end Store_After_Actions_In_Scope
;
7849 -----------------------------------
7850 -- Store_Before_Actions_In_Scope --
7851 -----------------------------------
7853 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
7854 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7857 if Present
(SE
.Actions_To_Be_Wrapped_Before
) then
7858 Insert_List_After_And_Analyze
(
7859 Last
(SE
.Actions_To_Be_Wrapped_Before
), L
);
7862 SE
.Actions_To_Be_Wrapped_Before
:= L
;
7864 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7865 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7867 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7872 end Store_Before_Actions_In_Scope
;
7874 --------------------------------
7875 -- Wrap_Transient_Declaration --
7876 --------------------------------
7878 -- If a transient scope has been established during the processing of the
7879 -- Expression of an Object_Declaration, it is not possible to wrap the
7880 -- declaration into a transient block as usual case, otherwise the object
7881 -- would be itself declared in the wrong scope. Therefore, all entities (if
7882 -- any) defined in the transient block are moved to the proper enclosing
7883 -- scope, furthermore, if they are controlled variables they are finalized
7884 -- right after the declaration. The finalization list of the transient
7885 -- scope is defined as a renaming of the enclosing one so during their
7886 -- initialization they will be attached to the proper finalization list.
7887 -- For instance, the following declaration :
7889 -- X : Typ := F (G (A), G (B));
7891 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7892 -- is expanded into :
7894 -- X : Typ := [ complex Expression-Action ];
7895 -- [Deep_]Finalize (_v1);
7896 -- [Deep_]Finalize (_v2);
7898 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
7905 Encl_S
:= Scope
(S
);
7907 -- Insert Actions kept in the Scope stack
7909 Insert_Actions_In_Scope_Around
(N
);
7911 -- If the declaration is consuming some secondary stack, mark the
7912 -- enclosing scope appropriately.
7914 Uses_SS
:= Uses_Sec_Stack
(S
);
7917 -- Put the local entities back in the enclosing scope, and set the
7918 -- Is_Public flag appropriately.
7920 Transfer_Entities
(S
, Encl_S
);
7922 -- Mark the enclosing dynamic scope so that the sec stack will be
7923 -- released upon its exit unless this is a function that returns on
7924 -- the sec stack in which case this will be done by the caller.
7926 if VM_Target
= No_VM
and then Uses_SS
then
7927 S
:= Enclosing_Dynamic_Scope
(S
);
7929 if Ekind
(S
) = E_Function
7930 and then Requires_Transient_Scope
(Etype
(S
))
7934 Set_Uses_Sec_Stack
(S
);
7935 Check_Restriction
(No_Secondary_Stack
, N
);
7938 end Wrap_Transient_Declaration
;
7940 -------------------------------
7941 -- Wrap_Transient_Expression --
7942 -------------------------------
7944 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
7945 Expr
: constant Node_Id
:= Relocate_Node
(N
);
7946 Loc
: constant Source_Ptr
:= Sloc
(N
);
7947 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
7948 Typ
: constant Entity_Id
:= Etype
(N
);
7955 -- M : constant Mark_Id := SS_Mark;
7956 -- procedure Finalizer is ... (See Build_Finalizer)
7965 Insert_Actions
(N
, New_List
(
7966 Make_Object_Declaration
(Loc
,
7967 Defining_Identifier
=> Temp
,
7968 Object_Definition
=> New_Reference_To
(Typ
, Loc
)),
7970 Make_Transient_Block
(Loc
,
7972 Make_Assignment_Statement
(Loc
,
7973 Name
=> New_Reference_To
(Temp
, Loc
),
7974 Expression
=> Expr
),
7975 Par
=> Parent
(N
))));
7977 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
7978 Analyze_And_Resolve
(N
, Typ
);
7979 end Wrap_Transient_Expression
;
7981 ------------------------------
7982 -- Wrap_Transient_Statement --
7983 ------------------------------
7985 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
7986 Loc
: constant Source_Ptr
:= Sloc
(N
);
7987 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
7992 -- M : constant Mark_Id := SS_Mark;
7993 -- procedure Finalizer is ... (See Build_Finalizer)
8003 Make_Transient_Block
(Loc
,
8005 Par
=> Parent
(N
)));
8007 -- With the scope stack back to normal, we can call analyze on the
8008 -- resulting block. At this point, the transient scope is being
8009 -- treated like a perfectly normal scope, so there is nothing
8010 -- special about it.
8012 -- Note: Wrap_Transient_Statement is called with the node already
8013 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8014 -- otherwise we would get a recursive processing of the node when
8015 -- we do this Analyze call.
8018 end Wrap_Transient_Statement
;