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, and 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 tack 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.
375 For_Parent
: Boolean := False) return Node_Id
;
376 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
377 -- routine [Deep_]Adjust / Finalize and an object parameter, create an
378 -- adjust / finalization call. Flag For_Parent should be set when field
379 -- _parent is being processed.
381 function Make_Deep_Proc
382 (Prim
: Final_Primitives
;
384 Stmts
: List_Id
) return Node_Id
;
385 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
386 -- Deep_Finalize procedures according to the first parameter, these
387 -- procedures operate on the type Typ. The Stmts parameter gives the body
390 function Make_Deep_Array_Body
391 (Prim
: Final_Primitives
;
392 Typ
: Entity_Id
) return List_Id
;
393 -- This function generates the list of statements for implementing
394 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
395 -- the first parameter, these procedures operate on the array type Typ.
397 function Make_Deep_Record_Body
398 (Prim
: Final_Primitives
;
400 Is_Local
: Boolean := False) return List_Id
;
401 -- This function generates the list of statements for implementing
402 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
403 -- the first parameter, these procedures operate on the record type Typ.
404 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
405 -- whether the inner logic should be dictated by state counters.
407 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
408 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
409 -- Make_Deep_Record_Body. Generate the following statements:
412 -- type Acc_Typ is access all Typ;
413 -- for Acc_Typ'Storage_Size use 0;
415 -- [Deep_]Finalize (Acc_Typ (V).all);
418 ----------------------------
419 -- Build_Array_Deep_Procs --
420 ----------------------------
422 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
426 (Prim
=> Initialize_Case
,
428 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
430 if not Is_Immutably_Limited_Type
(Typ
) then
433 (Prim
=> Adjust_Case
,
435 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
438 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
439 -- suppressed since these routine will not be used.
441 if not Restriction_Active
(No_Finalization
) then
444 (Prim
=> Finalize_Case
,
446 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
448 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
449 -- .NET do not support address arithmetic and unchecked conversions.
451 if VM_Target
= No_VM
then
454 (Prim
=> Address_Case
,
456 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
459 end Build_Array_Deep_Procs
;
461 ------------------------------
462 -- Build_Cleanup_Statements --
463 ------------------------------
465 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
is
466 Is_Asynchronous_Call
: constant Boolean :=
467 Nkind
(N
) = N_Block_Statement
468 and then Is_Asynchronous_Call_Block
(N
);
469 Is_Master
: constant Boolean :=
470 Nkind
(N
) /= N_Entry_Body
471 and then Is_Task_Master
(N
);
472 Is_Protected_Body
: constant Boolean :=
473 Nkind
(N
) = N_Subprogram_Body
474 and then Is_Protected_Subprogram_Body
(N
);
475 Is_Task_Allocation
: constant Boolean :=
476 Nkind
(N
) = N_Block_Statement
477 and then Is_Task_Allocation_Block
(N
);
478 Is_Task_Body
: constant Boolean :=
479 Nkind
(Original_Node
(N
)) = N_Task_Body
;
481 Loc
: constant Source_Ptr
:= Sloc
(N
);
482 Stmts
: constant List_Id
:= New_List
;
486 if Restricted_Profile
then
488 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
490 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
494 if Restriction_Active
(No_Task_Hierarchy
) = False then
495 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
498 -- Add statements to unlock the protected object parameter and to
499 -- undefer abort. If the context is a protected procedure and the object
500 -- has entries, call the entry service routine.
502 -- NOTE: The generated code references _object, a parameter to the
505 elsif Is_Protected_Body
then
507 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
508 Conc_Typ
: Entity_Id
;
511 Param_Typ
: Entity_Id
;
514 -- Find the _object parameter representing the protected object
516 Param
:= First
(Parameter_Specifications
(Spec
));
518 Param_Typ
:= Etype
(Parameter_Type
(Param
));
520 if Ekind
(Param_Typ
) = E_Record_Type
then
521 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
524 exit when No
(Param
) or else Present
(Conc_Typ
);
528 pragma Assert
(Present
(Param
));
530 -- If the associated protected object has entries, a protected
531 -- procedure has to service entry queues. In this case generate:
533 -- Service_Entries (_object._object'Access);
535 if Nkind
(Specification
(N
)) = N_Procedure_Specification
536 and then Has_Entries
(Conc_Typ
)
538 case Corresponding_Runtime_Package
(Conc_Typ
) is
539 when System_Tasking_Protected_Objects_Entries
=>
540 Nam
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
542 when System_Tasking_Protected_Objects_Single_Entry
=>
543 Nam
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
550 Make_Procedure_Call_Statement
(Loc
,
552 Parameter_Associations
=> New_List
(
553 Make_Attribute_Reference
(Loc
,
555 Make_Selected_Component
(Loc
,
556 Prefix
=> New_Reference_To
(
557 Defining_Identifier
(Param
), Loc
),
559 Make_Identifier
(Loc
, Name_uObject
)),
560 Attribute_Name
=> Name_Unchecked_Access
))));
564 -- Unlock (_object._object'Access);
566 case Corresponding_Runtime_Package
(Conc_Typ
) is
567 when System_Tasking_Protected_Objects_Entries
=>
568 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entries
), Loc
);
570 when System_Tasking_Protected_Objects_Single_Entry
=>
571 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entry
), Loc
);
573 when System_Tasking_Protected_Objects
=>
574 Nam
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
581 Make_Procedure_Call_Statement
(Loc
,
583 Parameter_Associations
=> New_List
(
584 Make_Attribute_Reference
(Loc
,
586 Make_Selected_Component
(Loc
,
589 (Defining_Identifier
(Param
), Loc
),
591 Make_Identifier
(Loc
, Name_uObject
)),
592 Attribute_Name
=> Name_Unchecked_Access
))));
598 if Abort_Allowed
then
600 Make_Procedure_Call_Statement
(Loc
,
602 New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
603 Parameter_Associations
=> Empty_List
));
607 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
608 -- tasks. Other unactivated tasks are completed by Complete_Task or
611 -- NOTE: The generated code references _chain, a local object
613 elsif Is_Task_Allocation
then
616 -- Expunge_Unactivated_Tasks (_chain);
618 -- where _chain is the list of tasks created by the allocator but not
619 -- yet activated. This list will be empty unless the block completes
623 Make_Procedure_Call_Statement
(Loc
,
626 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
627 Parameter_Associations
=> New_List
(
628 New_Reference_To
(Activation_Chain_Entity
(N
), Loc
))));
630 -- Attempt to cancel an asynchronous entry call whenever the block which
631 -- contains the abortable part is exited.
633 -- NOTE: The generated code references Cnn, a local object
635 elsif Is_Asynchronous_Call
then
637 Cancel_Param
: constant Entity_Id
:=
638 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
641 -- If it is of type Communication_Block, this must be a protected
642 -- entry call. Generate:
644 -- if Enqueued (Cancel_Param) then
645 -- Cancel_Protected_Entry_Call (Cancel_Param);
648 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
650 Make_If_Statement
(Loc
,
652 Make_Function_Call
(Loc
,
654 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
655 Parameter_Associations
=> New_List
(
656 New_Reference_To
(Cancel_Param
, Loc
))),
658 Then_Statements
=> New_List
(
659 Make_Procedure_Call_Statement
(Loc
,
662 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
663 Parameter_Associations
=> New_List
(
664 New_Reference_To
(Cancel_Param
, Loc
))))));
666 -- Asynchronous delay, generate:
667 -- Cancel_Async_Delay (Cancel_Param);
669 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
671 Make_Procedure_Call_Statement
(Loc
,
673 New_Reference_To
(RTE
(RE_Cancel_Async_Delay
), Loc
),
674 Parameter_Associations
=> New_List
(
675 Make_Attribute_Reference
(Loc
,
677 New_Reference_To
(Cancel_Param
, Loc
),
678 Attribute_Name
=> Name_Unchecked_Access
))));
680 -- Task entry call, generate:
681 -- Cancel_Task_Entry_Call (Cancel_Param);
685 Make_Procedure_Call_Statement
(Loc
,
687 New_Reference_To
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
688 Parameter_Associations
=> New_List
(
689 New_Reference_To
(Cancel_Param
, Loc
))));
695 end Build_Cleanup_Statements
;
697 -----------------------------
698 -- Build_Controlling_Procs --
699 -----------------------------
701 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
703 if Is_Array_Type
(Typ
) then
704 Build_Array_Deep_Procs
(Typ
);
705 else pragma Assert
(Is_Record_Type
(Typ
));
706 Build_Record_Deep_Procs
(Typ
);
708 end Build_Controlling_Procs
;
710 -----------------------------
711 -- Build_Exception_Handler --
712 -----------------------------
714 function Build_Exception_Handler
715 (Data
: Finalization_Exception_Data
;
716 For_Library
: Boolean := False) return Node_Id
719 Proc_To_Call
: Entity_Id
;
724 pragma Assert
(Present
(Data
.Raised_Id
));
726 if Exception_Extra_Info
727 or else (For_Library
and not Restricted_Profile
)
729 if Exception_Extra_Info
then
733 -- Get_Current_Excep.all
736 Make_Function_Call
(Data
.Loc
,
738 Make_Explicit_Dereference
(Data
.Loc
,
741 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
748 Except
:= Make_Null
(Data
.Loc
);
751 if For_Library
and then not Restricted_Profile
then
752 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
753 Actuals
:= New_List
(Except
);
756 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
758 -- The dereference occurs only when Exception_Extra_Info is true,
759 -- and therefore Except is not null.
763 New_Reference_To
(Data
.E_Id
, Data
.Loc
),
764 Make_Explicit_Dereference
(Data
.Loc
, Except
));
770 -- if not Raised_Id then
771 -- Raised_Id := True;
773 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
775 -- Save_Library_Occurrence (Get_Current_Excep.all);
780 Make_If_Statement
(Data
.Loc
,
782 Make_Op_Not
(Data
.Loc
,
783 Right_Opnd
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
)),
785 Then_Statements
=> New_List
(
786 Make_Assignment_Statement
(Data
.Loc
,
787 Name
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
788 Expression
=> New_Reference_To
(Standard_True
, Data
.Loc
)),
790 Make_Procedure_Call_Statement
(Data
.Loc
,
792 New_Reference_To
(Proc_To_Call
, Data
.Loc
),
793 Parameter_Associations
=> Actuals
))));
798 -- Raised_Id := True;
801 Make_Assignment_Statement
(Data
.Loc
,
802 Name
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
803 Expression
=> New_Reference_To
(Standard_True
, Data
.Loc
)));
811 Make_Exception_Handler
(Data
.Loc
,
812 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
813 Statements
=> Stmts
);
814 end Build_Exception_Handler
;
816 -------------------------------
817 -- Build_Finalization_Master --
818 -------------------------------
820 procedure Build_Finalization_Master
822 Ins_Node
: Node_Id
:= Empty
;
823 Encl_Scope
: Entity_Id
:= Empty
)
825 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
826 Ptr_Typ
: Entity_Id
:= Root_Type
(Base_Type
(Typ
));
828 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
829 -- Determine whether entity E is inside a wrapper package created for
830 -- an instance of Ada.Unchecked_Deallocation.
832 ------------------------------
833 -- In_Deallocation_Instance --
834 ------------------------------
836 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
837 Pkg
: constant Entity_Id
:= Scope
(E
);
838 Par
: Node_Id
:= Empty
;
841 if Ekind
(Pkg
) = E_Package
842 and then Present
(Related_Instance
(Pkg
))
843 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
845 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
849 and then Chars
(Par
) = Name_Unchecked_Deallocation
850 and then Chars
(Scope
(Par
)) = Name_Ada
851 and then Scope
(Scope
(Par
)) = Standard_Standard
;
855 end In_Deallocation_Instance
;
857 -- Start of processing for Build_Finalization_Master
860 if Is_Private_Type
(Ptr_Typ
)
861 and then Present
(Full_View
(Ptr_Typ
))
863 Ptr_Typ
:= Full_View
(Ptr_Typ
);
866 -- Certain run-time configurations and targets do not provide support
867 -- for controlled types.
869 if Restriction_Active
(No_Finalization
) then
872 -- Do not process C, C++, CIL and Java types since it is assumend that
873 -- the non-Ada side will handle their clean up.
875 elsif Convention
(Desig_Typ
) = Convention_C
876 or else Convention
(Desig_Typ
) = Convention_CIL
877 or else Convention
(Desig_Typ
) = Convention_CPP
878 or else Convention
(Desig_Typ
) = Convention_Java
882 -- Various machinery such as freezing may have already created a
883 -- finalization master.
885 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
888 -- Do not process types that return on the secondary stack
890 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
891 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
895 -- Do not process types which may never allocate an object
897 elsif No_Pool_Assigned
(Ptr_Typ
) then
900 -- Do not process access types coming from Ada.Unchecked_Deallocation
901 -- instances. Even though the designated type may be controlled, the
902 -- access type will never participate in allocation.
904 elsif In_Deallocation_Instance
(Ptr_Typ
) then
907 -- Ignore the general use of anonymous access types unless the context
908 -- requires a finalization master.
910 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
911 and then No
(Ins_Node
)
915 -- Do not process non-library access types when restriction No_Nested_
916 -- Finalization is in effect since masters are controlled objects.
918 elsif Restriction_Active
(No_Nested_Finalization
)
919 and then not Is_Library_Level_Entity
(Ptr_Typ
)
923 -- For .NET/JVM targets, allow the processing of access-to-controlled
924 -- types where the designated type is explicitly derived from [Limited_]
927 elsif VM_Target
/= No_VM
928 and then not Is_Controlled
(Desig_Typ
)
932 -- Do not create finalization masters in SPARK mode because they result
933 -- in unwanted expansion.
935 elsif SPARK_Mode
then
940 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
941 Actions
: constant List_Id
:= New_List
;
942 Fin_Mas_Id
: Entity_Id
;
947 -- Fnn : aliased Finalization_Master;
949 -- Source access types use fixed master names since the master is
950 -- inserted in the same source unit only once. The only exception to
951 -- this are instances using the same access type as generic actual.
953 if Comes_From_Source
(Ptr_Typ
)
954 and then not Inside_A_Generic
957 Make_Defining_Identifier
(Loc
,
958 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
960 -- Internally generated access types use temporaries as their names
961 -- due to possible collision with identical names coming from other
965 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
969 Make_Object_Declaration
(Loc
,
970 Defining_Identifier
=> Fin_Mas_Id
,
971 Aliased_Present
=> True,
973 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
)));
975 -- Storage pool selection and attribute decoration of the generated
976 -- master. Since .NET/JVM compilers do not support pools, this step
979 if VM_Target
= No_VM
then
981 -- If the access type has a user-defined pool, use it as the base
982 -- storage medium for the finalization pool.
984 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
985 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
987 -- The default choice is the global pool
990 Pool_Id
:= Get_Global_Pool_For_Access_Type
(Ptr_Typ
);
991 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
995 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
998 Make_Procedure_Call_Statement
(Loc
,
1000 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
1001 Parameter_Associations
=> New_List
(
1002 New_Reference_To
(Fin_Mas_Id
, Loc
),
1003 Make_Attribute_Reference
(Loc
,
1004 Prefix
=> New_Reference_To
(Pool_Id
, Loc
),
1005 Attribute_Name
=> Name_Unrestricted_Access
))));
1008 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1010 -- A finalization master created for an anonymous access type must be
1011 -- inserted before a context-dependent node.
1013 if Present
(Ins_Node
) then
1014 Push_Scope
(Encl_Scope
);
1016 -- Treat use clauses as declarations and insert directly in front
1019 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
1022 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
1024 Insert_Actions
(Ins_Node
, Actions
);
1029 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
1030 and then Has_Completion_In_Body
(Desig_Typ
)
1032 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1034 -- If the designated type is not yet frozen, then append the actions
1035 -- to that type's freeze actions. The actions need to be appended to
1036 -- whichever type is frozen later, similarly to what Freeze_Type does
1037 -- for appending the storage pool declaration for an access type.
1038 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
1039 -- pool object before it's declared. However, it's not clear that
1040 -- this is exactly the right test to accomplish that here. ???
1042 elsif Present
(Freeze_Node
(Desig_Typ
))
1043 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
1045 Append_Freeze_Actions
(Desig_Typ
, Actions
);
1047 elsif Present
(Freeze_Node
(Ptr_Typ
))
1048 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
1050 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1052 -- If there's a pool created locally for the access type, then we
1053 -- need to ensure that the master gets created after the pool object,
1054 -- because otherwise we can have a forward reference, so we force the
1055 -- master actions to be inserted and analyzed after the pool entity.
1056 -- Note that both the access type and its designated type may have
1057 -- already been frozen and had their freezing actions analyzed at
1058 -- this point. (This seems a little unclean.???)
1060 elsif VM_Target
= No_VM
1061 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1063 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1066 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1069 end Build_Finalization_Master
;
1071 ---------------------
1072 -- Build_Finalizer --
1073 ---------------------
1075 procedure Build_Finalizer
1077 Clean_Stmts
: List_Id
;
1078 Mark_Id
: Entity_Id
;
1079 Top_Decls
: List_Id
;
1080 Defer_Abort
: Boolean;
1081 Fin_Id
: out Entity_Id
)
1083 Acts_As_Clean
: constant Boolean :=
1086 (Present
(Clean_Stmts
)
1087 and then Is_Non_Empty_List
(Clean_Stmts
));
1088 Exceptions_OK
: constant Boolean :=
1089 not Restriction_Active
(No_Exception_Propagation
);
1090 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1091 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1092 For_Package
: constant Boolean :=
1093 For_Package_Body
or else For_Package_Spec
;
1094 Loc
: constant Source_Ptr
:= Sloc
(N
);
1096 -- NOTE: Local variable declarations are conservative and do not create
1097 -- structures right from the start. Entities and lists are created once
1098 -- it has been established that N has at least one controlled object.
1100 Components_Built
: Boolean := False;
1101 -- A flag used to avoid double initialization of entities and lists. If
1102 -- the flag is set then the following variables have been initialized:
1108 Counter_Id
: Entity_Id
:= Empty
;
1109 Counter_Val
: Int
:= 0;
1110 -- Name and value of the state counter
1112 Decls
: List_Id
:= No_List
;
1113 -- Declarative region of N (if available). If N is a package declaration
1114 -- Decls denotes the visible declarations.
1116 Finalizer_Data
: Finalization_Exception_Data
;
1117 -- Data for the exception
1119 Finalizer_Decls
: List_Id
:= No_List
;
1120 -- Local variable declarations. This list holds the label declarations
1121 -- of all jump block alternatives as well as the declaration of the
1122 -- local exception occurence and the raised flag:
1123 -- E : Exception_Occurrence;
1124 -- Raised : Boolean := False;
1125 -- L<counter value> : label;
1127 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1128 -- Insertion point for the finalizer body. Depending on the context
1129 -- (Nkind of N) and the individual grouping of controlled objects, this
1130 -- node may denote a package declaration or body, package instantiation,
1131 -- block statement or a counter update statement.
1133 Finalizer_Stmts
: List_Id
:= No_List
;
1134 -- The statement list of the finalizer body. It contains the following:
1136 -- Abort_Defer; -- Added if abort is allowed
1137 -- <call to Prev_At_End> -- Added if exists
1138 -- <cleanup statements> -- Added if Acts_As_Clean
1139 -- <jump block> -- Added if Has_Ctrl_Objs
1140 -- <finalization statements> -- Added if Has_Ctrl_Objs
1141 -- <stack release> -- Added if Mark_Id exists
1142 -- Abort_Undefer; -- Added if abort is allowed
1144 Has_Ctrl_Objs
: Boolean := False;
1145 -- A general flag which denotes whether N has at least one controlled
1148 Has_Tagged_Types
: Boolean := False;
1149 -- A general flag which indicates whether N has at least one library-
1150 -- level tagged type declaration.
1152 HSS
: Node_Id
:= Empty
;
1153 -- The sequence of statements of N (if available)
1155 Jump_Alts
: List_Id
:= No_List
;
1156 -- Jump block alternatives. Depending on the value of the state counter,
1157 -- the control flow jumps to a sequence of finalization statements. This
1158 -- list contains the following:
1160 -- when <counter value> =>
1161 -- goto L<counter value>;
1163 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1164 -- Specific point in the finalizer statements where the jump block is
1167 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1168 -- The last controlled construct encountered when processing the top
1169 -- level lists of N. This can be a nested package, an instantiation or
1170 -- an object declaration.
1172 Prev_At_End
: Entity_Id
:= Empty
;
1173 -- The previous at end procedure of the handled statements block of N
1175 Priv_Decls
: List_Id
:= No_List
;
1176 -- The private declarations of N if N is a package declaration
1178 Spec_Id
: Entity_Id
:= Empty
;
1179 Spec_Decls
: List_Id
:= Top_Decls
;
1180 Stmts
: List_Id
:= No_List
;
1182 Tagged_Type_Stmts
: List_Id
:= No_List
;
1183 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1184 -- tagged types found in N.
1186 -----------------------
1187 -- Local subprograms --
1188 -----------------------
1190 procedure Build_Components
;
1191 -- Create all entites and initialize all lists used in the creation of
1194 procedure Create_Finalizer
;
1195 -- Create the spec and body of the finalizer and insert them in the
1196 -- proper place in the tree depending on the context.
1198 procedure Process_Declarations
1200 Preprocess
: Boolean := False;
1201 Top_Level
: Boolean := False);
1202 -- Inspect a list of declarations or statements which may contain
1203 -- objects that need finalization. When flag Preprocess is set, the
1204 -- routine will simply count the total number of controlled objects in
1205 -- Decls. Flag Top_Level denotes whether the processing is done for
1206 -- objects in nested package declarations or instances.
1208 procedure Process_Object_Declaration
1210 Has_No_Init
: Boolean := False;
1211 Is_Protected
: Boolean := False);
1212 -- Generate all the machinery associated with the finalization of a
1213 -- single object. Flag Has_No_Init is used to denote certain contexts
1214 -- where Decl does not have initialization call(s). Flag Is_Protected
1215 -- is set when Decl denotes a simple protected object.
1217 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1218 -- Generate all the code necessary to unregister the external tag of a
1221 ----------------------
1222 -- Build_Components --
1223 ----------------------
1225 procedure Build_Components
is
1226 Counter_Decl
: Node_Id
;
1227 Counter_Typ
: Entity_Id
;
1228 Counter_Typ_Decl
: Node_Id
;
1231 pragma Assert
(Present
(Decls
));
1233 -- This routine might be invoked several times when dealing with
1234 -- constructs that have two lists (either two declarative regions
1235 -- or declarations and statements). Avoid double initialization.
1237 if Components_Built
then
1241 Components_Built
:= True;
1243 if Has_Ctrl_Objs
then
1245 -- Create entities for the counter, its type, the local exception
1246 -- and the raised flag.
1248 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1249 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1251 Finalizer_Decls
:= New_List
;
1253 Build_Object_Declarations
1254 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1256 -- Since the total number of controlled objects is always known,
1257 -- build a subtype of Natural with precise bounds. This allows
1258 -- the backend to optimize the case statement. Generate:
1260 -- subtype Tnn is Natural range 0 .. Counter_Val;
1263 Make_Subtype_Declaration
(Loc
,
1264 Defining_Identifier
=> Counter_Typ
,
1265 Subtype_Indication
=>
1266 Make_Subtype_Indication
(Loc
,
1267 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
1269 Make_Range_Constraint
(Loc
,
1273 Make_Integer_Literal
(Loc
, Uint_0
),
1275 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1277 -- Generate the declaration of the counter itself:
1279 -- Counter : Integer := 0;
1282 Make_Object_Declaration
(Loc
,
1283 Defining_Identifier
=> Counter_Id
,
1284 Object_Definition
=> New_Reference_To
(Counter_Typ
, Loc
),
1285 Expression
=> Make_Integer_Literal
(Loc
, 0));
1287 -- Set the type of the counter explicitly to prevent errors when
1288 -- examining object declarations later on.
1290 Set_Etype
(Counter_Id
, Counter_Typ
);
1292 -- The counter and its type are inserted before the source
1293 -- declarations of N.
1295 Prepend_To
(Decls
, Counter_Decl
);
1296 Prepend_To
(Decls
, Counter_Typ_Decl
);
1298 -- The counter and its associated type must be manually analized
1299 -- since N has already been analyzed. Use the scope of the spec
1300 -- when inserting in a package.
1303 Push_Scope
(Spec_Id
);
1304 Analyze
(Counter_Typ_Decl
);
1305 Analyze
(Counter_Decl
);
1309 Analyze
(Counter_Typ_Decl
);
1310 Analyze
(Counter_Decl
);
1313 Jump_Alts
:= New_List
;
1316 -- If the context requires additional clean up, the finalization
1317 -- machinery is added after the clean up code.
1319 if Acts_As_Clean
then
1320 Finalizer_Stmts
:= Clean_Stmts
;
1321 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1323 Finalizer_Stmts
:= New_List
;
1326 if Has_Tagged_Types
then
1327 Tagged_Type_Stmts
:= New_List
;
1329 end Build_Components
;
1331 ----------------------
1332 -- Create_Finalizer --
1333 ----------------------
1335 procedure Create_Finalizer
is
1336 Body_Id
: Entity_Id
;
1339 Jump_Block
: Node_Id
;
1341 Label_Id
: Entity_Id
;
1343 function New_Finalizer_Name
return Name_Id
;
1344 -- Create a fully qualified name of a package spec or body finalizer.
1345 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1347 ------------------------
1348 -- New_Finalizer_Name --
1349 ------------------------
1351 function New_Finalizer_Name
return Name_Id
is
1352 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1353 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1354 -- has a non-standard scope, process the scope first.
1356 ------------------------
1357 -- New_Finalizer_Name --
1358 ------------------------
1360 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1362 if Scope
(Id
) = Standard_Standard
then
1363 Get_Name_String
(Chars
(Id
));
1366 New_Finalizer_Name
(Scope
(Id
));
1367 Add_Str_To_Name_Buffer
("__");
1368 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1370 end New_Finalizer_Name
;
1372 -- Start of processing for New_Finalizer_Name
1375 -- Create the fully qualified name of the enclosing scope
1377 New_Finalizer_Name
(Spec_Id
);
1380 -- __finalize_[spec|body]
1382 Add_Str_To_Name_Buffer
("__finalize_");
1384 if For_Package_Spec
then
1385 Add_Str_To_Name_Buffer
("spec");
1387 Add_Str_To_Name_Buffer
("body");
1391 end New_Finalizer_Name
;
1393 -- Start of processing for Create_Finalizer
1396 -- Step 1: Creation of the finalizer name
1398 -- Packages must use a distinct name for their finalizers since the
1399 -- binder will have to generate calls to them by name. The name is
1400 -- of the following form:
1402 -- xx__yy__finalize_[spec|body]
1405 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1406 Set_Has_Qualified_Name
(Fin_Id
);
1407 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1409 -- The default name is _finalizer
1413 Make_Defining_Identifier
(Loc
,
1414 Chars
=> New_External_Name
(Name_uFinalizer
));
1416 -- The visibility semantics of AT_END handlers force a strange
1417 -- separation of spec and body for stack-related finalizers:
1419 -- declare : Enclosing_Scope
1420 -- procedure _finalizer;
1422 -- <controlled objects>
1423 -- procedure _finalizer is
1429 -- Both spec and body are within the same construct and scope, but
1430 -- the body is part of the handled sequence of statements. This
1431 -- placement confuses the elaboration mechanism on targets where
1432 -- AT_END handlers are expanded into "when all others" handlers:
1435 -- when all others =>
1436 -- _finalizer; -- appears to require elab checks
1441 -- Since the compiler guarantees that the body of a _finalizer is
1442 -- always inserted in the same construct where the AT_END handler
1443 -- resides, there is no need for elaboration checks.
1445 Set_Kill_Elaboration_Checks
(Fin_Id
);
1448 -- Step 2: Creation of the finalizer specification
1451 -- procedure Fin_Id;
1454 Make_Subprogram_Declaration
(Loc
,
1456 Make_Procedure_Specification
(Loc
,
1457 Defining_Unit_Name
=> Fin_Id
));
1459 -- Step 3: Creation of the finalizer body
1461 if Has_Ctrl_Objs
then
1463 -- Add L0, the default destination to the jump block
1465 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1466 Set_Entity
(Label_Id
,
1467 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1468 Label
:= Make_Label
(Loc
, Label_Id
);
1473 Prepend_To
(Finalizer_Decls
,
1474 Make_Implicit_Label_Declaration
(Loc
,
1475 Defining_Identifier
=> Entity
(Label_Id
),
1476 Label_Construct
=> Label
));
1482 Append_To
(Jump_Alts
,
1483 Make_Case_Statement_Alternative
(Loc
,
1484 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1485 Statements
=> New_List
(
1486 Make_Goto_Statement
(Loc
,
1487 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
1492 Append_To
(Finalizer_Stmts
, Label
);
1494 -- Create the jump block which controls the finalization flow
1495 -- depending on the value of the state counter.
1498 Make_Case_Statement
(Loc
,
1499 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1500 Alternatives
=> Jump_Alts
);
1503 and then Present
(Jump_Block_Insert_Nod
)
1505 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1507 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1511 -- Add the library-level tagged type unregistration machinery before
1512 -- the jump block circuitry. This ensures that external tags will be
1513 -- removed even if a finalization exception occurs at some point.
1515 if Has_Tagged_Types
then
1516 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1519 -- Add a call to the previous At_End handler if it exists. The call
1520 -- must always precede the jump block.
1522 if Present
(Prev_At_End
) then
1523 Prepend_To
(Finalizer_Stmts
,
1524 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1526 -- Clear the At_End handler since we have already generated the
1527 -- proper replacement call for it.
1529 Set_At_End_Proc
(HSS
, Empty
);
1532 -- Release the secondary stack mark
1534 if Present
(Mark_Id
) then
1535 Append_To
(Finalizer_Stmts
,
1536 Make_Procedure_Call_Statement
(Loc
,
1538 New_Reference_To
(RTE
(RE_SS_Release
), Loc
),
1539 Parameter_Associations
=> New_List
(
1540 New_Reference_To
(Mark_Id
, Loc
))));
1543 -- Protect the statements with abort defer/undefer. This is only when
1544 -- aborts are allowed and the clean up statements require deferral or
1545 -- there are controlled objects to be finalized.
1549 (Defer_Abort
or else Has_Ctrl_Objs
)
1551 Prepend_To
(Finalizer_Stmts
,
1552 Make_Procedure_Call_Statement
(Loc
,
1553 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
)));
1555 Append_To
(Finalizer_Stmts
,
1556 Make_Procedure_Call_Statement
(Loc
,
1557 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
1560 -- The local exception does not need to be reraised for library-level
1561 -- finalizers. Note that this action must be carried out after object
1562 -- clean up, secondary stack release and abort undeferral. Generate:
1564 -- if Raised and then not Abort then
1565 -- Raise_From_Controlled_Operation (E);
1569 and then Exceptions_OK
1570 and then not For_Package
1572 Append_To
(Finalizer_Stmts
,
1573 Build_Raise_Statement
(Finalizer_Data
));
1577 -- procedure Fin_Id is
1578 -- Abort : constant Boolean := Triggered_By_Abort;
1580 -- Abort : constant Boolean := False; -- no abort
1582 -- E : Exception_Occurrence; -- All added if flag
1583 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1589 -- Abort_Defer; -- Added if abort is allowed
1590 -- <call to Prev_At_End> -- Added if exists
1591 -- <cleanup statements> -- Added if Acts_As_Clean
1592 -- <jump block> -- Added if Has_Ctrl_Objs
1593 -- <finalization statements> -- Added if Has_Ctrl_Objs
1594 -- <stack release> -- Added if Mark_Id exists
1595 -- Abort_Undefer; -- Added if abort is allowed
1596 -- <exception propagation> -- Added if Has_Ctrl_Objs
1599 -- Create the body of the finalizer
1601 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1604 Set_Has_Qualified_Name
(Body_Id
);
1605 Set_Has_Fully_Qualified_Name
(Body_Id
);
1609 Make_Subprogram_Body
(Loc
,
1611 Make_Procedure_Specification
(Loc
,
1612 Defining_Unit_Name
=> Body_Id
),
1613 Declarations
=> Finalizer_Decls
,
1614 Handled_Statement_Sequence
=>
1615 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1617 -- Step 4: Spec and body insertion, analysis
1621 -- If the package spec has private declarations, the finalizer
1622 -- body must be added to the end of the list in order to have
1623 -- visibility of all private controlled objects.
1625 if For_Package_Spec
then
1626 if Present
(Priv_Decls
) then
1627 Append_To
(Priv_Decls
, Fin_Spec
);
1628 Append_To
(Priv_Decls
, Fin_Body
);
1630 Append_To
(Decls
, Fin_Spec
);
1631 Append_To
(Decls
, Fin_Body
);
1634 -- For package bodies, both the finalizer spec and body are
1635 -- inserted at the end of the package declarations.
1638 Append_To
(Decls
, Fin_Spec
);
1639 Append_To
(Decls
, Fin_Body
);
1642 -- Push the name of the package
1644 Push_Scope
(Spec_Id
);
1652 -- Create the spec for the finalizer. The At_End handler must be
1653 -- able to call the body which resides in a nested structure.
1657 -- procedure Fin_Id; -- Spec
1659 -- <objects and possibly statements>
1660 -- procedure Fin_Id is ... -- Body
1663 -- Fin_Id; -- At_End handler
1666 pragma Assert
(Present
(Spec_Decls
));
1668 Append_To
(Spec_Decls
, Fin_Spec
);
1671 -- When the finalizer acts solely as a clean up routine, the body
1672 -- is inserted right after the spec.
1675 and then not Has_Ctrl_Objs
1677 Insert_After
(Fin_Spec
, Fin_Body
);
1679 -- In all other cases the body is inserted after either:
1681 -- 1) The counter update statement of the last controlled object
1682 -- 2) The last top level nested controlled package
1683 -- 3) The last top level controlled instantiation
1686 -- Manually freeze the spec. This is somewhat of a hack because
1687 -- a subprogram is frozen when its body is seen and the freeze
1688 -- node appears right before the body. However, in this case,
1689 -- the spec must be frozen earlier since the At_End handler
1690 -- must be able to call it.
1693 -- procedure Fin_Id; -- Spec
1694 -- [Fin_Id] -- Freeze node
1698 -- Fin_Id; -- At_End handler
1701 Ensure_Freeze_Node
(Fin_Id
);
1702 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1703 Set_Is_Frozen
(Fin_Id
);
1705 -- In the case where the last construct to contain a controlled
1706 -- object is either a nested package, an instantiation or a
1707 -- freeze node, the body must be inserted directly after the
1710 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1712 N_Package_Declaration
,
1715 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1718 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1723 end Create_Finalizer
;
1725 --------------------------
1726 -- Process_Declarations --
1727 --------------------------
1729 procedure Process_Declarations
1731 Preprocess
: Boolean := False;
1732 Top_Level
: Boolean := False)
1737 Obj_Typ
: Entity_Id
;
1738 Pack_Id
: Entity_Id
;
1742 Old_Counter_Val
: Int
;
1743 -- This variable is used to determine whether a nested package or
1744 -- instance contains at least one controlled object.
1746 procedure Processing_Actions
1747 (Has_No_Init
: Boolean := False;
1748 Is_Protected
: Boolean := False);
1749 -- Depending on the mode of operation of Process_Declarations, either
1750 -- increment the controlled object counter, set the controlled object
1751 -- flag and store the last top level construct or process the current
1752 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1753 -- the current declaration may not have initialization proc(s). Flag
1754 -- Is_Protected should be set when the current declaration denotes a
1755 -- simple protected object.
1757 ------------------------
1758 -- Processing_Actions --
1759 ------------------------
1761 procedure Processing_Actions
1762 (Has_No_Init
: Boolean := False;
1763 Is_Protected
: Boolean := False)
1766 -- Library-level tagged type
1768 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1770 Has_Tagged_Types
:= True;
1773 and then No
(Last_Top_Level_Ctrl_Construct
)
1775 Last_Top_Level_Ctrl_Construct
:= Decl
;
1779 Process_Tagged_Type_Declaration
(Decl
);
1782 -- Controlled object declaration
1786 Counter_Val
:= Counter_Val
+ 1;
1787 Has_Ctrl_Objs
:= True;
1790 and then No
(Last_Top_Level_Ctrl_Construct
)
1792 Last_Top_Level_Ctrl_Construct
:= Decl
;
1796 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1799 end Processing_Actions
;
1801 -- Start of processing for Process_Declarations
1804 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1808 -- Process all declarations in reverse order
1810 Decl
:= Last_Non_Pragma
(Decls
);
1811 while Present
(Decl
) loop
1813 -- Library-level tagged types
1815 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1816 Typ
:= Defining_Identifier
(Decl
);
1818 if Is_Tagged_Type
(Typ
)
1819 and then Is_Library_Level_Entity
(Typ
)
1820 and then Convention
(Typ
) = Convention_Ada
1821 and then Present
(Access_Disp_Table
(Typ
))
1822 and then RTE_Available
(RE_Register_Tag
)
1823 and then not No_Run_Time_Mode
1824 and then not Is_Abstract_Type
(Typ
)
1829 -- Regular object declarations
1831 elsif Nkind
(Decl
) = N_Object_Declaration
then
1832 Obj_Id
:= Defining_Identifier
(Decl
);
1833 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1834 Expr
:= Expression
(Decl
);
1836 -- Bypass any form of processing for objects which have their
1837 -- finalization disabled. This applies only to objects at the
1841 and then Finalize_Storage_Only
(Obj_Typ
)
1845 -- Transient variables are treated separately in order to
1846 -- minimize the size of the generated code. For details, see
1847 -- Process_Transient_Objects.
1849 elsif Is_Processed_Transient
(Obj_Id
) then
1852 -- The object is of the form:
1853 -- Obj : Typ [:= Expr];
1855 -- Do not process the incomplete view of a deferred constant.
1856 -- Do not consider tag-to-class-wide conversions.
1858 elsif not Is_Imported
(Obj_Id
)
1859 and then Needs_Finalization
(Obj_Typ
)
1860 and then not (Ekind
(Obj_Id
) = E_Constant
1861 and then not Has_Completion
(Obj_Id
))
1862 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1866 -- The object is of the form:
1867 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1869 -- Obj : Access_Typ :=
1870 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1872 elsif Is_Access_Type
(Obj_Typ
)
1873 and then Needs_Finalization
1874 (Available_View
(Designated_Type
(Obj_Typ
)))
1875 and then Present
(Expr
)
1877 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1879 (Is_Non_BIP_Func_Call
(Expr
)
1880 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1882 Processing_Actions
(Has_No_Init
=> True);
1884 -- Processing for "hook" objects generated for controlled
1885 -- transients declared inside an Expression_With_Actions.
1887 elsif Is_Access_Type
(Obj_Typ
)
1888 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1889 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1890 N_Object_Declaration
1891 and then Is_Finalizable_Transient
1892 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Decl
)
1894 Processing_Actions
(Has_No_Init
=> True);
1896 -- Process intermediate results of an if expression with one
1897 -- of the alternatives using a controlled function call.
1899 elsif Is_Access_Type
(Obj_Typ
)
1900 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1901 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1902 N_Defining_Identifier
1903 and then Present
(Expr
)
1904 and then Nkind
(Expr
) = N_Null
1906 Processing_Actions
(Has_No_Init
=> True);
1908 -- Simple protected objects which use type System.Tasking.
1909 -- Protected_Objects.Protection to manage their locks should
1910 -- be treated as controlled since they require manual cleanup.
1911 -- The only exception is illustrated in the following example:
1914 -- type Ctrl is new Controlled ...
1915 -- procedure Finalize (Obj : in out Ctrl);
1919 -- package body Pkg is
1920 -- protected Prot is
1921 -- procedure Do_Something (Obj : in out Ctrl);
1924 -- protected body Prot is
1925 -- procedure Do_Something (Obj : in out Ctrl) is ...
1928 -- procedure Finalize (Obj : in out Ctrl) is
1930 -- Prot.Do_Something (Obj);
1934 -- Since for the most part entities in package bodies depend on
1935 -- those in package specs, Prot's lock should be cleaned up
1936 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1937 -- This act however attempts to invoke Do_Something and fails
1938 -- because the lock has disappeared.
1940 elsif Ekind
(Obj_Id
) = E_Variable
1941 and then not In_Library_Level_Package_Body
(Obj_Id
)
1943 (Is_Simple_Protected_Type
(Obj_Typ
)
1944 or else Has_Simple_Protected_Object
(Obj_Typ
))
1946 Processing_Actions
(Is_Protected
=> True);
1949 -- Specific cases of object renamings
1951 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1952 Obj_Id
:= Defining_Identifier
(Decl
);
1953 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1955 -- Bypass any form of processing for objects which have their
1956 -- finalization disabled. This applies only to objects at the
1960 and then Finalize_Storage_Only
(Obj_Typ
)
1964 -- Return object of a build-in-place function. This case is
1965 -- recognized and marked by the expansion of an extended return
1966 -- statement (see Expand_N_Extended_Return_Statement).
1968 elsif Needs_Finalization
(Obj_Typ
)
1969 and then Is_Return_Object
(Obj_Id
)
1970 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1972 Processing_Actions
(Has_No_Init
=> True);
1974 -- Detect a case where a source object has been initialized by
1975 -- a controlled function call or another object which was later
1976 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1978 -- Obj1 : CW_Type := Src_Obj;
1979 -- Obj2 : CW_Type := Function_Call (...);
1981 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1982 -- Tmp : ... := Function_Call (...)'reference;
1983 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1985 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1986 Processing_Actions
(Has_No_Init
=> True);
1989 -- Inspect the freeze node of an access-to-controlled type and
1990 -- look for a delayed finalization master. This case arises when
1991 -- the freeze actions are inserted at a later time than the
1992 -- expansion of the context. Since Build_Finalizer is never called
1993 -- on a single construct twice, the master will be ultimately
1994 -- left out and never finalized. This is also needed for freeze
1995 -- actions of designated types themselves, since in some cases the
1996 -- finalization master is associated with a designated type's
1997 -- freeze node rather than that of the access type (see handling
1998 -- for freeze actions in Build_Finalization_Master).
2000 elsif Nkind
(Decl
) = N_Freeze_Entity
2001 and then Present
(Actions
(Decl
))
2003 Typ
:= Entity
(Decl
);
2005 if (Is_Access_Type
(Typ
)
2006 and then not Is_Access_Subprogram_Type
(Typ
)
2007 and then Needs_Finalization
2008 (Available_View
(Designated_Type
(Typ
))))
2009 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2011 Old_Counter_Val
:= Counter_Val
;
2013 -- Freeze nodes are considered to be identical to packages
2014 -- and blocks in terms of nesting. The difference is that
2015 -- a finalization master created inside the freeze node is
2016 -- at the same nesting level as the node itself.
2018 Process_Declarations
(Actions
(Decl
), Preprocess
);
2020 -- The freeze node contains a finalization master
2024 and then No
(Last_Top_Level_Ctrl_Construct
)
2025 and then Counter_Val
> Old_Counter_Val
2027 Last_Top_Level_Ctrl_Construct
:= Decl
;
2031 -- Nested package declarations, avoid generics
2033 elsif Nkind
(Decl
) = N_Package_Declaration
then
2034 Spec
:= Specification
(Decl
);
2035 Pack_Id
:= Defining_Unit_Name
(Spec
);
2037 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
2038 Pack_Id
:= Defining_Identifier
(Pack_Id
);
2041 if Ekind
(Pack_Id
) /= E_Generic_Package
then
2042 Old_Counter_Val
:= Counter_Val
;
2043 Process_Declarations
2044 (Private_Declarations
(Spec
), Preprocess
);
2045 Process_Declarations
2046 (Visible_Declarations
(Spec
), Preprocess
);
2048 -- Either the visible or the private declarations contain a
2049 -- controlled object. The nested package declaration is the
2050 -- last such construct.
2054 and then No
(Last_Top_Level_Ctrl_Construct
)
2055 and then Counter_Val
> Old_Counter_Val
2057 Last_Top_Level_Ctrl_Construct
:= Decl
;
2061 -- Nested package bodies, avoid generics
2063 elsif Nkind
(Decl
) = N_Package_Body
then
2064 Spec
:= Corresponding_Spec
(Decl
);
2066 if Ekind
(Spec
) /= E_Generic_Package
then
2067 Old_Counter_Val
:= Counter_Val
;
2068 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2070 -- The nested package body is the last construct to contain
2071 -- a controlled object.
2075 and then No
(Last_Top_Level_Ctrl_Construct
)
2076 and then Counter_Val
> Old_Counter_Val
2078 Last_Top_Level_Ctrl_Construct
:= Decl
;
2082 -- Handle a rare case caused by a controlled transient variable
2083 -- created as part of a record init proc. The variable is wrapped
2084 -- in a block, but the block is not associated with a transient
2087 elsif Nkind
(Decl
) = N_Block_Statement
2088 and then Inside_Init_Proc
2090 Old_Counter_Val
:= Counter_Val
;
2092 if Present
(Handled_Statement_Sequence
(Decl
)) then
2093 Process_Declarations
2094 (Statements
(Handled_Statement_Sequence
(Decl
)),
2098 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2100 -- Either the declaration or statement list of the block has a
2101 -- controlled object.
2105 and then No
(Last_Top_Level_Ctrl_Construct
)
2106 and then Counter_Val
> Old_Counter_Val
2108 Last_Top_Level_Ctrl_Construct
:= Decl
;
2111 -- Handle the case where the original context has been wrapped in
2112 -- a block to avoid interference between exception handlers and
2113 -- At_End handlers. Treat the block as transparent and process its
2116 elsif Nkind
(Decl
) = N_Block_Statement
2117 and then Is_Finalization_Wrapper
(Decl
)
2119 if Present
(Handled_Statement_Sequence
(Decl
)) then
2120 Process_Declarations
2121 (Statements
(Handled_Statement_Sequence
(Decl
)),
2125 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2128 Prev_Non_Pragma
(Decl
);
2130 end Process_Declarations
;
2132 --------------------------------
2133 -- Process_Object_Declaration --
2134 --------------------------------
2136 procedure Process_Object_Declaration
2138 Has_No_Init
: Boolean := False;
2139 Is_Protected
: Boolean := False)
2141 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2142 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2144 Count_Ins
: Node_Id
;
2146 Fin_Stmts
: List_Id
;
2149 Label_Id
: Entity_Id
;
2151 Obj_Typ
: Entity_Id
;
2153 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2154 -- Once it has been established that the current object is in fact a
2155 -- return object of build-in-place function Func_Id, generate the
2156 -- following cleanup code:
2158 -- if BIPallocfrom > Secondary_Stack'Pos
2159 -- and then BIPfinalizationmaster /= null
2162 -- type Ptr_Typ is access Obj_Typ;
2163 -- for Ptr_Typ'Storage_Pool
2164 -- use Base_Pool (BIPfinalizationmaster);
2166 -- Free (Ptr_Typ (Temp));
2170 -- Obj_Typ is the type of the current object, Temp is the original
2171 -- allocation which Obj_Id renames.
2173 procedure Find_Last_Init
2176 Last_Init
: out Node_Id
;
2177 Body_Insert
: out Node_Id
);
2178 -- An object declaration has at least one and at most two init calls:
2179 -- that of the type and the user-defined initialize. Given an object
2180 -- declaration, Last_Init denotes the last initialization call which
2181 -- follows the declaration. Body_Insert denotes the place where the
2182 -- finalizer body could be potentially inserted.
2184 -----------------------------
2185 -- Build_BIP_Cleanup_Stmts --
2186 -----------------------------
2188 function Build_BIP_Cleanup_Stmts
2189 (Func_Id
: Entity_Id
) return Node_Id
2191 Decls
: constant List_Id
:= New_List
;
2192 Fin_Mas_Id
: constant Entity_Id
:=
2193 Build_In_Place_Formal
2194 (Func_Id
, BIP_Finalization_Master
);
2195 Obj_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2196 Temp_Id
: constant Entity_Id
:=
2197 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2201 Free_Stmt
: Node_Id
;
2202 Pool_Id
: Entity_Id
;
2203 Ptr_Typ
: Entity_Id
;
2207 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2209 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2212 Make_Object_Renaming_Declaration
(Loc
,
2213 Defining_Identifier
=> Pool_Id
,
2215 New_Reference_To
(RTE
(RE_Root_Storage_Pool
), Loc
),
2217 Make_Explicit_Dereference
(Loc
,
2219 Make_Function_Call
(Loc
,
2221 New_Reference_To
(RTE
(RE_Base_Pool
), Loc
),
2222 Parameter_Associations
=> New_List
(
2223 Make_Explicit_Dereference
(Loc
,
2224 Prefix
=> New_Reference_To
(Fin_Mas_Id
, Loc
)))))));
2226 -- Create an access type which uses the storage pool of the
2227 -- caller's finalization master.
2230 -- type Ptr_Typ is access Obj_Typ;
2232 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2235 Make_Full_Type_Declaration
(Loc
,
2236 Defining_Identifier
=> Ptr_Typ
,
2238 Make_Access_To_Object_Definition
(Loc
,
2239 Subtype_Indication
=> New_Reference_To
(Obj_Typ
, Loc
))));
2241 -- Perform minor decoration in order to set the master and the
2242 -- storage pool attributes.
2244 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2245 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2246 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2248 -- Create an explicit free statement. Note that the free uses the
2249 -- caller's pool expressed as a renaming.
2252 Make_Free_Statement
(Loc
,
2254 Unchecked_Convert_To
(Ptr_Typ
,
2255 New_Reference_To
(Temp_Id
, Loc
)));
2257 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2259 -- Create a block to house the dummy type and the instantiation as
2260 -- well as to perform the cleanup the temporary.
2266 -- Free (Ptr_Typ (Temp_Id));
2270 Make_Block_Statement
(Loc
,
2271 Declarations
=> Decls
,
2272 Handled_Statement_Sequence
=>
2273 Make_Handled_Sequence_Of_Statements
(Loc
,
2274 Statements
=> New_List
(Free_Stmt
)));
2277 -- if BIPfinalizationmaster /= null then
2281 Left_Opnd
=> New_Reference_To
(Fin_Mas_Id
, Loc
),
2282 Right_Opnd
=> Make_Null
(Loc
));
2284 -- For constrained or tagged results escalate the condition to
2285 -- include the allocation format. Generate:
2287 -- if BIPallocform > Secondary_Stack'Pos
2288 -- and then BIPfinalizationmaster /= null
2291 if not Is_Constrained
(Obj_Typ
)
2292 or else Is_Tagged_Type
(Obj_Typ
)
2295 Alloc
: constant Entity_Id
:=
2296 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2302 Left_Opnd
=> New_Reference_To
(Alloc
, Loc
),
2304 Make_Integer_Literal
(Loc
,
2306 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2308 Right_Opnd
=> Cond
);
2318 Make_If_Statement
(Loc
,
2320 Then_Statements
=> New_List
(Free_Blk
));
2321 end Build_BIP_Cleanup_Stmts
;
2323 --------------------
2324 -- Find_Last_Init --
2325 --------------------
2327 procedure Find_Last_Init
2330 Last_Init
: out Node_Id
;
2331 Body_Insert
: out Node_Id
)
2333 Nod_1
: Node_Id
:= Empty
;
2334 Nod_2
: Node_Id
:= Empty
;
2337 function Is_Init_Call
2339 Typ
: Entity_Id
) return Boolean;
2340 -- Given an arbitrary node, determine whether N is a procedure
2341 -- call and if it is, try to match the name of the call with the
2342 -- [Deep_]Initialize proc of Typ.
2344 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2345 -- Given a statement which is part of a list, return the next
2346 -- real statement while skipping over dynamic elab checks.
2352 function Is_Init_Call
2354 Typ
: Entity_Id
) return Boolean
2357 -- A call to [Deep_]Initialize is always direct
2359 if Nkind
(N
) = N_Procedure_Call_Statement
2360 and then Nkind
(Name
(N
)) = N_Identifier
2363 Call_Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2364 Deep_Init
: constant Entity_Id
:=
2365 TSS
(Typ
, TSS_Deep_Initialize
);
2366 Init
: Entity_Id
:= Empty
;
2369 -- A type may have controlled components but not be
2372 if Is_Controlled
(Typ
) then
2373 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2375 if Present
(Init
) then
2376 Init
:= Ultimate_Alias
(Init
);
2381 (Present
(Deep_Init
) and then Call_Ent
= Deep_Init
)
2383 (Present
(Init
) and then Call_Ent
= Init
);
2390 -----------------------------
2391 -- Next_Suitable_Statement --
2392 -----------------------------
2394 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2395 Result
: Node_Id
:= Next
(Stmt
);
2398 -- Skip over access-before-elaboration checks
2400 if Dynamic_Elaboration_Checks
2401 and then Nkind
(Result
) = N_Raise_Program_Error
2403 Result
:= Next
(Result
);
2407 end Next_Suitable_Statement
;
2409 -- Start of processing for Find_Last_Init
2413 Body_Insert
:= Empty
;
2415 -- Object renamings and objects associated with controlled
2416 -- function results do not have initialization calls.
2422 if Is_Concurrent_Type
(Typ
) then
2423 Utyp
:= Corresponding_Record_Type
(Typ
);
2428 if Is_Private_Type
(Utyp
)
2429 and then Present
(Full_View
(Utyp
))
2431 Utyp
:= Full_View
(Utyp
);
2434 -- The init procedures are arranged as follows:
2436 -- Object : Controlled_Type;
2437 -- Controlled_TypeIP (Object);
2438 -- [[Deep_]Initialize (Object);]
2440 -- where the user-defined initialize may be optional or may appear
2441 -- inside a block when abort deferral is needed.
2443 Nod_1
:= Next_Suitable_Statement
(Decl
);
2444 if Present
(Nod_1
) then
2445 Nod_2
:= Next_Suitable_Statement
(Nod_1
);
2447 -- The statement following an object declaration is always a
2448 -- call to the type init proc.
2453 -- Optional user-defined init or deep init processing
2455 if Present
(Nod_2
) then
2457 -- The statement following the type init proc may be a block
2458 -- statement in cases where abort deferral is required.
2460 if Nkind
(Nod_2
) = N_Block_Statement
then
2462 HSS
: constant Node_Id
:=
2463 Handled_Statement_Sequence
(Nod_2
);
2468 and then Present
(Statements
(HSS
))
2470 Stmt
:= First
(Statements
(HSS
));
2472 -- Examine individual block statements and locate the
2473 -- call to [Deep_]Initialze.
2475 while Present
(Stmt
) loop
2476 if Is_Init_Call
(Stmt
, Utyp
) then
2478 Body_Insert
:= Nod_2
;
2488 elsif Is_Init_Call
(Nod_2
, Utyp
) then
2494 -- Start of processing for Process_Object_Declaration
2497 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
2498 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2500 -- Handle access types
2502 if Is_Access_Type
(Obj_Typ
) then
2503 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2504 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2507 Set_Etype
(Obj_Ref
, Obj_Typ
);
2509 -- Set a new value for the state counter and insert the statement
2510 -- after the object declaration. Generate:
2512 -- Counter := <value>;
2515 Make_Assignment_Statement
(Loc
,
2516 Name
=> New_Reference_To
(Counter_Id
, Loc
),
2517 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2519 -- Insert the counter after all initialization has been done. The
2520 -- place of insertion depends on the context. When dealing with a
2521 -- controlled function, the counter is inserted directly after the
2522 -- declaration because such objects lack init calls.
2524 Find_Last_Init
(Decl
, Obj_Typ
, Count_Ins
, Body_Ins
);
2526 Insert_After
(Count_Ins
, Inc_Decl
);
2529 -- If the current declaration is the last in the list, the finalizer
2530 -- body needs to be inserted after the set counter statement for the
2531 -- current object declaration. This is complicated by the fact that
2532 -- the set counter statement may appear in abort deferred block. In
2533 -- that case, the proper insertion place is after the block.
2535 if No
(Finalizer_Insert_Nod
) then
2537 -- Insertion after an abort deffered block
2539 if Present
(Body_Ins
) then
2540 Finalizer_Insert_Nod
:= Body_Ins
;
2542 Finalizer_Insert_Nod
:= Inc_Decl
;
2546 -- Create the associated label with this object, generate:
2548 -- L<counter> : label;
2551 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2553 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2554 Label
:= Make_Label
(Loc
, Label_Id
);
2556 Prepend_To
(Finalizer_Decls
,
2557 Make_Implicit_Label_Declaration
(Loc
,
2558 Defining_Identifier
=> Entity
(Label_Id
),
2559 Label_Construct
=> Label
));
2561 -- Create the associated jump with this object, generate:
2563 -- when <counter> =>
2566 Prepend_To
(Jump_Alts
,
2567 Make_Case_Statement_Alternative
(Loc
,
2568 Discrete_Choices
=> New_List
(
2569 Make_Integer_Literal
(Loc
, Counter_Val
)),
2570 Statements
=> New_List
(
2571 Make_Goto_Statement
(Loc
,
2572 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
2574 -- Insert the jump destination, generate:
2578 Append_To
(Finalizer_Stmts
, Label
);
2580 -- Processing for simple protected objects. Such objects require
2581 -- manual finalization of their lock managers.
2583 if Is_Protected
then
2584 Fin_Stmts
:= No_List
;
2586 if Is_Simple_Protected_Type
(Obj_Typ
) then
2587 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2589 if Present
(Fin_Call
) then
2590 Fin_Stmts
:= New_List
(Fin_Call
);
2593 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2594 if Is_Record_Type
(Obj_Typ
) then
2595 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2596 elsif Is_Array_Type
(Obj_Typ
) then
2597 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2603 -- System.Tasking.Protected_Objects.Finalize_Protection
2611 if Present
(Fin_Stmts
) then
2612 Append_To
(Finalizer_Stmts
,
2613 Make_Block_Statement
(Loc
,
2614 Handled_Statement_Sequence
=>
2615 Make_Handled_Sequence_Of_Statements
(Loc
,
2616 Statements
=> Fin_Stmts
,
2618 Exception_Handlers
=> New_List
(
2619 Make_Exception_Handler
(Loc
,
2620 Exception_Choices
=> New_List
(
2621 Make_Others_Choice
(Loc
)),
2623 Statements
=> New_List
(
2624 Make_Null_Statement
(Loc
)))))));
2627 -- Processing for regular controlled objects
2631 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2633 -- begin -- Exception handlers allowed
2634 -- [Deep_]Finalize (Obj);
2637 -- when Id : others =>
2638 -- if not Raised then
2640 -- Save_Occurrence (E, Id);
2649 -- For CodePeer, the exception handlers normally generated here
2650 -- generate complex flowgraphs which result in capacity problems.
2651 -- Omitting these handlers for CodePeer is justified as follows:
2653 -- If a handler is dead, then omitting it is surely ok
2655 -- If a handler is live, then CodePeer should flag the
2656 -- potentially-exception-raising construct that causes it
2657 -- to be live. That is what we are interested in, not what
2658 -- happens after the exception is raised.
2660 if Exceptions_OK
and not CodePeer_Mode
then
2661 Fin_Stmts
:= New_List
(
2662 Make_Block_Statement
(Loc
,
2663 Handled_Statement_Sequence
=>
2664 Make_Handled_Sequence_Of_Statements
(Loc
,
2665 Statements
=> New_List
(Fin_Call
),
2667 Exception_Handlers
=> New_List
(
2668 Build_Exception_Handler
2669 (Finalizer_Data
, For_Package
)))));
2671 -- When exception handlers are prohibited, the finalization call
2672 -- appears unprotected. Any exception raised during finalization
2673 -- will bypass the circuitry which ensures the cleanup of all
2674 -- remaining objects.
2677 Fin_Stmts
:= New_List
(Fin_Call
);
2680 -- If we are dealing with a return object of a build-in-place
2681 -- function, generate the following cleanup statements:
2683 -- if BIPallocfrom > Secondary_Stack'Pos
2684 -- and then BIPfinalizationmaster /= null
2687 -- type Ptr_Typ is access Obj_Typ;
2688 -- for Ptr_Typ'Storage_Pool use
2689 -- Base_Pool (BIPfinalizationmaster.all).all;
2691 -- Free (Ptr_Typ (Temp));
2695 -- The generated code effectively detaches the temporary from the
2696 -- caller finalization master and deallocates the object. This is
2697 -- disabled on .NET/JVM because pools are not supported.
2699 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2701 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2703 if Is_Build_In_Place_Function
(Func_Id
)
2704 and then Needs_BIP_Finalization_Master
(Func_Id
)
2706 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2711 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2712 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2714 -- Temporaries created for the purpose of "exporting" a
2715 -- controlled transient out of an Expression_With_Actions (EWA)
2716 -- need guards. The following illustrates the usage of such
2719 -- Access_Typ : access [all] Obj_Typ;
2720 -- Temp : Access_Typ := null;
2721 -- <Counter> := ...;
2724 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2725 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2727 -- Temp := Ctrl_Trans'Unchecked_Access;
2730 -- The finalization machinery does not process EWA nodes as
2731 -- this may lead to premature finalization of expressions. Note
2732 -- that Temp is marked as being properly initialized regardless
2733 -- of whether the initialization of Ctrl_Trans succeeded. Since
2734 -- a failed initialization may leave Temp with a value of null,
2735 -- add a guard to handle this case:
2737 -- if Obj /= null then
2738 -- <object finalization statements>
2741 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2742 N_Object_Declaration
2744 Fin_Stmts
:= New_List
(
2745 Make_If_Statement
(Loc
,
2748 Left_Opnd
=> New_Reference_To
(Obj_Id
, Loc
),
2749 Right_Opnd
=> Make_Null
(Loc
)),
2750 Then_Statements
=> Fin_Stmts
));
2752 -- Return objects use a flag to aid in processing their
2753 -- potential finalization when the enclosing function fails
2754 -- to return properly. Generate:
2757 -- <object finalization statements>
2761 Fin_Stmts
:= New_List
(
2762 Make_If_Statement
(Loc
,
2767 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2769 Then_Statements
=> Fin_Stmts
));
2774 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2776 -- Since the declarations are examined in reverse, the state counter
2777 -- must be decremented in order to keep with the true position of
2780 Counter_Val
:= Counter_Val
- 1;
2781 end Process_Object_Declaration
;
2783 -------------------------------------
2784 -- Process_Tagged_Type_Declaration --
2785 -------------------------------------
2787 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2788 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2789 DT_Ptr
: constant Entity_Id
:=
2790 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2793 -- Ada.Tags.Unregister_Tag (<Typ>P);
2795 Append_To
(Tagged_Type_Stmts
,
2796 Make_Procedure_Call_Statement
(Loc
,
2798 New_Reference_To
(RTE
(RE_Unregister_Tag
), Loc
),
2799 Parameter_Associations
=> New_List
(
2800 New_Reference_To
(DT_Ptr
, Loc
))));
2801 end Process_Tagged_Type_Declaration
;
2803 -- Start of processing for Build_Finalizer
2808 -- Do not perform this expansion in SPARK mode because it is not
2815 -- Step 1: Extract all lists which may contain controlled objects or
2816 -- library-level tagged types.
2818 if For_Package_Spec
then
2819 Decls
:= Visible_Declarations
(Specification
(N
));
2820 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2822 -- Retrieve the package spec id
2824 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2826 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2827 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2830 -- Accept statement, block, entry body, package body, protected body,
2831 -- subprogram body or task body.
2834 Decls
:= Declarations
(N
);
2835 HSS
:= Handled_Statement_Sequence
(N
);
2837 if Present
(HSS
) then
2838 if Present
(Statements
(HSS
)) then
2839 Stmts
:= Statements
(HSS
);
2842 if Present
(At_End_Proc
(HSS
)) then
2843 Prev_At_End
:= At_End_Proc
(HSS
);
2847 -- Retrieve the package spec id for package bodies
2849 if For_Package_Body
then
2850 Spec_Id
:= Corresponding_Spec
(N
);
2854 -- Do not process nested packages since those are handled by the
2855 -- enclosing scope's finalizer. Do not process non-expanded package
2856 -- instantiations since those will be re-analyzed and re-expanded.
2860 (not Is_Library_Level_Entity
(Spec_Id
)
2862 -- Nested packages are considered to be library level entities,
2863 -- but do not need to be processed separately. True library level
2864 -- packages have a scope value of 1.
2866 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2867 or else (Is_Generic_Instance
(Spec_Id
)
2868 and then Package_Instantiation
(Spec_Id
) /= N
))
2873 -- Step 2: Object [pre]processing
2877 -- Preprocess the visible declarations now in order to obtain the
2878 -- correct number of controlled object by the time the private
2879 -- declarations are processed.
2881 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2883 -- From all the possible contexts, only package specifications may
2884 -- have private declarations.
2886 if For_Package_Spec
then
2887 Process_Declarations
2888 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2891 -- The current context may lack controlled objects, but require some
2892 -- other form of completion (task termination for instance). In such
2893 -- cases, the finalizer must be created and carry the additional
2896 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2900 -- The preprocessing has determined that the context has controlled
2901 -- objects or library-level tagged types.
2903 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2905 -- Private declarations are processed first in order to preserve
2906 -- possible dependencies between public and private objects.
2908 if For_Package_Spec
then
2909 Process_Declarations
(Priv_Decls
);
2912 Process_Declarations
(Decls
);
2918 -- Preprocess both declarations and statements
2920 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2921 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
2923 -- At this point it is known that N has controlled objects. Ensure
2924 -- that N has a declarative list since the finalizer spec will be
2927 if Has_Ctrl_Objs
and then No
(Decls
) then
2928 Set_Declarations
(N
, New_List
);
2929 Decls
:= Declarations
(N
);
2930 Spec_Decls
:= Decls
;
2933 -- The current context may lack controlled objects, but require some
2934 -- other form of completion (task termination for instance). In such
2935 -- cases, the finalizer must be created and carry the additional
2938 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2942 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2943 Process_Declarations
(Stmts
);
2944 Process_Declarations
(Decls
);
2948 -- Step 3: Finalizer creation
2950 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2953 end Build_Finalizer
;
2955 --------------------------
2956 -- Build_Finalizer_Call --
2957 --------------------------
2959 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
2960 Is_Prot_Body
: constant Boolean :=
2961 Nkind
(N
) = N_Subprogram_Body
2962 and then Is_Protected_Subprogram_Body
(N
);
2963 -- Determine whether N denotes the protected version of a subprogram
2964 -- which belongs to a protected type.
2966 Loc
: constant Source_Ptr
:= Sloc
(N
);
2970 -- Do not perform this expansion in SPARK mode because we do not create
2971 -- finalizers in the first place.
2977 -- The At_End handler should have been assimilated by the finalizer
2979 HSS
:= Handled_Statement_Sequence
(N
);
2980 pragma Assert
(No
(At_End_Proc
(HSS
)));
2982 -- If the construct to be cleaned up is a protected subprogram body, the
2983 -- finalizer call needs to be associated with the block which wraps the
2984 -- unprotected version of the subprogram. The following illustrates this
2987 -- procedure Prot_SubpP is
2988 -- procedure finalizer is
2990 -- Service_Entries (Prot_Obj);
2997 -- Prot_SubpN (Prot_Obj);
3003 if Is_Prot_Body
then
3004 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3006 -- An At_End handler and regular exception handlers cannot coexist in
3007 -- the same statement sequence. Wrap the original statements in a block.
3009 elsif Present
(Exception_Handlers
(HSS
)) then
3011 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3016 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3018 Set_Handled_Statement_Sequence
(N
,
3019 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3021 HSS
:= Handled_Statement_Sequence
(N
);
3022 Set_End_Label
(HSS
, End_Lab
);
3026 Set_At_End_Proc
(HSS
, New_Reference_To
(Fin_Id
, Loc
));
3028 Analyze
(At_End_Proc
(HSS
));
3029 Expand_At_End_Handler
(HSS
, Empty
);
3030 end Build_Finalizer_Call
;
3032 ---------------------
3033 -- Build_Late_Proc --
3034 ---------------------
3036 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3038 for Final_Prim
in Name_Of
'Range loop
3039 if Name_Of
(Final_Prim
) = Nam
then
3042 (Prim
=> Final_Prim
,
3044 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3047 end Build_Late_Proc
;
3049 -------------------------------
3050 -- Build_Object_Declarations --
3051 -------------------------------
3053 procedure Build_Object_Declarations
3054 (Data
: out Finalization_Exception_Data
;
3057 For_Package
: Boolean := False)
3063 pragma Assert
(Decls
/= No_List
);
3065 -- Always set the proper location as it may be needed even when
3066 -- exception propagation is forbidden.
3070 if Restriction_Active
(No_Exception_Propagation
) then
3071 Data
.Abort_Id
:= Empty
;
3073 Data
.Raised_Id
:= Empty
;
3077 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3079 -- In certain scenarios, finalization can be triggered by an abort. If
3080 -- the finalization itself fails and raises an exception, the resulting
3081 -- Program_Error must be supressed and replaced by an abort signal. In
3082 -- order to detect this scenario, save the state of entry into the
3083 -- finalization code.
3085 -- No need to do this for VM case, since VM version of Ada.Exceptions
3086 -- does not include routine Raise_From_Controlled_Operation which is the
3087 -- the sole user of flag Abort.
3089 -- This is not needed for library-level finalizers as they are called
3090 -- by the environment task and cannot be aborted.
3093 and then VM_Target
= No_VM
3094 and then not For_Package
3096 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3098 A_Expr
:= New_Reference_To
(RTE
(RE_Triggered_By_Abort
), Loc
);
3102 -- Abort_Id : constant Boolean := <A_Expr>;
3105 Make_Object_Declaration
(Loc
,
3106 Defining_Identifier
=> Data
.Abort_Id
,
3107 Constant_Present
=> True,
3108 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3109 Expression
=> A_Expr
));
3112 -- No abort, .NET/JVM or library-level finalizers
3114 Data
.Abort_Id
:= Empty
;
3117 if Exception_Extra_Info
then
3118 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3122 -- E_Id : Exception_Occurrence;
3125 Make_Object_Declaration
(Loc
,
3126 Defining_Identifier
=> Data
.E_Id
,
3127 Object_Definition
=>
3128 New_Reference_To
(RTE
(RE_Exception_Occurrence
), Loc
));
3129 Set_No_Initialization
(E_Decl
);
3131 Append_To
(Decls
, E_Decl
);
3139 -- Raised_Id : Boolean := False;
3142 Make_Object_Declaration
(Loc
,
3143 Defining_Identifier
=> Data
.Raised_Id
,
3144 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3145 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
3146 end Build_Object_Declarations
;
3148 ---------------------------
3149 -- Build_Raise_Statement --
3150 ---------------------------
3152 function Build_Raise_Statement
3153 (Data
: Finalization_Exception_Data
) return Node_Id
3159 -- Standard run-time and .NET/JVM targets use the specialized routine
3160 -- Raise_From_Controlled_Operation.
3162 if Exception_Extra_Info
3163 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3166 Make_Procedure_Call_Statement
(Data
.Loc
,
3169 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3170 Parameter_Associations
=>
3171 New_List
(New_Reference_To
(Data
.E_Id
, Data
.Loc
)));
3173 -- Restricted run-time: exception messages are not supported and hence
3174 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3179 Make_Raise_Program_Error
(Data
.Loc
,
3180 Reason
=> PE_Finalize_Raised_Exception
);
3185 -- Raised_Id and then not Abort_Id
3189 Expr
:= New_Reference_To
(Data
.Raised_Id
, Data
.Loc
);
3191 if Present
(Data
.Abort_Id
) then
3192 Expr
:= Make_And_Then
(Data
.Loc
,
3195 Make_Op_Not
(Data
.Loc
,
3196 Right_Opnd
=> New_Reference_To
(Data
.Abort_Id
, Data
.Loc
)));
3201 -- if Raised_Id and then not Abort_Id then
3202 -- Raise_From_Controlled_Operation (E_Id);
3204 -- raise Program_Error; -- restricted runtime
3208 Make_If_Statement
(Data
.Loc
,
3210 Then_Statements
=> New_List
(Stmt
));
3211 end Build_Raise_Statement
;
3213 -----------------------------
3214 -- Build_Record_Deep_Procs --
3215 -----------------------------
3217 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3221 (Prim
=> Initialize_Case
,
3223 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3225 if not Is_Immutably_Limited_Type
(Typ
) then
3228 (Prim
=> Adjust_Case
,
3230 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3233 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3234 -- suppressed since these routine will not be used.
3236 if not Restriction_Active
(No_Finalization
) then
3239 (Prim
=> Finalize_Case
,
3241 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3243 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3244 -- .NET do not support address arithmetic and unchecked conversions.
3246 if VM_Target
= No_VM
then
3249 (Prim
=> Address_Case
,
3251 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3254 end Build_Record_Deep_Procs
;
3260 function Cleanup_Array
3263 Typ
: Entity_Id
) return List_Id
3265 Loc
: constant Source_Ptr
:= Sloc
(N
);
3266 Index_List
: constant List_Id
:= New_List
;
3268 function Free_Component
return List_Id
;
3269 -- Generate the code to finalize the task or protected subcomponents
3270 -- of a single component of the array.
3272 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3273 -- Generate a loop over one dimension of the array
3275 --------------------
3276 -- Free_Component --
3277 --------------------
3279 function Free_Component
return List_Id
is
3280 Stmts
: List_Id
:= New_List
;
3282 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3285 -- Component type is known to contain tasks or protected objects
3288 Make_Indexed_Component
(Loc
,
3289 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3290 Expressions
=> Index_List
);
3292 Set_Etype
(Tsk
, C_Typ
);
3294 if Is_Task_Type
(C_Typ
) then
3295 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3297 elsif Is_Simple_Protected_Type
(C_Typ
) then
3298 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3300 elsif Is_Record_Type
(C_Typ
) then
3301 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3303 elsif Is_Array_Type
(C_Typ
) then
3304 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3310 ------------------------
3311 -- Free_One_Dimension --
3312 ------------------------
3314 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3318 if Dim
> Number_Dimensions
(Typ
) then
3319 return Free_Component
;
3321 -- Here we generate the required loop
3324 Index
:= Make_Temporary
(Loc
, 'J');
3325 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
3328 Make_Implicit_Loop_Statement
(N
,
3329 Identifier
=> Empty
,
3331 Make_Iteration_Scheme
(Loc
,
3332 Loop_Parameter_Specification
=>
3333 Make_Loop_Parameter_Specification
(Loc
,
3334 Defining_Identifier
=> Index
,
3335 Discrete_Subtype_Definition
=>
3336 Make_Attribute_Reference
(Loc
,
3337 Prefix
=> Duplicate_Subexpr
(Obj
),
3338 Attribute_Name
=> Name_Range
,
3339 Expressions
=> New_List
(
3340 Make_Integer_Literal
(Loc
, Dim
))))),
3341 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3343 end Free_One_Dimension
;
3345 -- Start of processing for Cleanup_Array
3348 return Free_One_Dimension
(1);
3351 --------------------
3352 -- Cleanup_Record --
3353 --------------------
3355 function Cleanup_Record
3358 Typ
: Entity_Id
) return List_Id
3360 Loc
: constant Source_Ptr
:= Sloc
(N
);
3363 Stmts
: constant List_Id
:= New_List
;
3364 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3367 if Has_Discriminants
(U_Typ
)
3368 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3370 Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3373 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3375 -- For now, do not attempt to free a component that may appear in a
3376 -- variant, and instead issue a warning. Doing this "properly" would
3377 -- require building a case statement and would be quite a mess. Note
3378 -- that the RM only requires that free "work" for the case of a task
3379 -- access value, so already we go way beyond this in that we deal
3380 -- with the array case and non-discriminated record cases.
3383 ("task/protected object in variant record will not be freed??", N
);
3384 return New_List
(Make_Null_Statement
(Loc
));
3387 Comp
:= First_Component
(Typ
);
3388 while Present
(Comp
) loop
3389 if Has_Task
(Etype
(Comp
))
3390 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3393 Make_Selected_Component
(Loc
,
3394 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3395 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3396 Set_Etype
(Tsk
, Etype
(Comp
));
3398 if Is_Task_Type
(Etype
(Comp
)) then
3399 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3401 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3402 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3404 elsif Is_Record_Type
(Etype
(Comp
)) then
3406 -- Recurse, by generating the prefix of the argument to
3407 -- the eventual cleanup call.
3409 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3411 elsif Is_Array_Type
(Etype
(Comp
)) then
3412 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3416 Next_Component
(Comp
);
3422 ------------------------------
3423 -- Cleanup_Protected_Object --
3424 ------------------------------
3426 function Cleanup_Protected_Object
3428 Ref
: Node_Id
) return Node_Id
3430 Loc
: constant Source_Ptr
:= Sloc
(N
);
3433 -- For restricted run-time libraries (Ravenscar), tasks are
3434 -- non-terminating, and protected objects can only appear at library
3435 -- level, so we do not want finalization of protected objects.
3437 if Restricted_Profile
then
3442 Make_Procedure_Call_Statement
(Loc
,
3444 New_Reference_To
(RTE
(RE_Finalize_Protection
), Loc
),
3445 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3447 end Cleanup_Protected_Object
;
3453 function Cleanup_Task
3455 Ref
: Node_Id
) return Node_Id
3457 Loc
: constant Source_Ptr
:= Sloc
(N
);
3460 -- For restricted run-time libraries (Ravenscar), tasks are
3461 -- non-terminating and they can only appear at library level, so we do
3462 -- not want finalization of task objects.
3464 if Restricted_Profile
then
3469 Make_Procedure_Call_Statement
(Loc
,
3471 New_Reference_To
(RTE
(RE_Free_Task
), Loc
),
3472 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3476 ------------------------------
3477 -- Check_Visibly_Controlled --
3478 ------------------------------
3480 procedure Check_Visibly_Controlled
3481 (Prim
: Final_Primitives
;
3483 E
: in out Entity_Id
;
3484 Cref
: in out Node_Id
)
3486 Parent_Type
: Entity_Id
;
3490 if Is_Derived_Type
(Typ
)
3491 and then Comes_From_Source
(E
)
3492 and then not Present
(Overridden_Operation
(E
))
3494 -- We know that the explicit operation on the type does not override
3495 -- the inherited operation of the parent, and that the derivation
3496 -- is from a private type that is not visibly controlled.
3498 Parent_Type
:= Etype
(Typ
);
3499 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3501 if Present
(Op
) then
3504 -- Wrap the object to be initialized into the proper
3505 -- unchecked conversion, to be compatible with the operation
3508 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3509 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3511 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3515 end Check_Visibly_Controlled
;
3517 -------------------------------
3518 -- CW_Or_Has_Controlled_Part --
3519 -------------------------------
3521 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3523 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3524 end CW_Or_Has_Controlled_Part
;
3530 function Convert_View
3533 Ind
: Pos
:= 1) return Node_Id
3535 Fent
: Entity_Id
:= First_Entity
(Proc
);
3540 for J
in 2 .. Ind
loop
3544 Ftyp
:= Etype
(Fent
);
3546 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3547 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3549 Atyp
:= Etype
(Arg
);
3552 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3553 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3556 and then Present
(Atyp
)
3557 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3558 and then Base_Type
(Underlying_Type
(Atyp
)) =
3559 Base_Type
(Underlying_Type
(Ftyp
))
3561 return Unchecked_Convert_To
(Ftyp
, Arg
);
3563 -- If the argument is already a conversion, as generated by
3564 -- Make_Init_Call, set the target type to the type of the formal
3565 -- directly, to avoid spurious typing problems.
3567 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3568 and then not Is_Class_Wide_Type
(Atyp
)
3570 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3571 Set_Etype
(Arg
, Ftyp
);
3579 ------------------------
3580 -- Enclosing_Function --
3581 ------------------------
3583 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3584 Func_Id
: Entity_Id
;
3588 while Present
(Func_Id
)
3589 and then Func_Id
/= Standard_Standard
3591 if Ekind
(Func_Id
) = E_Function
then
3595 Func_Id
:= Scope
(Func_Id
);
3599 end Enclosing_Function
;
3601 -------------------------------
3602 -- Establish_Transient_Scope --
3603 -------------------------------
3605 -- This procedure is called each time a transient block has to be inserted
3606 -- that is to say for each call to a function with unconstrained or tagged
3607 -- result. It creates a new scope on the stack scope in order to enclose
3608 -- all transient variables generated
3610 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3611 Loc
: constant Source_Ptr
:= Sloc
(N
);
3612 Wrap_Node
: Node_Id
;
3615 -- Do not create a transient scope if we are already inside one
3617 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3618 if Scope_Stack
.Table
(S
).Is_Transient
then
3620 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3625 -- If we have encountered Standard there are no enclosing
3626 -- transient scopes.
3628 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3633 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3635 -- Case of no wrap node, false alert, no transient scope needed
3637 if No
(Wrap_Node
) then
3640 -- If the node to wrap is an iteration_scheme, the expression is
3641 -- one of the bounds, and the expansion will make an explicit
3642 -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3643 -- so do not apply any transformations here. Same for an Ada 2012
3644 -- iterator specification, where a block is created for the expression
3645 -- that build the container.
3647 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3648 N_Iterator_Specification
)
3652 -- In formal verification mode, if the node to wrap is a pragma check,
3653 -- this node and enclosed expression are not expanded, so do not apply
3654 -- any transformations here.
3657 and then Nkind
(Wrap_Node
) = N_Pragma
3658 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3663 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3664 Set_Scope_Is_Transient
;
3667 Set_Uses_Sec_Stack
(Current_Scope
);
3668 Check_Restriction
(No_Secondary_Stack
, N
);
3671 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3672 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3674 if Debug_Flag_W
then
3675 Write_Str
(" <Transient>");
3679 end Establish_Transient_Scope
;
3681 ----------------------------
3682 -- Expand_Cleanup_Actions --
3683 ----------------------------
3685 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3686 Scop
: constant Entity_Id
:= Current_Scope
;
3688 Is_Asynchronous_Call
: constant Boolean :=
3689 Nkind
(N
) = N_Block_Statement
3690 and then Is_Asynchronous_Call_Block
(N
);
3691 Is_Master
: constant Boolean :=
3692 Nkind
(N
) /= N_Entry_Body
3693 and then Is_Task_Master
(N
);
3694 Is_Protected_Body
: constant Boolean :=
3695 Nkind
(N
) = N_Subprogram_Body
3696 and then Is_Protected_Subprogram_Body
(N
);
3697 Is_Task_Allocation
: constant Boolean :=
3698 Nkind
(N
) = N_Block_Statement
3699 and then Is_Task_Allocation_Block
(N
);
3700 Is_Task_Body
: constant Boolean :=
3701 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3702 Needs_Sec_Stack_Mark
: constant Boolean :=
3703 Uses_Sec_Stack
(Scop
)
3705 not Sec_Stack_Needed_For_Return
(Scop
)
3706 and then VM_Target
= No_VM
;
3708 Actions_Required
: constant Boolean :=
3709 Requires_Cleanup_Actions
(N
, True)
3710 or else Is_Asynchronous_Call
3712 or else Is_Protected_Body
3713 or else Is_Task_Allocation
3714 or else Is_Task_Body
3715 or else Needs_Sec_Stack_Mark
;
3717 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3720 procedure Wrap_HSS_In_Block
;
3721 -- Move HSS inside a new block along with the original exception
3722 -- handlers. Make the newly generated block the sole statement of HSS.
3724 -----------------------
3725 -- Wrap_HSS_In_Block --
3726 -----------------------
3728 procedure Wrap_HSS_In_Block
is
3733 -- Preserve end label to provide proper cross-reference information
3735 End_Lab
:= End_Label
(HSS
);
3737 Make_Block_Statement
(Loc
,
3738 Handled_Statement_Sequence
=> HSS
);
3740 -- Signal the finalization machinery that this particular block
3741 -- contains the original context.
3743 Set_Is_Finalization_Wrapper
(Block
);
3745 Set_Handled_Statement_Sequence
(N
,
3746 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3747 HSS
:= Handled_Statement_Sequence
(N
);
3749 Set_First_Real_Statement
(HSS
, Block
);
3750 Set_End_Label
(HSS
, End_Lab
);
3752 -- Comment needed here, see RH for 1.306 ???
3754 if Nkind
(N
) = N_Subprogram_Body
then
3755 Set_Has_Nested_Block_With_Handler
(Scop
);
3757 end Wrap_HSS_In_Block
;
3759 -- Start of processing for Expand_Cleanup_Actions
3762 -- The current construct does not need any form of servicing
3764 if not Actions_Required
then
3767 -- If the current node is a rewritten task body and the descriptors have
3768 -- not been delayed (due to some nested instantiations), do not generate
3769 -- redundant cleanup actions.
3772 and then Nkind
(N
) = N_Subprogram_Body
3773 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3779 Decls
: List_Id
:= Declarations
(N
);
3781 Mark
: Entity_Id
:= Empty
;
3782 New_Decls
: List_Id
;
3786 -- If we are generating expanded code for debugging purposes, use the
3787 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3788 -- be updated subsequently to reference the proper line in .dg files.
3789 -- If we are not debugging generated code, use No_Location instead,
3790 -- so that no debug information is generated for the cleanup code.
3791 -- This makes the behavior of the NEXT command in GDB monotonic, and
3792 -- makes the placement of breakpoints more accurate.
3794 if Debug_Generated_Code
then
3800 -- Set polling off. The finalization and cleanup code is executed
3801 -- with aborts deferred.
3803 Old_Poll
:= Polling_Required
;
3804 Polling_Required
:= False;
3806 -- A task activation call has already been built for a task
3807 -- allocation block.
3809 if not Is_Task_Allocation
then
3810 Build_Task_Activation_Call
(N
);
3814 Establish_Task_Master
(N
);
3817 New_Decls
:= New_List
;
3819 -- If secondary stack is in use, generate:
3821 -- Mnn : constant Mark_Id := SS_Mark;
3823 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3824 -- secondary stack is never used on a VM.
3826 if Needs_Sec_Stack_Mark
then
3827 Mark
:= Make_Temporary
(Loc
, 'M');
3829 Append_To
(New_Decls
,
3830 Make_Object_Declaration
(Loc
,
3831 Defining_Identifier
=> Mark
,
3832 Object_Definition
=>
3833 New_Reference_To
(RTE
(RE_Mark_Id
), Loc
),
3835 Make_Function_Call
(Loc
,
3836 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
))));
3838 Set_Uses_Sec_Stack
(Scop
, False);
3841 -- If exception handlers are present, wrap the sequence of statements
3842 -- in a block since it is not possible to have exception handlers and
3843 -- an At_End handler in the same construct.
3845 if Present
(Exception_Handlers
(HSS
)) then
3848 -- Ensure that the First_Real_Statement field is set
3850 elsif No
(First_Real_Statement
(HSS
)) then
3851 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3854 -- Do not move the Activation_Chain declaration in the context of
3855 -- task allocation blocks. Task allocation blocks use _chain in their
3856 -- cleanup handlers and gigi complains if it is declared in the
3857 -- sequence of statements of the scope that declares the handler.
3859 if Is_Task_Allocation
then
3861 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3865 Decl
:= First
(Decls
);
3866 while Nkind
(Decl
) /= N_Object_Declaration
3867 or else Defining_Identifier
(Decl
) /= Chain
3871 -- A task allocation block should always include a _chain
3874 pragma Assert
(Present
(Decl
));
3878 Prepend_To
(New_Decls
, Decl
);
3882 -- Ensure the presence of a declaration list in order to successfully
3883 -- append all original statements to it.
3886 Set_Declarations
(N
, New_List
);
3887 Decls
:= Declarations
(N
);
3890 -- Move the declarations into the sequence of statements in order to
3891 -- have them protected by the At_End handler. It may seem weird to
3892 -- put declarations in the sequence of statement but in fact nothing
3893 -- forbids that at the tree level.
3895 Append_List_To
(Decls
, Statements
(HSS
));
3896 Set_Statements
(HSS
, Decls
);
3898 -- Reset the Sloc of the handled statement sequence to properly
3899 -- reflect the new initial "statement" in the sequence.
3901 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
3903 -- The declarations of finalizer spec and auxiliary variables replace
3904 -- the old declarations that have been moved inward.
3906 Set_Declarations
(N
, New_Decls
);
3907 Analyze_Declarations
(New_Decls
);
3909 -- Generate finalization calls for all controlled objects appearing
3910 -- in the statements of N. Add context specific cleanup for various
3915 Clean_Stmts
=> Build_Cleanup_Statements
(N
),
3917 Top_Decls
=> New_Decls
,
3918 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
3922 if Present
(Fin_Id
) then
3923 Build_Finalizer_Call
(N
, Fin_Id
);
3926 -- Restore saved polling mode
3928 Polling_Required
:= Old_Poll
;
3930 end Expand_Cleanup_Actions
;
3932 ---------------------------
3933 -- Expand_N_Package_Body --
3934 ---------------------------
3936 -- Add call to Activate_Tasks if body is an activator (actual processing
3937 -- is in chapter 9).
3939 -- Generate subprogram descriptor for elaboration routine
3941 -- Encode entity names in package body
3943 procedure Expand_N_Package_Body
(N
: Node_Id
) is
3944 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
3948 -- This is done only for non-generic packages
3950 if Ekind
(Spec_Ent
) = E_Package
then
3951 Push_Scope
(Corresponding_Spec
(N
));
3953 -- Build dispatch tables of library level tagged types
3955 if Tagged_Type_Expansion
3956 and then Is_Library_Level_Entity
(Spec_Ent
)
3958 Build_Static_Dispatch_Tables
(N
);
3961 Build_Task_Activation_Call
(N
);
3965 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
3966 Set_In_Package_Body
(Spec_Ent
, False);
3968 -- Set to encode entity names in package body before gigi is called
3970 Qualify_Entity_Names
(N
);
3972 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
3975 Clean_Stmts
=> No_List
,
3977 Top_Decls
=> No_List
,
3978 Defer_Abort
=> False,
3981 if Present
(Fin_Id
) then
3983 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
3986 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
3987 Body_Ent
:= Defining_Identifier
(Body_Ent
);
3990 Set_Finalizer
(Body_Ent
, Fin_Id
);
3994 end Expand_N_Package_Body
;
3996 ----------------------------------
3997 -- Expand_N_Package_Declaration --
3998 ----------------------------------
4000 -- Add call to Activate_Tasks if there are tasks declared and the package
4001 -- has no body. Note that in Ada 83 this may result in premature activation
4002 -- of some tasks, given that we cannot tell whether a body will eventually
4005 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4006 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4007 Spec
: constant Node_Id
:= Specification
(N
);
4011 No_Body
: Boolean := False;
4012 -- True in the case of a package declaration that is a compilation
4013 -- unit and for which no associated body will be compiled in this
4017 -- Case of a package declaration other than a compilation unit
4019 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4022 -- Case of a compilation unit that does not require a body
4024 elsif not Body_Required
(Parent
(N
))
4025 and then not Unit_Requires_Body
(Id
)
4029 -- Special case of generating calling stubs for a remote call interface
4030 -- package: even though the package declaration requires one, the body
4031 -- won't be processed in this compilation (so any stubs for RACWs
4032 -- declared in the package must be generated here, along with the spec).
4034 elsif Parent
(N
) = Cunit
(Main_Unit
)
4035 and then Is_Remote_Call_Interface
(Id
)
4036 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4041 -- For a nested instance, delay processing until freeze point
4043 if Has_Delayed_Freeze
(Id
)
4044 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4049 -- For a package declaration that implies no associated body, generate
4050 -- task activation call and RACW supporting bodies now (since we won't
4051 -- have a specific separate compilation unit for that).
4056 if Has_RACW
(Id
) then
4058 -- Generate RACW subprogram bodies
4060 Decls
:= Private_Declarations
(Spec
);
4063 Decls
:= Visible_Declarations
(Spec
);
4068 Set_Visible_Declarations
(Spec
, Decls
);
4071 Append_RACW_Bodies
(Decls
, Id
);
4072 Analyze_List
(Decls
);
4075 if Present
(Activation_Chain_Entity
(N
)) then
4077 -- Generate task activation call as last step of elaboration
4079 Build_Task_Activation_Call
(N
);
4085 -- Build dispatch tables of library level tagged types
4087 if Tagged_Type_Expansion
4088 and then (Is_Compilation_Unit
(Id
)
4089 or else (Is_Generic_Instance
(Id
)
4090 and then Is_Library_Level_Entity
(Id
)))
4092 Build_Static_Dispatch_Tables
(N
);
4095 -- Note: it is not necessary to worry about generating a subprogram
4096 -- descriptor, since the only way to get exception handlers into a
4097 -- package spec is to include instantiations, and that would cause
4098 -- generation of subprogram descriptors to be delayed in any case.
4100 -- Set to encode entity names in package spec before gigi is called
4102 Qualify_Entity_Names
(N
);
4104 if Ekind
(Id
) /= E_Generic_Package
then
4107 Clean_Stmts
=> No_List
,
4109 Top_Decls
=> No_List
,
4110 Defer_Abort
=> False,
4113 Set_Finalizer
(Id
, Fin_Id
);
4115 end Expand_N_Package_Declaration
;
4117 -----------------------------
4118 -- Find_Node_To_Be_Wrapped --
4119 -----------------------------
4121 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4123 The_Parent
: Node_Id
;
4129 pragma Assert
(P
/= Empty
);
4130 The_Parent
:= Parent
(P
);
4132 case Nkind
(The_Parent
) is
4134 -- Simple statement can be wrapped
4139 -- Usually assignments are good candidate for wrapping except
4140 -- when they have been generated as part of a controlled aggregate
4141 -- where the wrapping should take place more globally.
4143 when N_Assignment_Statement
=>
4144 if No_Ctrl_Actions
(The_Parent
) then
4150 -- An entry call statement is a special case if it occurs in the
4151 -- context of a Timed_Entry_Call. In this case we wrap the entire
4152 -- timed entry call.
4154 when N_Entry_Call_Statement |
4155 N_Procedure_Call_Statement
=>
4156 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4157 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4159 N_Conditional_Entry_Call
)
4161 return Parent
(Parent
(The_Parent
));
4166 -- Object declarations are also a boundary for the transient scope
4167 -- even if they are not really wrapped. For further details, see
4168 -- Wrap_Transient_Declaration.
4170 when N_Object_Declaration |
4171 N_Object_Renaming_Declaration |
4172 N_Subtype_Declaration
=>
4175 -- The expression itself is to be wrapped if its parent is a
4176 -- compound statement or any other statement where the expression
4177 -- is known to be scalar
4179 when N_Accept_Alternative |
4180 N_Attribute_Definition_Clause |
4183 N_Delay_Alternative |
4184 N_Delay_Until_Statement |
4185 N_Delay_Relative_Statement |
4186 N_Discriminant_Association |
4188 N_Entry_Body_Formal_Part |
4191 N_Iteration_Scheme |
4192 N_Terminate_Alternative
=>
4195 when N_Attribute_Reference
=>
4197 if Is_Procedure_Attribute_Name
4198 (Attribute_Name
(The_Parent
))
4203 -- A raise statement can be wrapped. This will arise when the
4204 -- expression in a raise_with_expression uses the secondary
4205 -- stack, for example.
4207 when N_Raise_Statement
=>
4210 -- If the expression is within the iteration scheme of a loop,
4211 -- we must create a declaration for it, followed by an assignment
4212 -- in order to have a usable statement to wrap.
4214 when N_Loop_Parameter_Specification
=>
4215 return Parent
(The_Parent
);
4217 -- The following nodes contains "dummy calls" which don't need to
4220 when N_Parameter_Specification |
4221 N_Discriminant_Specification |
4222 N_Component_Declaration
=>
4225 -- The return statement is not to be wrapped when the function
4226 -- itself needs wrapping at the outer-level
4228 when N_Simple_Return_Statement
=>
4230 Applies_To
: constant Entity_Id
:=
4232 (Return_Statement_Entity
(The_Parent
));
4233 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4235 if Requires_Transient_Scope
(Return_Type
) then
4242 -- If we leave a scope without having been able to find a node to
4243 -- wrap, something is going wrong but this can happen in error
4244 -- situation that are not detected yet (such as a dynamic string
4245 -- in a pragma export)
4247 when N_Subprogram_Body |
4248 N_Package_Declaration |
4250 N_Block_Statement
=>
4253 -- Otherwise continue the search
4259 end Find_Node_To_Be_Wrapped
;
4261 -------------------------------------
4262 -- Get_Global_Pool_For_Access_Type --
4263 -------------------------------------
4265 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4267 -- Access types whose size is smaller than System.Address size can exist
4268 -- only on VMS. We can't use the usual global pool which returns an
4269 -- object of type Address as truncation will make it invalid. To handle
4270 -- this case, VMS has a dedicated global pool that returns addresses
4271 -- that fit into 32 bit accesses.
4273 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4274 return RTE
(RE_Global_Pool_32_Object
);
4276 return RTE
(RE_Global_Pool_Object
);
4278 end Get_Global_Pool_For_Access_Type
;
4280 ----------------------------------
4281 -- Has_New_Controlled_Component --
4282 ----------------------------------
4284 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4288 if not Is_Tagged_Type
(E
) then
4289 return Has_Controlled_Component
(E
);
4290 elsif not Is_Derived_Type
(E
) then
4291 return Has_Controlled_Component
(E
);
4294 Comp
:= First_Component
(E
);
4295 while Present
(Comp
) loop
4296 if Chars
(Comp
) = Name_uParent
then
4299 elsif Scope
(Original_Record_Component
(Comp
)) = E
4300 and then Needs_Finalization
(Etype
(Comp
))
4305 Next_Component
(Comp
);
4309 end Has_New_Controlled_Component
;
4311 ---------------------------------
4312 -- Has_Simple_Protected_Object --
4313 ---------------------------------
4315 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4317 if Has_Task
(T
) then
4320 elsif Is_Simple_Protected_Type
(T
) then
4323 elsif Is_Array_Type
(T
) then
4324 return Has_Simple_Protected_Object
(Component_Type
(T
));
4326 elsif Is_Record_Type
(T
) then
4331 Comp
:= First_Component
(T
);
4332 while Present
(Comp
) loop
4333 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4337 Next_Component
(Comp
);
4346 end Has_Simple_Protected_Object
;
4348 ------------------------------------
4349 -- Insert_Actions_In_Scope_Around --
4350 ------------------------------------
4352 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
) is
4353 After
: constant List_Id
:=
4354 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_After
;
4355 Before
: constant List_Id
:=
4356 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_Before
;
4357 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4358 -- Last), but this was incorrect as Process_Transient_Object may
4359 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4361 procedure Process_Transient_Objects
4362 (First_Object
: Node_Id
;
4363 Last_Object
: Node_Id
;
4364 Related_Node
: Node_Id
);
4365 -- First_Object and Last_Object define a list which contains potential
4366 -- controlled transient objects. Finalization flags are inserted before
4367 -- First_Object and finalization calls are inserted after Last_Object.
4368 -- Related_Node is the node for which transient objects have been
4371 -------------------------------
4372 -- Process_Transient_Objects --
4373 -------------------------------
4375 procedure Process_Transient_Objects
4376 (First_Object
: Node_Id
;
4377 Last_Object
: Node_Id
;
4378 Related_Node
: Node_Id
)
4380 function Requires_Hooking
return Boolean;
4381 -- Determine whether the context requires transient variable export
4382 -- to the outer finalizer. This scenario arises when the context may
4383 -- raise an exception.
4385 ----------------------
4386 -- Requires_Hooking --
4387 ----------------------
4389 function Requires_Hooking
return Boolean is
4391 -- The context is either a procedure or function call or an object
4392 -- declaration initialized by a function call. Note that in the
4393 -- latter case, a function call that returns on the secondary
4394 -- stack is usually rewritten into something else. Its proper
4395 -- detection requires examination of the original initialization
4398 return Nkind
(N
) in N_Subprogram_Call
4399 or else (Nkind
(N
) = N_Object_Declaration
4400 and then Nkind
(Original_Node
(Expression
(N
))) =
4402 end Requires_Hooking
;
4406 Must_Hook
: constant Boolean := Requires_Hooking
;
4407 Built
: Boolean := False;
4408 Desig_Typ
: Entity_Id
;
4409 Fin_Block
: Node_Id
;
4410 Fin_Data
: Finalization_Exception_Data
;
4411 Fin_Decls
: List_Id
;
4412 Last_Fin
: Node_Id
:= Empty
;
4416 Obj_Typ
: Entity_Id
;
4417 Prev_Fin
: Node_Id
:= Empty
;
4420 Temp_Id
: Entity_Id
;
4422 -- Start of processing for Process_Transient_Objects
4425 -- Examine all objects in the list First_Object .. Last_Object
4427 Stmt
:= First_Object
;
4428 while Present
(Stmt
) loop
4429 if Nkind
(Stmt
) = N_Object_Declaration
4430 and then Analyzed
(Stmt
)
4431 and then Is_Finalizable_Transient
(Stmt
, N
)
4433 -- Do not process the node to be wrapped since it will be
4434 -- handled by the enclosing finalizer.
4436 and then Stmt
/= Related_Node
4439 Obj_Id
:= Defining_Identifier
(Stmt
);
4440 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4441 Desig_Typ
:= Obj_Typ
;
4443 Set_Is_Processed_Transient
(Obj_Id
);
4445 -- Handle access types
4447 if Is_Access_Type
(Desig_Typ
) then
4448 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4451 -- Create the necessary entities and declarations the first
4455 Fin_Decls
:= New_List
;
4457 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4462 -- Transient variables associated with subprogram calls need
4463 -- extra processing. These variables are usually created right
4464 -- before the call and finalized immediately after the call.
4465 -- If an exception occurs during the call, the clean up code
4466 -- is skipped due to the sudden change in control and the
4467 -- transient is never finalized.
4469 -- To handle this case, such variables are "exported" to the
4470 -- enclosing sequence of statements where their corresponding
4471 -- "hooks" are picked up by the finalization machinery.
4479 -- Step 1: Create an access type which provides a
4480 -- reference to the transient object. Generate:
4482 -- Ann : access [all] <Desig_Typ>;
4484 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4486 Insert_Action
(Stmt
,
4487 Make_Full_Type_Declaration
(Loc
,
4488 Defining_Identifier
=> Ptr_Id
,
4490 Make_Access_To_Object_Definition
(Loc
,
4492 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4493 Subtype_Indication
=>
4494 New_Reference_To
(Desig_Typ
, Loc
))));
4496 -- Step 2: Create a temporary which acts as a hook to
4497 -- the transient object. Generate:
4499 -- Temp : Ptr_Id := null;
4501 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4503 Insert_Action
(Stmt
,
4504 Make_Object_Declaration
(Loc
,
4505 Defining_Identifier
=> Temp_Id
,
4506 Object_Definition
=>
4507 New_Reference_To
(Ptr_Id
, Loc
)));
4509 -- Mark the temporary as a transient hook. This signals
4510 -- the machinery in Build_Finalizer to recognize this
4513 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4515 -- Step 3: Hook the transient object to the temporary
4517 if Is_Access_Type
(Obj_Typ
) then
4519 Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
4522 Make_Attribute_Reference
(Loc
,
4523 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
4524 Attribute_Name
=> Name_Unrestricted_Access
);
4528 -- Temp := Ptr_Id (Obj_Id);
4530 -- Temp := Obj_Id'Unrestricted_Access;
4532 Insert_After_And_Analyze
(Stmt
,
4533 Make_Assignment_Statement
(Loc
,
4534 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4535 Expression
=> Expr
));
4541 -- The transient object is about to be finalized by the clean
4542 -- up code following the subprogram call. In order to avoid
4543 -- double finalization, clear the hook.
4550 Make_Assignment_Statement
(Loc
,
4551 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4552 Expression
=> Make_Null
(Loc
)));
4556 -- [Deep_]Finalize (Obj_Ref);
4558 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
4560 if Is_Access_Type
(Obj_Typ
) then
4561 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4565 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4570 -- [Deep_]Finalize (Obj_Ref);
4574 -- if not Raised then
4577 -- (Enn, Get_Current_Excep.all.all);
4582 Make_Block_Statement
(Loc
,
4583 Handled_Statement_Sequence
=>
4584 Make_Handled_Sequence_Of_Statements
(Loc
,
4585 Statements
=> Stmts
,
4586 Exception_Handlers
=> New_List
(
4587 Build_Exception_Handler
(Fin_Data
))));
4589 -- The single raise statement must be inserted after all the
4590 -- finalization blocks, and we put everything into a wrapper
4591 -- block to clearly expose the construct to the back-end.
4593 if Present
(Prev_Fin
) then
4594 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4596 Insert_After_And_Analyze
(Last_Object
,
4597 Make_Block_Statement
(Loc
,
4598 Declarations
=> Fin_Decls
,
4599 Handled_Statement_Sequence
=>
4600 Make_Handled_Sequence_Of_Statements
(Loc
,
4601 Statements
=> New_List
(Fin_Block
))));
4603 Last_Fin
:= Fin_Block
;
4606 Prev_Fin
:= Fin_Block
;
4609 -- Terminate the scan after the last object has been processed to
4610 -- avoid touching unrelated code.
4612 if Stmt
= Last_Object
then
4620 -- if Raised and then not Abort then
4621 -- Raise_From_Controlled_Operation (E);
4625 and then Present
(Last_Fin
)
4627 Insert_After_And_Analyze
(Last_Fin
,
4628 Build_Raise_Statement
(Fin_Data
));
4630 end Process_Transient_Objects
;
4632 -- Start of processing for Insert_Actions_In_Scope_Around
4635 if No
(Before
) and then No
(After
) then
4640 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4641 First_Obj
: Node_Id
;
4646 -- If the node to be wrapped is the trigger of an asynchronous
4647 -- select, it is not part of a statement list. The actions must be
4648 -- inserted before the select itself, which is part of some list of
4649 -- statements. Note that the triggering alternative includes the
4650 -- triggering statement and an optional statement list. If the node
4651 -- to be wrapped is part of that list, the normal insertion applies.
4653 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4654 and then not Is_List_Member
(Node_To_Wrap
)
4656 Target
:= Parent
(Parent
(Node_To_Wrap
));
4661 First_Obj
:= Target
;
4664 -- Add all actions associated with a transient scope into the main
4665 -- tree. There are several scenarios here:
4667 -- +--- Before ----+ +----- After ---+
4668 -- 1) First_Obj ....... Target ........ Last_Obj
4670 -- 2) First_Obj ....... Target
4672 -- 3) Target ........ Last_Obj
4674 if Present
(Before
) then
4676 -- Flag declarations are inserted before the first object
4678 First_Obj
:= First
(Before
);
4680 Insert_List_Before
(Target
, Before
);
4683 if Present
(After
) then
4685 -- Finalization calls are inserted after the last object
4687 Last_Obj
:= Last
(After
);
4689 Insert_List_After
(Target
, After
);
4692 -- Check for transient controlled objects associated with Target and
4693 -- generate the appropriate finalization actions for them.
4695 Process_Transient_Objects
4696 (First_Object
=> First_Obj
,
4697 Last_Object
=> Last_Obj
,
4698 Related_Node
=> Target
);
4700 -- Reset the action lists
4702 if Present
(Before
) then
4703 Scope_Stack
.Table
(Scope_Stack
.Last
).
4704 Actions_To_Be_Wrapped_Before
:= No_List
;
4707 if Present
(After
) then
4708 Scope_Stack
.Table
(Scope_Stack
.Last
).
4709 Actions_To_Be_Wrapped_After
:= No_List
;
4712 end Insert_Actions_In_Scope_Around
;
4714 ------------------------------
4715 -- Is_Simple_Protected_Type --
4716 ------------------------------
4718 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4721 Is_Protected_Type
(T
)
4722 and then not Uses_Lock_Free
(T
)
4723 and then not Has_Entries
(T
)
4724 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4725 end Is_Simple_Protected_Type
;
4727 -----------------------
4728 -- Make_Adjust_Call --
4729 -----------------------
4731 function Make_Adjust_Call
4734 For_Parent
: Boolean := False) return Node_Id
4736 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4737 Adj_Id
: Entity_Id
:= Empty
;
4738 Ref
: Node_Id
:= Obj_Ref
;
4742 -- Recover the proper type which contains Deep_Adjust
4744 if Is_Class_Wide_Type
(Typ
) then
4745 Utyp
:= Root_Type
(Typ
);
4750 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4751 Set_Assignment_OK
(Ref
);
4753 -- Deal with non-tagged derivation of private views
4755 if Is_Untagged_Derivation
(Typ
) then
4756 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4757 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4758 Set_Assignment_OK
(Ref
);
4761 -- When dealing with the completion of a private type, use the base
4764 if Utyp
/= Base_Type
(Utyp
) then
4765 pragma Assert
(Is_Private_Type
(Typ
));
4767 Utyp
:= Base_Type
(Utyp
);
4768 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4771 -- Select the appropriate version of adjust
4774 if Has_Controlled_Component
(Utyp
) then
4775 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4778 -- Class-wide types, interfaces and types with controlled components
4780 elsif Is_Class_Wide_Type
(Typ
)
4781 or else Is_Interface
(Typ
)
4782 or else Has_Controlled_Component
(Utyp
)
4784 if Is_Tagged_Type
(Utyp
) then
4785 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4787 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
4790 -- Derivations from [Limited_]Controlled
4792 elsif Is_Controlled
(Utyp
) then
4793 if Has_Controlled_Component
(Utyp
) then
4794 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4796 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
4801 elsif Is_Tagged_Type
(Utyp
) then
4802 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4805 raise Program_Error
;
4808 if Present
(Adj_Id
) then
4810 -- If the object is unanalyzed, set its expected type for use in
4811 -- Convert_View in case an additional conversion is needed.
4814 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
4816 Set_Etype
(Ref
, Typ
);
4819 -- The object reference may need another conversion depending on the
4820 -- type of the formal and that of the actual.
4822 if not Is_Class_Wide_Type
(Typ
) then
4823 Ref
:= Convert_View
(Adj_Id
, Ref
);
4826 return Make_Call
(Loc
, Adj_Id
, New_Copy_Tree
(Ref
), For_Parent
);
4830 end Make_Adjust_Call
;
4832 ----------------------
4833 -- Make_Attach_Call --
4834 ----------------------
4836 function Make_Attach_Call
4838 Ptr_Typ
: Entity_Id
) return Node_Id
4840 pragma Assert
(VM_Target
/= No_VM
);
4842 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4845 Make_Procedure_Call_Statement
(Loc
,
4847 New_Reference_To
(RTE
(RE_Attach
), Loc
),
4848 Parameter_Associations
=> New_List
(
4849 New_Reference_To
(Finalization_Master
(Ptr_Typ
), Loc
),
4850 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4851 end Make_Attach_Call
;
4853 ----------------------
4854 -- Make_Detach_Call --
4855 ----------------------
4857 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
4858 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4862 Make_Procedure_Call_Statement
(Loc
,
4864 New_Reference_To
(RTE
(RE_Detach
), Loc
),
4865 Parameter_Associations
=> New_List
(
4866 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4867 end Make_Detach_Call
;
4875 Proc_Id
: Entity_Id
;
4877 For_Parent
: Boolean := False) return Node_Id
4879 Params
: constant List_Id
:= New_List
(Param
);
4882 -- When creating a call to Deep_Finalize for a _parent field of a
4883 -- derived type, disable the invocation of the nested Finalize by giving
4884 -- the corresponding flag a False value.
4887 Append_To
(Params
, New_Reference_To
(Standard_False
, Loc
));
4891 Make_Procedure_Call_Statement
(Loc
,
4892 Name
=> New_Reference_To
(Proc_Id
, Loc
),
4893 Parameter_Associations
=> Params
);
4896 --------------------------
4897 -- Make_Deep_Array_Body --
4898 --------------------------
4900 function Make_Deep_Array_Body
4901 (Prim
: Final_Primitives
;
4902 Typ
: Entity_Id
) return List_Id
4904 function Build_Adjust_Or_Finalize_Statements
4905 (Typ
: Entity_Id
) return List_Id
;
4906 -- Create the statements necessary to adjust or finalize an array of
4907 -- controlled elements. Generate:
4910 -- Abort : constant Boolean := Triggered_By_Abort;
4912 -- Abort : constant Boolean := False; -- no abort
4914 -- E : Exception_Occurrence;
4915 -- Raised : Boolean := False;
4918 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4919 -- ^-- in the finalization case
4921 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4923 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4927 -- if not Raised then
4929 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4936 -- if Raised and then not Abort then
4937 -- Raise_From_Controlled_Operation (E);
4941 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
4942 -- Create the statements necessary to initialize an array of controlled
4943 -- elements. Include a mechanism to carry out partial finalization if an
4944 -- exception occurs. Generate:
4947 -- Counter : Integer := 0;
4950 -- for J1 in V'Range (1) loop
4952 -- for JN in V'Range (N) loop
4954 -- [Deep_]Initialize (V (J1, ..., JN));
4956 -- Counter := Counter + 1;
4961 -- Abort : constant Boolean := Triggered_By_Abort;
4963 -- Abort : constant Boolean := False; -- no abort
4964 -- E : Exception_Occurence;
4965 -- Raised : Boolean := False;
4972 -- V'Length (N) - Counter;
4974 -- for F1 in reverse V'Range (1) loop
4976 -- for FN in reverse V'Range (N) loop
4977 -- if Counter > 0 then
4978 -- Counter := Counter - 1;
4981 -- [Deep_]Finalize (V (F1, ..., FN));
4985 -- if not Raised then
4987 -- Save_Occurrence (E,
4988 -- Get_Current_Excep.all.all);
4997 -- if Raised and then not Abort then
4998 -- Raise_From_Controlled_Operation (E);
5007 function New_References_To
5009 Loc
: Source_Ptr
) return List_Id
;
5010 -- Given a list of defining identifiers, return a list of references to
5011 -- the original identifiers, in the same order as they appear.
5013 -----------------------------------------
5014 -- Build_Adjust_Or_Finalize_Statements --
5015 -----------------------------------------
5017 function Build_Adjust_Or_Finalize_Statements
5018 (Typ
: Entity_Id
) return List_Id
5020 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5021 Index_List
: constant List_Id
:= New_List
;
5022 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5023 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5024 Finalizer_Decls
: List_Id
:= No_List
;
5025 Finalizer_Data
: Finalization_Exception_Data
;
5028 Core_Loop
: Node_Id
;
5031 Loop_Id
: Entity_Id
;
5034 Exceptions_OK
: constant Boolean :=
5035 not Restriction_Active
(No_Exception_Propagation
);
5037 procedure Build_Indices
;
5038 -- Generate the indices used in the dimension loops
5044 procedure Build_Indices
is
5046 -- Generate the following identifiers:
5047 -- Jnn - for initialization
5049 for Dim
in 1 .. Num_Dims
loop
5050 Append_To
(Index_List
,
5051 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5055 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5058 Finalizer_Decls
:= New_List
;
5061 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5064 Make_Indexed_Component
(Loc
,
5065 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5066 Expressions
=> New_References_To
(Index_List
, Loc
));
5067 Set_Etype
(Comp_Ref
, Comp_Typ
);
5070 -- [Deep_]Adjust (V (J1, ..., JN))
5072 if Prim
= Adjust_Case
then
5073 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5076 -- [Deep_]Finalize (V (J1, ..., JN))
5078 else pragma Assert
(Prim
= Finalize_Case
);
5079 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5082 -- Generate the block which houses the adjust or finalize call:
5084 -- <adjust or finalize call>; -- No_Exception_Propagation
5086 -- begin -- Exception handlers allowed
5087 -- <adjust or finalize call>
5091 -- if not Raised then
5093 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5097 if Exceptions_OK
then
5099 Make_Block_Statement
(Loc
,
5100 Handled_Statement_Sequence
=>
5101 Make_Handled_Sequence_Of_Statements
(Loc
,
5102 Statements
=> New_List
(Call
),
5103 Exception_Handlers
=> New_List
(
5104 Build_Exception_Handler
(Finalizer_Data
))));
5109 -- Generate the dimension loops starting from the innermost one
5111 -- for Jnn in [reverse] V'Range (Dim) loop
5115 J
:= Last
(Index_List
);
5117 while Present
(J
) and then Dim
> 0 loop
5123 Make_Loop_Statement
(Loc
,
5125 Make_Iteration_Scheme
(Loc
,
5126 Loop_Parameter_Specification
=>
5127 Make_Loop_Parameter_Specification
(Loc
,
5128 Defining_Identifier
=> Loop_Id
,
5129 Discrete_Subtype_Definition
=>
5130 Make_Attribute_Reference
(Loc
,
5131 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5132 Attribute_Name
=> Name_Range
,
5133 Expressions
=> New_List
(
5134 Make_Integer_Literal
(Loc
, Dim
))),
5136 Reverse_Present
=> Prim
= Finalize_Case
)),
5138 Statements
=> New_List
(Core_Loop
),
5139 End_Label
=> Empty
);
5144 -- Generate the block which contains the core loop, the declarations
5145 -- of the abort flag, the exception occurrence, the raised flag and
5146 -- the conditional raise:
5149 -- Abort : constant Boolean := Triggered_By_Abort;
5151 -- Abort : constant Boolean := False; -- no abort
5153 -- E : Exception_Occurrence;
5154 -- Raised : Boolean := False;
5159 -- if Raised and then not Abort then -- Expection handlers OK
5160 -- Raise_From_Controlled_Operation (E);
5164 Stmts
:= New_List
(Core_Loop
);
5166 if Exceptions_OK
then
5168 Build_Raise_Statement
(Finalizer_Data
));
5173 Make_Block_Statement
(Loc
,
5176 Handled_Statement_Sequence
=>
5177 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5178 end Build_Adjust_Or_Finalize_Statements
;
5180 ---------------------------------
5181 -- Build_Initialize_Statements --
5182 ---------------------------------
5184 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5185 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5186 Final_List
: constant List_Id
:= New_List
;
5187 Index_List
: constant List_Id
:= New_List
;
5188 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5189 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5190 Counter_Id
: Entity_Id
;
5194 Final_Block
: Node_Id
;
5195 Final_Loop
: Node_Id
;
5196 Finalizer_Data
: Finalization_Exception_Data
;
5197 Finalizer_Decls
: List_Id
:= No_List
;
5198 Init_Loop
: Node_Id
;
5203 Exceptions_OK
: constant Boolean :=
5204 not Restriction_Active
(No_Exception_Propagation
);
5206 function Build_Counter_Assignment
return Node_Id
;
5207 -- Generate the following assignment:
5208 -- Counter := V'Length (1) *
5210 -- V'Length (N) - Counter;
5212 function Build_Finalization_Call
return Node_Id
;
5213 -- Generate a deep finalization call for an array element
5215 procedure Build_Indices
;
5216 -- Generate the initialization and finalization indices used in the
5219 function Build_Initialization_Call
return Node_Id
;
5220 -- Generate a deep initialization call for an array element
5222 ------------------------------
5223 -- Build_Counter_Assignment --
5224 ------------------------------
5226 function Build_Counter_Assignment
return Node_Id
is
5231 -- Start from the first dimension and generate:
5236 Make_Attribute_Reference
(Loc
,
5237 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5238 Attribute_Name
=> Name_Length
,
5239 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5241 -- Process the rest of the dimensions, generate:
5242 -- Expr * V'Length (N)
5245 while Dim
<= Num_Dims
loop
5247 Make_Op_Multiply
(Loc
,
5250 Make_Attribute_Reference
(Loc
,
5251 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5252 Attribute_Name
=> Name_Length
,
5253 Expressions
=> New_List
(
5254 Make_Integer_Literal
(Loc
, Dim
))));
5260 -- Counter := Expr - Counter;
5263 Make_Assignment_Statement
(Loc
,
5264 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5266 Make_Op_Subtract
(Loc
,
5268 Right_Opnd
=> New_Reference_To
(Counter_Id
, Loc
)));
5269 end Build_Counter_Assignment
;
5271 -----------------------------
5272 -- Build_Finalization_Call --
5273 -----------------------------
5275 function Build_Finalization_Call
return Node_Id
is
5276 Comp_Ref
: constant Node_Id
:=
5277 Make_Indexed_Component
(Loc
,
5278 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5279 Expressions
=> New_References_To
(Final_List
, Loc
));
5282 Set_Etype
(Comp_Ref
, Comp_Typ
);
5285 -- [Deep_]Finalize (V);
5287 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5288 end Build_Finalization_Call
;
5294 procedure Build_Indices
is
5296 -- Generate the following identifiers:
5297 -- Jnn - for initialization
5298 -- Fnn - for finalization
5300 for Dim
in 1 .. Num_Dims
loop
5301 Append_To
(Index_List
,
5302 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5304 Append_To
(Final_List
,
5305 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5309 -------------------------------
5310 -- Build_Initialization_Call --
5311 -------------------------------
5313 function Build_Initialization_Call
return Node_Id
is
5314 Comp_Ref
: constant Node_Id
:=
5315 Make_Indexed_Component
(Loc
,
5316 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5317 Expressions
=> New_References_To
(Index_List
, Loc
));
5320 Set_Etype
(Comp_Ref
, Comp_Typ
);
5323 -- [Deep_]Initialize (V (J1, ..., JN));
5325 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5326 end Build_Initialization_Call
;
5328 -- Start of processing for Build_Initialize_Statements
5331 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5332 Finalizer_Decls
:= New_List
;
5335 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5337 -- Generate the block which houses the finalization call, the index
5338 -- guard and the handler which triggers Program_Error later on.
5340 -- if Counter > 0 then
5341 -- Counter := Counter - 1;
5343 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5345 -- begin -- Exceptions allowed
5346 -- [Deep_]Finalize (V (F1, ..., FN));
5349 -- if not Raised then
5351 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5356 if Exceptions_OK
then
5358 Make_Block_Statement
(Loc
,
5359 Handled_Statement_Sequence
=>
5360 Make_Handled_Sequence_Of_Statements
(Loc
,
5361 Statements
=> New_List
(Build_Finalization_Call
),
5362 Exception_Handlers
=> New_List
(
5363 Build_Exception_Handler
(Finalizer_Data
))));
5365 Fin_Stmt
:= Build_Finalization_Call
;
5368 -- This is the core of the loop, the dimension iterators are added
5369 -- one by one in reverse.
5372 Make_If_Statement
(Loc
,
5375 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5376 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5378 Then_Statements
=> New_List
(
5379 Make_Assignment_Statement
(Loc
,
5380 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5382 Make_Op_Subtract
(Loc
,
5383 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5384 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5386 Else_Statements
=> New_List
(Fin_Stmt
));
5388 -- Generate all finalization loops starting from the innermost
5391 -- for Fnn in reverse V'Range (Dim) loop
5395 F
:= Last
(Final_List
);
5397 while Present
(F
) and then Dim
> 0 loop
5403 Make_Loop_Statement
(Loc
,
5405 Make_Iteration_Scheme
(Loc
,
5406 Loop_Parameter_Specification
=>
5407 Make_Loop_Parameter_Specification
(Loc
,
5408 Defining_Identifier
=> Loop_Id
,
5409 Discrete_Subtype_Definition
=>
5410 Make_Attribute_Reference
(Loc
,
5411 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5412 Attribute_Name
=> Name_Range
,
5413 Expressions
=> New_List
(
5414 Make_Integer_Literal
(Loc
, Dim
))),
5416 Reverse_Present
=> True)),
5418 Statements
=> New_List
(Final_Loop
),
5419 End_Label
=> Empty
);
5424 -- Generate the block which contains the finalization loops, the
5425 -- declarations of the abort flag, the exception occurrence, the
5426 -- raised flag and the conditional raise.
5429 -- Abort : constant Boolean := Triggered_By_Abort;
5431 -- Abort : constant Boolean := False; -- no abort
5433 -- E : Exception_Occurrence;
5434 -- Raised : Boolean := False;
5440 -- V'Length (N) - Counter;
5444 -- if Raised and then not Abort then -- Exception handlers OK
5445 -- Raise_From_Controlled_Operation (E);
5448 -- raise; -- Exception handlers OK
5451 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5453 if Exceptions_OK
then
5455 Build_Raise_Statement
(Finalizer_Data
));
5456 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5460 Make_Block_Statement
(Loc
,
5463 Handled_Statement_Sequence
=>
5464 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5466 -- Generate the block which contains the initialization call and
5467 -- the partial finalization code.
5470 -- [Deep_]Initialize (V (J1, ..., JN));
5472 -- Counter := Counter + 1;
5476 -- <finalization code>
5480 Make_Block_Statement
(Loc
,
5481 Handled_Statement_Sequence
=>
5482 Make_Handled_Sequence_Of_Statements
(Loc
,
5483 Statements
=> New_List
(Build_Initialization_Call
),
5484 Exception_Handlers
=> New_List
(
5485 Make_Exception_Handler
(Loc
,
5486 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5487 Statements
=> New_List
(Final_Block
)))));
5489 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5490 Make_Assignment_Statement
(Loc
,
5491 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5494 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5495 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5497 -- Generate all initialization loops starting from the innermost
5500 -- for Jnn in V'Range (Dim) loop
5504 J
:= Last
(Index_List
);
5506 while Present
(J
) and then Dim
> 0 loop
5512 Make_Loop_Statement
(Loc
,
5514 Make_Iteration_Scheme
(Loc
,
5515 Loop_Parameter_Specification
=>
5516 Make_Loop_Parameter_Specification
(Loc
,
5517 Defining_Identifier
=> Loop_Id
,
5518 Discrete_Subtype_Definition
=>
5519 Make_Attribute_Reference
(Loc
,
5520 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5521 Attribute_Name
=> Name_Range
,
5522 Expressions
=> New_List
(
5523 Make_Integer_Literal
(Loc
, Dim
))))),
5525 Statements
=> New_List
(Init_Loop
),
5526 End_Label
=> Empty
);
5531 -- Generate the block which contains the counter variable and the
5532 -- initialization loops.
5535 -- Counter : Integer := 0;
5542 Make_Block_Statement
(Loc
,
5543 Declarations
=> New_List
(
5544 Make_Object_Declaration
(Loc
,
5545 Defining_Identifier
=> Counter_Id
,
5546 Object_Definition
=>
5547 New_Reference_To
(Standard_Integer
, Loc
),
5548 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5550 Handled_Statement_Sequence
=>
5551 Make_Handled_Sequence_Of_Statements
(Loc
,
5552 Statements
=> New_List
(Init_Loop
))));
5553 end Build_Initialize_Statements
;
5555 -----------------------
5556 -- New_References_To --
5557 -----------------------
5559 function New_References_To
5561 Loc
: Source_Ptr
) return List_Id
5563 Refs
: constant List_Id
:= New_List
;
5568 while Present
(Id
) loop
5569 Append_To
(Refs
, New_Reference_To
(Id
, Loc
));
5574 end New_References_To
;
5576 -- Start of processing for Make_Deep_Array_Body
5580 when Address_Case
=>
5581 return Make_Finalize_Address_Stmts
(Typ
);
5585 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5587 when Initialize_Case
=>
5588 return Build_Initialize_Statements
(Typ
);
5590 end Make_Deep_Array_Body
;
5592 --------------------
5593 -- Make_Deep_Proc --
5594 --------------------
5596 function Make_Deep_Proc
5597 (Prim
: Final_Primitives
;
5599 Stmts
: List_Id
) return Entity_Id
5601 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5603 Proc_Id
: Entity_Id
;
5606 -- Create the object formal, generate:
5607 -- V : System.Address
5609 if Prim
= Address_Case
then
5610 Formals
:= New_List
(
5611 Make_Parameter_Specification
(Loc
,
5612 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5613 Parameter_Type
=> New_Reference_To
(RTE
(RE_Address
), Loc
)));
5620 Formals
:= New_List
(
5621 Make_Parameter_Specification
(Loc
,
5622 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5624 Out_Present
=> True,
5625 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5627 -- F : Boolean := True
5629 if Prim
= Adjust_Case
5630 or else Prim
= Finalize_Case
5633 Make_Parameter_Specification
(Loc
,
5634 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5636 New_Reference_To
(Standard_Boolean
, Loc
),
5638 New_Reference_To
(Standard_True
, Loc
)));
5643 Make_Defining_Identifier
(Loc
,
5644 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5647 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5650 -- exception -- Finalize and Adjust cases only
5651 -- raise Program_Error;
5652 -- end Deep_Initialize / Adjust / Finalize;
5656 -- procedure Finalize_Address (V : System.Address) is
5659 -- end Finalize_Address;
5662 Make_Subprogram_Body
(Loc
,
5664 Make_Procedure_Specification
(Loc
,
5665 Defining_Unit_Name
=> Proc_Id
,
5666 Parameter_Specifications
=> Formals
),
5668 Declarations
=> Empty_List
,
5670 Handled_Statement_Sequence
=>
5671 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5676 ---------------------------
5677 -- Make_Deep_Record_Body --
5678 ---------------------------
5680 function Make_Deep_Record_Body
5681 (Prim
: Final_Primitives
;
5683 Is_Local
: Boolean := False) return List_Id
5685 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5686 -- Build the statements necessary to adjust a record type. The type may
5687 -- have discriminants and contain variant parts. Generate:
5691 -- [Deep_]Adjust (V.Comp_1);
5693 -- when Id : others =>
5694 -- if not Raised then
5696 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5701 -- [Deep_]Adjust (V.Comp_N);
5703 -- when Id : others =>
5704 -- if not Raised then
5706 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5711 -- Deep_Adjust (V._parent, False); -- If applicable
5713 -- when Id : others =>
5714 -- if not Raised then
5716 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5722 -- Adjust (V); -- If applicable
5725 -- if not Raised then
5727 -- Save_Occurence (E, Get_Current_Excep.all.all);
5732 -- if Raised and then not Abort then
5733 -- Raise_From_Controlled_Operation (E);
5737 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5738 -- Build the statements necessary to finalize a record type. The type
5739 -- may have discriminants and contain variant parts. Generate:
5742 -- Abort : constant Boolean := Triggered_By_Abort;
5744 -- Abort : constant Boolean := False; -- no abort
5745 -- E : Exception_Occurence;
5746 -- Raised : Boolean := False;
5751 -- Finalize (V); -- If applicable
5754 -- if not Raised then
5756 -- Save_Occurence (E, Get_Current_Excep.all.all);
5761 -- case Variant_1 is
5763 -- case State_Counter_N => -- If Is_Local is enabled
5773 -- <<LN>> -- If Is_Local is enabled
5775 -- [Deep_]Finalize (V.Comp_N);
5778 -- if not Raised then
5780 -- Save_Occurence (E, Get_Current_Excep.all.all);
5786 -- [Deep_]Finalize (V.Comp_1);
5789 -- if not Raised then
5791 -- Save_Occurence (E, Get_Current_Excep.all.all);
5797 -- case State_Counter_1 => -- If Is_Local is enabled
5803 -- Deep_Finalize (V._parent, False); -- If applicable
5805 -- when Id : others =>
5806 -- if not Raised then
5808 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5812 -- if Raised and then not Abort then
5813 -- Raise_From_Controlled_Operation (E);
5817 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
5818 -- Given a derived tagged type Typ, traverse all components, find field
5819 -- _parent and return its type.
5821 procedure Preprocess_Components
5823 Num_Comps
: out Int
;
5824 Has_POC
: out Boolean);
5825 -- Examine all components in component list Comps, count all controlled
5826 -- components and determine whether at least one of them is per-object
5827 -- constrained. Component _parent is always skipped.
5829 -----------------------------
5830 -- Build_Adjust_Statements --
5831 -----------------------------
5833 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
5834 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5835 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
5836 Bod_Stmts
: List_Id
;
5837 Finalizer_Data
: Finalization_Exception_Data
;
5838 Finalizer_Decls
: List_Id
:= No_List
;
5842 Exceptions_OK
: constant Boolean :=
5843 not Restriction_Active
(No_Exception_Propagation
);
5845 function Process_Component_List_For_Adjust
5846 (Comps
: Node_Id
) return List_Id
;
5847 -- Build all necessary adjust statements for a single component list
5849 ---------------------------------------
5850 -- Process_Component_List_For_Adjust --
5851 ---------------------------------------
5853 function Process_Component_List_For_Adjust
5854 (Comps
: Node_Id
) return List_Id
5856 Stmts
: constant List_Id
:= New_List
;
5858 Decl_Id
: Entity_Id
;
5859 Decl_Typ
: Entity_Id
;
5863 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
5864 -- Process the declaration of a single controlled component
5866 ----------------------------------
5867 -- Process_Component_For_Adjust --
5868 ----------------------------------
5870 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
5871 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
5872 Typ
: constant Entity_Id
:= Etype
(Id
);
5877 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
5879 -- begin -- Exception handlers allowed
5880 -- [Deep_]Adjust (V.Id);
5883 -- if not Raised then
5885 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5892 Make_Selected_Component
(Loc
,
5893 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5894 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
5897 if Exceptions_OK
then
5899 Make_Block_Statement
(Loc
,
5900 Handled_Statement_Sequence
=>
5901 Make_Handled_Sequence_Of_Statements
(Loc
,
5902 Statements
=> New_List
(Adj_Stmt
),
5903 Exception_Handlers
=> New_List
(
5904 Build_Exception_Handler
(Finalizer_Data
))));
5907 Append_To
(Stmts
, Adj_Stmt
);
5908 end Process_Component_For_Adjust
;
5910 -- Start of processing for Process_Component_List_For_Adjust
5913 -- Perform an initial check, determine the number of controlled
5914 -- components in the current list and whether at least one of them
5915 -- is per-object constrained.
5917 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
5919 -- The processing in this routine is done in the following order:
5920 -- 1) Regular components
5921 -- 2) Per-object constrained components
5924 if Num_Comps
> 0 then
5926 -- Process all regular components in order of declarations
5928 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5929 while Present
(Decl
) loop
5930 Decl_Id
:= Defining_Identifier
(Decl
);
5931 Decl_Typ
:= Etype
(Decl_Id
);
5933 -- Skip _parent as well as per-object constrained components
5935 if Chars
(Decl_Id
) /= Name_uParent
5936 and then Needs_Finalization
(Decl_Typ
)
5938 if Has_Access_Constraint
(Decl_Id
)
5939 and then No
(Expression
(Decl
))
5943 Process_Component_For_Adjust
(Decl
);
5947 Next_Non_Pragma
(Decl
);
5950 -- Process all per-object constrained components in order of
5954 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5955 while Present
(Decl
) loop
5956 Decl_Id
:= Defining_Identifier
(Decl
);
5957 Decl_Typ
:= Etype
(Decl_Id
);
5961 if Chars
(Decl_Id
) /= Name_uParent
5962 and then Needs_Finalization
(Decl_Typ
)
5963 and then Has_Access_Constraint
(Decl_Id
)
5964 and then No
(Expression
(Decl
))
5966 Process_Component_For_Adjust
(Decl
);
5969 Next_Non_Pragma
(Decl
);
5974 -- Process all variants, if any
5977 if Present
(Variant_Part
(Comps
)) then
5979 Var_Alts
: constant List_Id
:= New_List
;
5983 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
5984 while Present
(Var
) loop
5987 -- when <discrete choices> =>
5988 -- <adjust statements>
5990 Append_To
(Var_Alts
,
5991 Make_Case_Statement_Alternative
(Loc
,
5993 New_Copy_List
(Discrete_Choices
(Var
)),
5995 Process_Component_List_For_Adjust
(
5996 Component_List
(Var
))));
5998 Next_Non_Pragma
(Var
);
6002 -- case V.<discriminant> is
6003 -- when <discrete choices 1> =>
6004 -- <adjust statements 1>
6006 -- when <discrete choices N> =>
6007 -- <adjust statements N>
6011 Make_Case_Statement
(Loc
,
6013 Make_Selected_Component
(Loc
,
6014 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6016 Make_Identifier
(Loc
,
6017 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6018 Alternatives
=> Var_Alts
);
6022 -- Add the variant case statement to the list of statements
6024 if Present
(Var_Case
) then
6025 Append_To
(Stmts
, Var_Case
);
6028 -- If the component list did not have any controlled components
6029 -- nor variants, return null.
6031 if Is_Empty_List
(Stmts
) then
6032 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6036 end Process_Component_List_For_Adjust
;
6038 -- Start of processing for Build_Adjust_Statements
6041 Finalizer_Decls
:= New_List
;
6042 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6044 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6045 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6050 -- Create an adjust sequence for all record components
6052 if Present
(Component_List
(Rec_Def
)) then
6054 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6057 -- A derived record type must adjust all inherited components. This
6058 -- action poses the following problem:
6060 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6065 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6067 -- Deep_Adjust (Obj._parent);
6072 -- Adjusting the derived type will invoke Adjust of the parent and
6073 -- then that of the derived type. This is undesirable because both
6074 -- routines may modify shared components. Only the Adjust of the
6075 -- derived type should be invoked.
6077 -- To prevent this double adjustment of shared components,
6078 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6080 -- procedure Deep_Adjust
6081 -- (Obj : in out Some_Type;
6082 -- Flag : Boolean := True)
6090 -- When Deep_Adjust is invokes for field _parent, a value of False is
6091 -- provided for the flag:
6093 -- Deep_Adjust (Obj._parent, False);
6095 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6097 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6102 if Needs_Finalization
(Par_Typ
) then
6106 Make_Selected_Component
(Loc
,
6107 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6109 Make_Identifier
(Loc
, Name_uParent
)),
6111 For_Parent
=> True);
6114 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6116 -- begin -- Exceptions OK
6117 -- Deep_Adjust (V._parent, False);
6119 -- when Id : others =>
6120 -- if not Raised then
6122 -- Save_Occurrence (E,
6123 -- Get_Current_Excep.all.all);
6127 if Present
(Call
) then
6130 if Exceptions_OK
then
6132 Make_Block_Statement
(Loc
,
6133 Handled_Statement_Sequence
=>
6134 Make_Handled_Sequence_Of_Statements
(Loc
,
6135 Statements
=> New_List
(Adj_Stmt
),
6136 Exception_Handlers
=> New_List
(
6137 Build_Exception_Handler
(Finalizer_Data
))));
6140 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6146 -- Adjust the object. This action must be performed last after all
6147 -- components have been adjusted.
6149 if Is_Controlled
(Typ
) then
6155 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6159 -- Adjust (V); -- No_Exception_Propagation
6161 -- begin -- Exception handlers allowed
6165 -- if not Raised then
6167 -- Save_Occurrence (E,
6168 -- Get_Current_Excep.all.all);
6173 if Present
(Proc
) then
6175 Make_Procedure_Call_Statement
(Loc
,
6176 Name
=> New_Reference_To
(Proc
, Loc
),
6177 Parameter_Associations
=> New_List
(
6178 Make_Identifier
(Loc
, Name_V
)));
6180 if Exceptions_OK
then
6182 Make_Block_Statement
(Loc
,
6183 Handled_Statement_Sequence
=>
6184 Make_Handled_Sequence_Of_Statements
(Loc
,
6185 Statements
=> New_List
(Adj_Stmt
),
6186 Exception_Handlers
=> New_List
(
6187 Build_Exception_Handler
6188 (Finalizer_Data
))));
6191 Append_To
(Bod_Stmts
,
6192 Make_If_Statement
(Loc
,
6193 Condition
=> Make_Identifier
(Loc
, Name_F
),
6194 Then_Statements
=> New_List
(Adj_Stmt
)));
6199 -- At this point either all adjustment statements have been generated
6200 -- or the type is not controlled.
6202 if Is_Empty_List
(Bod_Stmts
) then
6203 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6209 -- Abort : constant Boolean := Triggered_By_Abort;
6211 -- Abort : constant Boolean := False; -- no abort
6213 -- E : Exception_Occurence;
6214 -- Raised : Boolean := False;
6217 -- <adjust statements>
6219 -- if Raised and then not Abort then
6220 -- Raise_From_Controlled_Operation (E);
6225 if Exceptions_OK
then
6226 Append_To
(Bod_Stmts
,
6227 Build_Raise_Statement
(Finalizer_Data
));
6232 Make_Block_Statement
(Loc
,
6235 Handled_Statement_Sequence
=>
6236 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6238 end Build_Adjust_Statements
;
6240 -------------------------------
6241 -- Build_Finalize_Statements --
6242 -------------------------------
6244 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6245 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6246 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6247 Bod_Stmts
: List_Id
;
6249 Finalizer_Data
: Finalization_Exception_Data
;
6250 Finalizer_Decls
: List_Id
:= No_List
;
6254 Exceptions_OK
: constant Boolean :=
6255 not Restriction_Active
(No_Exception_Propagation
);
6257 function Process_Component_List_For_Finalize
6258 (Comps
: Node_Id
) return List_Id
;
6259 -- Build all necessary finalization statements for a single component
6260 -- list. The statements may include a jump circuitry if flag Is_Local
6263 -----------------------------------------
6264 -- Process_Component_List_For_Finalize --
6265 -----------------------------------------
6267 function Process_Component_List_For_Finalize
6268 (Comps
: Node_Id
) return List_Id
6271 Counter_Id
: Entity_Id
;
6273 Decl_Id
: Entity_Id
;
6274 Decl_Typ
: Entity_Id
;
6277 Jump_Block
: Node_Id
;
6279 Label_Id
: Entity_Id
;
6283 procedure Process_Component_For_Finalize
6288 -- Process the declaration of a single controlled component. If
6289 -- flag Is_Local is enabled, create the corresponding label and
6290 -- jump circuitry. Alts is the list of case alternatives, Decls
6291 -- is the top level declaration list where labels are declared
6292 -- and Stmts is the list of finalization actions.
6294 ------------------------------------
6295 -- Process_Component_For_Finalize --
6296 ------------------------------------
6298 procedure Process_Component_For_Finalize
6304 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6305 Typ
: constant Entity_Id
:= Etype
(Id
);
6312 Label_Id
: Entity_Id
;
6319 Make_Identifier
(Loc
,
6320 Chars
=> New_External_Name
('L', Num_Comps
));
6321 Set_Entity
(Label_Id
,
6322 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6323 Label
:= Make_Label
(Loc
, Label_Id
);
6326 Make_Implicit_Label_Declaration
(Loc
,
6327 Defining_Identifier
=> Entity
(Label_Id
),
6328 Label_Construct
=> Label
));
6335 Make_Case_Statement_Alternative
(Loc
,
6336 Discrete_Choices
=> New_List
(
6337 Make_Integer_Literal
(Loc
, Num_Comps
)),
6339 Statements
=> New_List
(
6340 Make_Goto_Statement
(Loc
,
6342 New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6347 Append_To
(Stmts
, Label
);
6349 -- Decrease the number of components to be processed.
6350 -- This action yields a new Label_Id in future calls.
6352 Num_Comps
:= Num_Comps
- 1;
6357 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6359 -- begin -- Exception handlers allowed
6360 -- [Deep_]Finalize (V.Id);
6363 -- if not Raised then
6365 -- Save_Occurrence (E,
6366 -- Get_Current_Excep.all.all);
6373 Make_Selected_Component
(Loc
,
6374 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6375 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6378 if not Restriction_Active
(No_Exception_Propagation
) then
6380 Make_Block_Statement
(Loc
,
6381 Handled_Statement_Sequence
=>
6382 Make_Handled_Sequence_Of_Statements
(Loc
,
6383 Statements
=> New_List
(Fin_Stmt
),
6384 Exception_Handlers
=> New_List
(
6385 Build_Exception_Handler
(Finalizer_Data
))));
6388 Append_To
(Stmts
, Fin_Stmt
);
6389 end Process_Component_For_Finalize
;
6391 -- Start of processing for Process_Component_List_For_Finalize
6394 -- Perform an initial check, look for controlled and per-object
6395 -- constrained components.
6397 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6399 -- Create a state counter to service the current component list.
6400 -- This step is performed before the variants are inspected in
6401 -- order to generate the same state counter names as those from
6402 -- Build_Initialize_Statements.
6407 Counter
:= Counter
+ 1;
6410 Make_Defining_Identifier
(Loc
,
6411 Chars
=> New_External_Name
('C', Counter
));
6414 -- Process the component in the following order:
6416 -- 2) Per-object constrained components
6417 -- 3) Regular components
6419 -- Start with the variant parts
6422 if Present
(Variant_Part
(Comps
)) then
6424 Var_Alts
: constant List_Id
:= New_List
;
6428 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6429 while Present
(Var
) loop
6432 -- when <discrete choices> =>
6433 -- <finalize statements>
6435 Append_To
(Var_Alts
,
6436 Make_Case_Statement_Alternative
(Loc
,
6438 New_Copy_List
(Discrete_Choices
(Var
)),
6440 Process_Component_List_For_Finalize
(
6441 Component_List
(Var
))));
6443 Next_Non_Pragma
(Var
);
6447 -- case V.<discriminant> is
6448 -- when <discrete choices 1> =>
6449 -- <finalize statements 1>
6451 -- when <discrete choices N> =>
6452 -- <finalize statements N>
6456 Make_Case_Statement
(Loc
,
6458 Make_Selected_Component
(Loc
,
6459 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6461 Make_Identifier
(Loc
,
6462 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6463 Alternatives
=> Var_Alts
);
6467 -- The current component list does not have a single controlled
6468 -- component, however it may contain variants. Return the case
6469 -- statement for the variants or nothing.
6471 if Num_Comps
= 0 then
6472 if Present
(Var_Case
) then
6473 return New_List
(Var_Case
);
6475 return New_List
(Make_Null_Statement
(Loc
));
6479 -- Prepare all lists
6485 -- Process all per-object constrained components in reverse order
6488 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6489 while Present
(Decl
) loop
6490 Decl_Id
:= Defining_Identifier
(Decl
);
6491 Decl_Typ
:= Etype
(Decl_Id
);
6495 if Chars
(Decl_Id
) /= Name_uParent
6496 and then Needs_Finalization
(Decl_Typ
)
6497 and then Has_Access_Constraint
(Decl_Id
)
6498 and then No
(Expression
(Decl
))
6500 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6503 Prev_Non_Pragma
(Decl
);
6507 -- Process the rest of the components in reverse order
6509 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6510 while Present
(Decl
) loop
6511 Decl_Id
:= Defining_Identifier
(Decl
);
6512 Decl_Typ
:= Etype
(Decl_Id
);
6516 if Chars
(Decl_Id
) /= Name_uParent
6517 and then Needs_Finalization
(Decl_Typ
)
6519 -- Skip per-object constrained components since they were
6520 -- handled in the above step.
6522 if Has_Access_Constraint
(Decl_Id
)
6523 and then No
(Expression
(Decl
))
6527 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6531 Prev_Non_Pragma
(Decl
);
6536 -- LN : label; -- If Is_Local is enabled
6541 -- case CounterX is .
6551 -- <<LN>> -- If Is_Local is enabled
6553 -- [Deep_]Finalize (V.CompY);
6555 -- when Id : others =>
6556 -- if not Raised then
6558 -- Save_Occurrence (E,
6559 -- Get_Current_Excep.all.all);
6563 -- <<L0>> -- If Is_Local is enabled
6568 -- Add the declaration of default jump location L0, its
6569 -- corresponding alternative and its place in the statements.
6571 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6572 Set_Entity
(Label_Id
,
6573 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6574 Label
:= Make_Label
(Loc
, Label_Id
);
6576 Append_To
(Decls
, -- declaration
6577 Make_Implicit_Label_Declaration
(Loc
,
6578 Defining_Identifier
=> Entity
(Label_Id
),
6579 Label_Construct
=> Label
));
6581 Append_To
(Alts
, -- alternative
6582 Make_Case_Statement_Alternative
(Loc
,
6583 Discrete_Choices
=> New_List
(
6584 Make_Others_Choice
(Loc
)),
6586 Statements
=> New_List
(
6587 Make_Goto_Statement
(Loc
,
6588 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6590 Append_To
(Stmts
, Label
); -- statement
6592 -- Create the jump block
6595 Make_Case_Statement
(Loc
,
6596 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6597 Alternatives
=> Alts
));
6601 Make_Block_Statement
(Loc
,
6602 Declarations
=> Decls
,
6603 Handled_Statement_Sequence
=>
6604 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6606 if Present
(Var_Case
) then
6607 return New_List
(Var_Case
, Jump_Block
);
6609 return New_List
(Jump_Block
);
6611 end Process_Component_List_For_Finalize
;
6613 -- Start of processing for Build_Finalize_Statements
6616 Finalizer_Decls
:= New_List
;
6617 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6619 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6620 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6625 -- Create a finalization sequence for all record components
6627 if Present
(Component_List
(Rec_Def
)) then
6629 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6632 -- A derived record type must finalize all inherited components. This
6633 -- action poses the following problem:
6635 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6640 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6642 -- Deep_Finalize (Obj._parent);
6647 -- Finalizing the derived type will invoke Finalize of the parent and
6648 -- then that of the derived type. This is undesirable because both
6649 -- routines may modify shared components. Only the Finalize of the
6650 -- derived type should be invoked.
6652 -- To prevent this double adjustment of shared components,
6653 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6655 -- procedure Deep_Finalize
6656 -- (Obj : in out Some_Type;
6657 -- Flag : Boolean := True)
6665 -- When Deep_Finalize is invokes for field _parent, a value of False
6666 -- is provided for the flag:
6668 -- Deep_Finalize (Obj._parent, False);
6670 if Is_Tagged_Type
(Typ
)
6671 and then Is_Derived_Type
(Typ
)
6674 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6679 if Needs_Finalization
(Par_Typ
) then
6683 Make_Selected_Component
(Loc
,
6684 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6686 Make_Identifier
(Loc
, Name_uParent
)),
6688 For_Parent
=> True);
6691 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6693 -- begin -- Exceptions OK
6694 -- Deep_Finalize (V._parent, False);
6696 -- when Id : others =>
6697 -- if not Raised then
6699 -- Save_Occurrence (E,
6700 -- Get_Current_Excep.all.all);
6704 if Present
(Call
) then
6707 if Exceptions_OK
then
6709 Make_Block_Statement
(Loc
,
6710 Handled_Statement_Sequence
=>
6711 Make_Handled_Sequence_Of_Statements
(Loc
,
6712 Statements
=> New_List
(Fin_Stmt
),
6713 Exception_Handlers
=> New_List
(
6714 Build_Exception_Handler
6715 (Finalizer_Data
))));
6718 Append_To
(Bod_Stmts
, Fin_Stmt
);
6724 -- Finalize the object. This action must be performed first before
6725 -- all components have been finalized.
6727 if Is_Controlled
(Typ
)
6728 and then not Is_Local
6735 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6739 -- Finalize (V); -- No_Exception_Propagation
6745 -- if not Raised then
6747 -- Save_Occurrence (E,
6748 -- Get_Current_Excep.all.all);
6753 if Present
(Proc
) then
6755 Make_Procedure_Call_Statement
(Loc
,
6756 Name
=> New_Reference_To
(Proc
, Loc
),
6757 Parameter_Associations
=> New_List
(
6758 Make_Identifier
(Loc
, Name_V
)));
6760 if Exceptions_OK
then
6762 Make_Block_Statement
(Loc
,
6763 Handled_Statement_Sequence
=>
6764 Make_Handled_Sequence_Of_Statements
(Loc
,
6765 Statements
=> New_List
(Fin_Stmt
),
6766 Exception_Handlers
=> New_List
(
6767 Build_Exception_Handler
6768 (Finalizer_Data
))));
6771 Prepend_To
(Bod_Stmts
,
6772 Make_If_Statement
(Loc
,
6773 Condition
=> Make_Identifier
(Loc
, Name_F
),
6774 Then_Statements
=> New_List
(Fin_Stmt
)));
6779 -- At this point either all finalization statements have been
6780 -- generated or the type is not controlled.
6782 if No
(Bod_Stmts
) then
6783 return New_List
(Make_Null_Statement
(Loc
));
6787 -- Abort : constant Boolean := Triggered_By_Abort;
6789 -- Abort : constant Boolean := False; -- no abort
6791 -- E : Exception_Occurence;
6792 -- Raised : Boolean := False;
6795 -- <finalize statements>
6797 -- if Raised and then not Abort then
6798 -- Raise_From_Controlled_Operation (E);
6803 if Exceptions_OK
then
6804 Append_To
(Bod_Stmts
,
6805 Build_Raise_Statement
(Finalizer_Data
));
6810 Make_Block_Statement
(Loc
,
6813 Handled_Statement_Sequence
=>
6814 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6816 end Build_Finalize_Statements
;
6818 -----------------------
6819 -- Parent_Field_Type --
6820 -----------------------
6822 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
6826 Field
:= First_Entity
(Typ
);
6827 while Present
(Field
) loop
6828 if Chars
(Field
) = Name_uParent
then
6829 return Etype
(Field
);
6832 Next_Entity
(Field
);
6835 -- A derived tagged type should always have a parent field
6837 raise Program_Error
;
6838 end Parent_Field_Type
;
6840 ---------------------------
6841 -- Preprocess_Components --
6842 ---------------------------
6844 procedure Preprocess_Components
6846 Num_Comps
: out Int
;
6847 Has_POC
: out Boolean)
6857 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6858 while Present
(Decl
) loop
6859 Id
:= Defining_Identifier
(Decl
);
6862 -- Skip field _parent
6864 if Chars
(Id
) /= Name_uParent
6865 and then Needs_Finalization
(Typ
)
6867 Num_Comps
:= Num_Comps
+ 1;
6869 if Has_Access_Constraint
(Id
)
6870 and then No
(Expression
(Decl
))
6876 Next_Non_Pragma
(Decl
);
6878 end Preprocess_Components
;
6880 -- Start of processing for Make_Deep_Record_Body
6884 when Address_Case
=>
6885 return Make_Finalize_Address_Stmts
(Typ
);
6888 return Build_Adjust_Statements
(Typ
);
6890 when Finalize_Case
=>
6891 return Build_Finalize_Statements
(Typ
);
6893 when Initialize_Case
=>
6895 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6898 if Is_Controlled
(Typ
) then
6900 Make_Procedure_Call_Statement
(Loc
,
6903 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
6904 Parameter_Associations
=> New_List
(
6905 Make_Identifier
(Loc
, Name_V
))));
6911 end Make_Deep_Record_Body
;
6913 ----------------------
6914 -- Make_Final_Call --
6915 ----------------------
6917 function Make_Final_Call
6920 For_Parent
: Boolean := False) return Node_Id
6922 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6924 Fin_Id
: Entity_Id
:= Empty
;
6929 -- Recover the proper type which contains [Deep_]Finalize
6931 if Is_Class_Wide_Type
(Typ
) then
6932 Utyp
:= Root_Type
(Typ
);
6936 elsif Is_Concurrent_Type
(Typ
) then
6937 Utyp
:= Corresponding_Record_Type
(Typ
);
6939 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
6941 elsif Is_Private_Type
(Typ
)
6942 and then Present
(Full_View
(Typ
))
6943 and then Is_Concurrent_Type
(Full_View
(Typ
))
6945 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
6947 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
6955 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6956 Set_Assignment_OK
(Ref
);
6958 -- Deal with non-tagged derivation of private views. If the parent type
6959 -- is a protected type, Deep_Finalize is found on the corresponding
6960 -- record of the ancestor.
6962 if Is_Untagged_Derivation
(Typ
) then
6963 if Is_Protected_Type
(Typ
) then
6964 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
6966 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6968 if Is_Protected_Type
(Utyp
) then
6969 Utyp
:= Corresponding_Record_Type
(Utyp
);
6973 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6974 Set_Assignment_OK
(Ref
);
6977 -- Deal with derived private types which do not inherit primitives from
6978 -- their parents. In this case, [Deep_]Finalize can be found in the full
6979 -- view of the parent type.
6981 if Is_Tagged_Type
(Utyp
)
6982 and then Is_Derived_Type
(Utyp
)
6983 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
6984 and then Is_Private_Type
(Etype
(Utyp
))
6985 and then Present
(Full_View
(Etype
(Utyp
)))
6987 Utyp
:= Full_View
(Etype
(Utyp
));
6988 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6989 Set_Assignment_OK
(Ref
);
6992 -- When dealing with the completion of a private type, use the base type
6995 if Utyp
/= Base_Type
(Utyp
) then
6996 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
6998 Utyp
:= Base_Type
(Utyp
);
6999 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7000 Set_Assignment_OK
(Ref
);
7003 -- Select the appropriate version of Finalize
7006 if Has_Controlled_Component
(Utyp
) then
7007 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7010 -- Class-wide types, interfaces and types with controlled components
7012 elsif Is_Class_Wide_Type
(Typ
)
7013 or else Is_Interface
(Typ
)
7014 or else Has_Controlled_Component
(Utyp
)
7016 if Is_Tagged_Type
(Utyp
) then
7017 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7019 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7022 -- Derivations from [Limited_]Controlled
7024 elsif Is_Controlled
(Utyp
) then
7025 if Has_Controlled_Component
(Utyp
) then
7026 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7028 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7033 elsif Is_Tagged_Type
(Utyp
) then
7034 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7037 raise Program_Error
;
7040 if Present
(Fin_Id
) then
7042 -- When finalizing a class-wide object, do not convert to the root
7043 -- type in order to produce a dispatching call.
7045 if Is_Class_Wide_Type
(Typ
) then
7048 -- Ensure that a finalization routine is at least decorated in order
7049 -- to inspect the object parameter.
7051 elsif Analyzed
(Fin_Id
)
7052 or else Ekind
(Fin_Id
) = E_Procedure
7054 -- In certain cases, such as the creation of Stream_Read, the
7055 -- visible entity of the type is its full view. Since Stream_Read
7056 -- will have to create an object of type Typ, the local object
7057 -- will be finalzed by the scope finalizer generated later on. The
7058 -- object parameter of Deep_Finalize will always use the private
7059 -- view of the type. To avoid such a clash between a private and a
7060 -- full view, perform an unchecked conversion of the object
7061 -- reference to the private view.
7064 Formal_Typ
: constant Entity_Id
:=
7065 Etype
(First_Formal
(Fin_Id
));
7067 if Is_Private_Type
(Formal_Typ
)
7068 and then Present
(Full_View
(Formal_Typ
))
7069 and then Full_View
(Formal_Typ
) = Utyp
7071 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7075 Ref
:= Convert_View
(Fin_Id
, Ref
);
7078 return Make_Call
(Loc
, Fin_Id
, New_Copy_Tree
(Ref
), For_Parent
);
7082 end Make_Final_Call
;
7084 --------------------------------
7085 -- Make_Finalize_Address_Body --
7086 --------------------------------
7088 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7089 Is_Task
: constant Boolean :=
7090 Ekind
(Typ
) = E_Record_Type
7091 and then Is_Concurrent_Record_Type
(Typ
)
7092 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7094 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7095 Proc_Id
: Entity_Id
;
7099 -- The corresponding records of task types are not controlled by design.
7100 -- For the sake of completeness, create an empty Finalize_Address to be
7101 -- used in task class-wide allocations.
7106 -- Nothing to do if the type is not controlled or it already has a
7107 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7108 -- come from source. These are usually generated for completeness and
7109 -- do not need the Finalize_Address primitive.
7111 elsif not Needs_Finalization
(Typ
)
7112 or else Is_Abstract_Type
(Typ
)
7113 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7115 (Is_Class_Wide_Type
(Typ
)
7116 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7117 and then not Comes_From_Source
(Root_Type
(Typ
)))
7123 Make_Defining_Identifier
(Loc
,
7124 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7128 -- procedure <Typ>FD (V : System.Address) is
7130 -- null; -- for tasks
7132 -- declare -- for all other types
7133 -- type Pnn is access all Typ;
7134 -- for Pnn'Storage_Size use 0;
7136 -- [Deep_]Finalize (Pnn (V).all);
7141 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7143 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7147 Make_Subprogram_Body
(Loc
,
7149 Make_Procedure_Specification
(Loc
,
7150 Defining_Unit_Name
=> Proc_Id
,
7152 Parameter_Specifications
=> New_List
(
7153 Make_Parameter_Specification
(Loc
,
7154 Defining_Identifier
=>
7155 Make_Defining_Identifier
(Loc
, Name_V
),
7157 New_Reference_To
(RTE
(RE_Address
), Loc
)))),
7159 Declarations
=> No_List
,
7161 Handled_Statement_Sequence
=>
7162 Make_Handled_Sequence_Of_Statements
(Loc
,
7163 Statements
=> Stmts
)));
7165 Set_TSS
(Typ
, Proc_Id
);
7166 end Make_Finalize_Address_Body
;
7168 ---------------------------------
7169 -- Make_Finalize_Address_Stmts --
7170 ---------------------------------
7172 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7173 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7174 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7176 Desg_Typ
: Entity_Id
;
7180 if Is_Array_Type
(Typ
) then
7181 if Is_Constrained
(First_Subtype
(Typ
)) then
7182 Desg_Typ
:= First_Subtype
(Typ
);
7184 Desg_Typ
:= Base_Type
(Typ
);
7187 -- Class-wide types of constrained root types
7189 elsif Is_Class_Wide_Type
(Typ
)
7190 and then Has_Discriminants
(Root_Type
(Typ
))
7192 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7195 Parent_Typ
: Entity_Id
;
7198 -- Climb the parent type chain looking for a non-constrained type
7200 Parent_Typ
:= Root_Type
(Typ
);
7201 while Parent_Typ
/= Etype
(Parent_Typ
)
7202 and then Has_Discriminants
(Parent_Typ
)
7204 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7206 Parent_Typ
:= Etype
(Parent_Typ
);
7209 -- Handle views created for tagged types with unknown
7212 if Is_Underlying_Record_View
(Parent_Typ
) then
7213 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7216 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7226 -- type Ptr_Typ is access all Typ;
7227 -- for Ptr_Typ'Storage_Size use 0;
7230 Make_Full_Type_Declaration
(Loc
,
7231 Defining_Identifier
=> Ptr_Typ
,
7233 Make_Access_To_Object_Definition
(Loc
,
7234 All_Present
=> True,
7235 Subtype_Indication
=> New_Reference_To
(Desg_Typ
, Loc
))),
7237 Make_Attribute_Definition_Clause
(Loc
,
7238 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7239 Chars
=> Name_Storage_Size
,
7240 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7242 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7244 -- Unconstrained arrays require special processing in order to retrieve
7245 -- the elements. To achieve this, we have to skip the dope vector which
7246 -- lays in front of the elements and then use a thin pointer to perform
7247 -- the address-to-access conversion.
7249 if Is_Array_Type
(Typ
)
7250 and then not Is_Constrained
(First_Subtype
(Typ
))
7253 Dope_Id
: Entity_Id
;
7256 -- Ensure that Ptr_Typ a thin pointer, generate:
7257 -- for Ptr_Typ'Size use System.Address'Size;
7260 Make_Attribute_Definition_Clause
(Loc
,
7261 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7264 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7267 -- Dnn : constant Storage_Offset :=
7268 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7270 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7273 Make_Object_Declaration
(Loc
,
7274 Defining_Identifier
=> Dope_Id
,
7275 Constant_Present
=> True,
7276 Object_Definition
=>
7277 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
7279 Make_Op_Divide
(Loc
,
7281 Make_Attribute_Reference
(Loc
,
7282 Prefix
=> New_Reference_To
(Desg_Typ
, Loc
),
7283 Attribute_Name
=> Name_Descriptor_Size
),
7285 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7287 -- Shift the address from the start of the dope vector to the
7288 -- start of the elements:
7292 -- Note that this is done through a wrapper routine since RTSfind
7293 -- cannot retrieve operations with string names of the form "+".
7296 Make_Function_Call
(Loc
,
7298 New_Reference_To
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7299 Parameter_Associations
=> New_List
(
7301 New_Reference_To
(Dope_Id
, Loc
)));
7305 -- Create the block and the finalization call
7308 Make_Block_Statement
(Loc
,
7309 Declarations
=> Decls
,
7311 Handled_Statement_Sequence
=>
7312 Make_Handled_Sequence_Of_Statements
(Loc
,
7313 Statements
=> New_List
(
7316 Make_Explicit_Dereference
(Loc
,
7317 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7318 Typ
=> Desg_Typ
)))));
7319 end Make_Finalize_Address_Stmts
;
7321 -------------------------------------
7322 -- Make_Handler_For_Ctrl_Operation --
7323 -------------------------------------
7327 -- when E : others =>
7328 -- Raise_From_Controlled_Operation (E);
7333 -- raise Program_Error [finalize raised exception];
7335 -- depending on whether Raise_From_Controlled_Operation is available
7337 function Make_Handler_For_Ctrl_Operation
7338 (Loc
: Source_Ptr
) return Node_Id
7341 -- Choice parameter (for the first case above)
7343 Raise_Node
: Node_Id
;
7344 -- Procedure call or raise statement
7347 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7348 -- it to Raise_From_Controlled_Operation so that the original exception
7349 -- name and message can be recorded in the exception message for
7352 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7353 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7355 Make_Procedure_Call_Statement
(Loc
,
7358 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7359 Parameter_Associations
=> New_List
(
7360 New_Reference_To
(E_Occ
, Loc
)));
7362 -- Restricted run-time: exception messages are not supported
7367 Make_Raise_Program_Error
(Loc
,
7368 Reason
=> PE_Finalize_Raised_Exception
);
7372 Make_Implicit_Exception_Handler
(Loc
,
7373 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7374 Choice_Parameter
=> E_Occ
,
7375 Statements
=> New_List
(Raise_Node
));
7376 end Make_Handler_For_Ctrl_Operation
;
7378 --------------------
7379 -- Make_Init_Call --
7380 --------------------
7382 function Make_Init_Call
7384 Typ
: Entity_Id
) return Node_Id
7386 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7393 -- Deal with the type and object reference. Depending on the context, an
7394 -- object reference may need several conversions.
7396 if Is_Concurrent_Type
(Typ
) then
7398 Utyp
:= Corresponding_Record_Type
(Typ
);
7399 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7401 elsif Is_Private_Type
(Typ
)
7402 and then Present
(Full_View
(Typ
))
7403 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7406 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7407 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7415 Set_Assignment_OK
(Ref
);
7417 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7419 -- Deal with non-tagged derivation of private views
7421 if Is_Untagged_Derivation
(Typ
)
7422 and then not Is_Conc
7424 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7425 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7427 -- The following is to prevent problems with UC see 1.156 RH ???
7429 Set_Assignment_OK
(Ref
);
7432 -- If the underlying_type is a subtype, then we are dealing with the
7433 -- completion of a private type. We need to access the base type and
7434 -- generate a conversion to it.
7436 if Utyp
/= Base_Type
(Utyp
) then
7437 pragma Assert
(Is_Private_Type
(Typ
));
7438 Utyp
:= Base_Type
(Utyp
);
7439 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7442 -- Select the appropriate version of initialize
7444 if Has_Controlled_Component
(Utyp
) then
7445 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7447 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7448 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7451 -- The object reference may need another conversion depending on the
7452 -- type of the formal and that of the actual.
7454 Ref
:= Convert_View
(Proc
, Ref
);
7457 -- [Deep_]Initialize (Ref);
7460 Make_Procedure_Call_Statement
(Loc
,
7462 New_Reference_To
(Proc
, Loc
),
7463 Parameter_Associations
=> New_List
(Ref
));
7466 ------------------------------
7467 -- Make_Local_Deep_Finalize --
7468 ------------------------------
7470 function Make_Local_Deep_Finalize
7472 Nam
: Entity_Id
) return Node_Id
7474 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7478 Formals
:= New_List
(
7482 Make_Parameter_Specification
(Loc
,
7483 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7485 Out_Present
=> True,
7486 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7488 -- F : Boolean := True
7490 Make_Parameter_Specification
(Loc
,
7491 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7492 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
),
7493 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
7495 -- Add the necessary number of counters to represent the initialization
7496 -- state of an object.
7499 Make_Subprogram_Body
(Loc
,
7501 Make_Procedure_Specification
(Loc
,
7502 Defining_Unit_Name
=> Nam
,
7503 Parameter_Specifications
=> Formals
),
7505 Declarations
=> No_List
,
7507 Handled_Statement_Sequence
=>
7508 Make_Handled_Sequence_Of_Statements
(Loc
,
7509 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7510 end Make_Local_Deep_Finalize
;
7512 ------------------------------------
7513 -- Make_Set_Finalize_Address_Call --
7514 ------------------------------------
7516 function Make_Set_Finalize_Address_Call
7519 Ptr_Typ
: Entity_Id
) return Node_Id
7521 Desig_Typ
: constant Entity_Id
:=
7522 Available_View
(Designated_Type
(Ptr_Typ
));
7523 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7524 Fin_Mas_Ref
: Node_Id
;
7528 -- If the context is a class-wide allocator, we use the class-wide type
7529 -- to obtain the proper Finalize_Address routine.
7531 if Is_Class_Wide_Type
(Desig_Typ
) then
7537 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7538 Utyp
:= Full_View
(Utyp
);
7541 if Is_Concurrent_Type
(Utyp
) then
7542 Utyp
:= Corresponding_Record_Type
(Utyp
);
7546 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7548 -- Deal with non-tagged derivation of private views. If the parent is
7549 -- now known to be protected, the finalization routine is the one
7550 -- defined on the corresponding record of the ancestor (corresponding
7551 -- records do not automatically inherit operations, but maybe they
7554 if Is_Untagged_Derivation
(Typ
) then
7555 if Is_Protected_Type
(Typ
) then
7556 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7558 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7560 if Is_Protected_Type
(Utyp
) then
7561 Utyp
:= Corresponding_Record_Type
(Utyp
);
7566 -- If the underlying_type is a subtype, we are dealing with the
7567 -- completion of a private type. We need to access the base type and
7568 -- generate a conversion to it.
7570 if Utyp
/= Base_Type
(Utyp
) then
7571 pragma Assert
(Is_Private_Type
(Typ
));
7573 Utyp
:= Base_Type
(Utyp
);
7576 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7578 -- If the call is from a build-in-place function, the Master parameter
7579 -- is actually a pointer. Dereference it for the call.
7581 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7582 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7586 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7589 Make_Procedure_Call_Statement
(Loc
,
7591 New_Reference_To
(RTE
(RE_Set_Finalize_Address
), Loc
),
7592 Parameter_Associations
=> New_List
(
7594 Make_Attribute_Reference
(Loc
,
7596 New_Reference_To
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7597 Attribute_Name
=> Name_Unrestricted_Access
)));
7598 end Make_Set_Finalize_Address_Call
;
7600 --------------------------
7601 -- Make_Transient_Block --
7602 --------------------------
7604 function Make_Transient_Block
7607 Par
: Node_Id
) return Node_Id
7609 Decls
: constant List_Id
:= New_List
;
7610 Instrs
: constant List_Id
:= New_List
(Action
);
7615 -- Case where only secondary stack use is involved
7617 if VM_Target
= No_VM
7618 and then Uses_Sec_Stack
(Current_Scope
)
7619 and then Nkind
(Action
) /= N_Simple_Return_Statement
7620 and then Nkind
(Par
) /= N_Exception_Handler
7626 S
:= Scope
(Current_Scope
);
7628 -- At the outer level, no need to release the sec stack
7630 if S
= Standard_Standard
then
7631 Set_Uses_Sec_Stack
(Current_Scope
, False);
7634 -- In a function, only release the sec stack if the function
7635 -- does not return on the sec stack otherwise the result may
7636 -- be lost. The caller is responsible for releasing.
7638 elsif Ekind
(S
) = E_Function
then
7639 Set_Uses_Sec_Stack
(Current_Scope
, False);
7641 if not Requires_Transient_Scope
(Etype
(S
)) then
7642 Set_Uses_Sec_Stack
(S
, True);
7643 Check_Restriction
(No_Secondary_Stack
, Action
);
7648 -- In a loop or entry we should install a block encompassing
7649 -- all the construct. For now just release right away.
7651 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7654 -- In a procedure or a block, we release on exit of the
7655 -- procedure or block. ??? memory leak can be created by
7658 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7659 Set_Uses_Sec_Stack
(S
, True);
7660 Check_Restriction
(No_Secondary_Stack
, Action
);
7661 Set_Uses_Sec_Stack
(Current_Scope
, False);
7671 -- Create the transient block. Set the parent now since the block itself
7672 -- is not part of the tree.
7675 Make_Block_Statement
(Loc
,
7676 Identifier
=> New_Reference_To
(Current_Scope
, Loc
),
7677 Declarations
=> Decls
,
7678 Handled_Statement_Sequence
=>
7679 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7680 Has_Created_Identifier
=> True);
7681 Set_Parent
(Block
, Par
);
7683 -- Insert actions stuck in the transient scopes as well as all freezing
7684 -- nodes needed by those actions.
7686 Insert_Actions_In_Scope_Around
(Action
);
7688 Insert
:= Prev
(Action
);
7689 if Present
(Insert
) then
7690 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7693 -- When the transient scope was established, we pushed the entry for the
7694 -- transient scope onto the scope stack, so that the scope was active
7695 -- for the installation of finalizable entities etc. Now we must remove
7696 -- this entry, since we have constructed a proper block.
7701 end Make_Transient_Block
;
7703 ------------------------
7704 -- Node_To_Be_Wrapped --
7705 ------------------------
7707 function Node_To_Be_Wrapped
return Node_Id
is
7709 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7710 end Node_To_Be_Wrapped
;
7712 ----------------------------
7713 -- Set_Node_To_Be_Wrapped --
7714 ----------------------------
7716 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7718 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7719 end Set_Node_To_Be_Wrapped
;
7721 ----------------------------------
7722 -- Store_After_Actions_In_Scope --
7723 ----------------------------------
7725 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
7726 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7729 if Present
(SE
.Actions_To_Be_Wrapped_After
) then
7730 Insert_List_Before_And_Analyze
(
7731 First
(SE
.Actions_To_Be_Wrapped_After
), L
);
7734 SE
.Actions_To_Be_Wrapped_After
:= L
;
7736 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7737 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7739 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7744 end Store_After_Actions_In_Scope
;
7746 -----------------------------------
7747 -- Store_Before_Actions_In_Scope --
7748 -----------------------------------
7750 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
7751 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7754 if Present
(SE
.Actions_To_Be_Wrapped_Before
) then
7755 Insert_List_After_And_Analyze
(
7756 Last
(SE
.Actions_To_Be_Wrapped_Before
), L
);
7759 SE
.Actions_To_Be_Wrapped_Before
:= L
;
7761 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7762 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7764 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7769 end Store_Before_Actions_In_Scope
;
7771 --------------------------------
7772 -- Wrap_Transient_Declaration --
7773 --------------------------------
7775 -- If a transient scope has been established during the processing of the
7776 -- Expression of an Object_Declaration, it is not possible to wrap the
7777 -- declaration into a transient block as usual case, otherwise the object
7778 -- would be itself declared in the wrong scope. Therefore, all entities (if
7779 -- any) defined in the transient block are moved to the proper enclosing
7780 -- scope, furthermore, if they are controlled variables they are finalized
7781 -- right after the declaration. The finalization list of the transient
7782 -- scope is defined as a renaming of the enclosing one so during their
7783 -- initialization they will be attached to the proper finalization list.
7784 -- For instance, the following declaration :
7786 -- X : Typ := F (G (A), G (B));
7788 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7789 -- is expanded into :
7791 -- X : Typ := [ complex Expression-Action ];
7792 -- [Deep_]Finalize (_v1);
7793 -- [Deep_]Finalize (_v2);
7795 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
7802 Encl_S
:= Scope
(S
);
7804 -- Insert Actions kept in the Scope stack
7806 Insert_Actions_In_Scope_Around
(N
);
7808 -- If the declaration is consuming some secondary stack, mark the
7809 -- enclosing scope appropriately.
7811 Uses_SS
:= Uses_Sec_Stack
(S
);
7814 -- Put the local entities back in the enclosing scope, and set the
7815 -- Is_Public flag appropriately.
7817 Transfer_Entities
(S
, Encl_S
);
7819 -- Mark the enclosing dynamic scope so that the sec stack will be
7820 -- released upon its exit unless this is a function that returns on
7821 -- the sec stack in which case this will be done by the caller.
7823 if VM_Target
= No_VM
and then Uses_SS
then
7824 S
:= Enclosing_Dynamic_Scope
(S
);
7826 if Ekind
(S
) = E_Function
7827 and then Requires_Transient_Scope
(Etype
(S
))
7831 Set_Uses_Sec_Stack
(S
);
7832 Check_Restriction
(No_Secondary_Stack
, N
);
7835 end Wrap_Transient_Declaration
;
7837 -------------------------------
7838 -- Wrap_Transient_Expression --
7839 -------------------------------
7841 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
7842 Expr
: constant Node_Id
:= Relocate_Node
(N
);
7843 Loc
: constant Source_Ptr
:= Sloc
(N
);
7844 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
7845 Typ
: constant Entity_Id
:= Etype
(N
);
7852 -- M : constant Mark_Id := SS_Mark;
7853 -- procedure Finalizer is ... (See Build_Finalizer)
7862 Insert_Actions
(N
, New_List
(
7863 Make_Object_Declaration
(Loc
,
7864 Defining_Identifier
=> Temp
,
7865 Object_Definition
=> New_Reference_To
(Typ
, Loc
)),
7867 Make_Transient_Block
(Loc
,
7869 Make_Assignment_Statement
(Loc
,
7870 Name
=> New_Reference_To
(Temp
, Loc
),
7871 Expression
=> Expr
),
7872 Par
=> Parent
(N
))));
7874 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
7875 Analyze_And_Resolve
(N
, Typ
);
7876 end Wrap_Transient_Expression
;
7878 ------------------------------
7879 -- Wrap_Transient_Statement --
7880 ------------------------------
7882 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
7883 Loc
: constant Source_Ptr
:= Sloc
(N
);
7884 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
7889 -- M : constant Mark_Id := SS_Mark;
7890 -- procedure Finalizer is ... (See Build_Finalizer)
7900 Make_Transient_Block
(Loc
,
7902 Par
=> Parent
(N
)));
7904 -- With the scope stack back to normal, we can call analyze on the
7905 -- resulting block. At this point, the transient scope is being
7906 -- treated like a perfectly normal scope, so there is nothing
7907 -- special about it.
7909 -- Note: Wrap_Transient_Statement is called with the node already
7910 -- analyzed (i.e. Analyzed (N) is True). This is important, since
7911 -- otherwise we would get a recursive processing of the node when
7912 -- we do this Analyze call.
7915 end Wrap_Transient_Statement
;