1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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
152 -----------------------------
153 -- Finalization Management --
154 -----------------------------
156 -- This part describe how Initialization/Adjustment/Finalization procedures
157 -- are generated and called. Two cases must be considered, types that are
158 -- Controlled (Is_Controlled flag set) and composite types that contain
159 -- controlled components (Has_Controlled_Component flag set). In the first
160 -- case the procedures to call are the user-defined primitive operations
161 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
162 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
163 -- of calling the former procedures on the controlled components.
165 -- For records with Has_Controlled_Component set, a hidden "controller"
166 -- component is inserted. This controller component contains its own
167 -- finalization list on which all controlled components are attached
168 -- creating an indirection on the upper-level Finalization list. This
169 -- technique facilitates the management of objects whose number of
170 -- controlled components changes during execution. This controller
171 -- component is itself controlled and is attached to the upper-level
172 -- finalization chain. Its adjust primitive is in charge of calling adjust
173 -- on the components and adjusting the finalization pointer to match their
174 -- new location (see a-finali.adb).
176 -- It is not possible to use a similar technique for arrays that have
177 -- Has_Controlled_Component set. In this case, deep procedures are
178 -- generated that call initialize/adjust/finalize + attachment or
179 -- detachment on the finalization list for all component.
181 -- Initialize calls: they are generated for declarations or dynamic
182 -- allocations of Controlled objects with no initial value. They are always
183 -- followed by an attachment to the current Finalization Chain. For the
184 -- dynamic allocation case this the chain attached to the scope of the
185 -- access type definition otherwise, this is the chain of the current
188 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
189 -- or dynamic allocations of Controlled objects with an initial value.
190 -- (2) after an assignment. In the first case they are followed by an
191 -- attachment to the final chain, in the second case they are not.
193 -- Finalization Calls: They are generated on (1) scope exit, (2)
194 -- assignments, (3) unchecked deallocations. In case (3) they have to
195 -- be detached from the final chain, in case (2) they must not and in
196 -- case (1) this is not important since we are exiting the scope anyway.
200 -- Type extensions will have a new record controller at each derivation
201 -- level containing controlled components. The record controller for
202 -- the parent/ancestor is attached to the finalization list of the
203 -- extension's record controller (i.e. the parent is like a component
204 -- of the extension).
206 -- For types that are both Is_Controlled and Has_Controlled_Components,
207 -- the record controller and the object itself are handled separately.
208 -- It could seem simpler to attach the object at the end of its record
209 -- controller but this would not tackle view conversions properly.
211 -- A classwide type can always potentially have controlled components
212 -- but the record controller of the corresponding actual type may not
213 -- be known at compile time so the dispatch table contains a special
214 -- field that allows to compute the offset of the record controller
215 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
217 -- Here is a simple example of the expansion of a controlled block :
221 -- Y : Controlled := Init;
227 -- Z : R := (C => X);
237 -- _L : System.FI.Finalizable_Ptr;
239 -- procedure _Clean is
242 -- System.FI.Finalize_List (_L);
250 -- Attach_To_Final_List (_L, Finalizable (X), 1);
251 -- at end: Abort_Undefer;
252 -- Y : Controlled := Init;
254 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
262 -- Deep_Initialize (W, _L, 1);
263 -- at end: Abort_Under;
264 -- Z : R := (C => X);
265 -- Deep_Adjust (Z, _L, 1);
269 -- Deep_Finalize (W, False);
270 -- <save W's final pointers>
272 -- <restore W's final pointers>
273 -- Deep_Adjust (W, _L, 0);
278 type Final_Primitives
is
279 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
280 -- This enumeration type is defined in order to ease sharing code for
281 -- building finalization procedures for composite types.
283 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
284 (Initialize_Case
=> Name_Initialize
,
285 Adjust_Case
=> Name_Adjust
,
286 Finalize_Case
=> Name_Finalize
,
287 Address_Case
=> Name_Finalize_Address
);
288 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
289 (Initialize_Case
=> TSS_Deep_Initialize
,
290 Adjust_Case
=> TSS_Deep_Adjust
,
291 Finalize_Case
=> TSS_Deep_Finalize
,
292 Address_Case
=> TSS_Finalize_Address
);
294 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
295 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
296 -- Has_Controlled_Component set and store them using the TSS mechanism.
298 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
;
299 -- Create the clean up calls for an asynchronous call block, task master,
300 -- protected subprogram body, task allocation block or task body. If the
301 -- context does not contain the above constructs, the routine returns an
304 procedure Build_Finalizer
306 Clean_Stmts
: List_Id
;
309 Defer_Abort
: Boolean;
310 Fin_Id
: out Entity_Id
);
311 -- N may denote an accept statement, block, entry body, package body,
312 -- package spec, protected body, subprogram body, and a task body. Create
313 -- a procedure which contains finalization calls for all controlled objects
314 -- declared in the declarative or statement region of N. The calls are
315 -- built in reverse order relative to the original declarations. In the
316 -- case of a tack body, the routine delays the creation of the finalizer
317 -- until all statements have been moved to the task body procedure.
318 -- Clean_Stmts may contain additional context-dependent code used to abort
319 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
320 -- Mark_Id is the secondary stack used in the current context or Empty if
321 -- missing. Top_Decls is the list on which the declaration of the finalizer
322 -- is attached in the non-package case. Defer_Abort indicates that the
323 -- statements passed in perform actions that require abort to be deferred,
324 -- such as for task termination. Fin_Id is the finalizer declaration
327 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
328 -- N is a construct which contains a handled sequence of statements, Fin_Id
329 -- is the entity of a finalizer. Create an At_End handler which covers the
330 -- statements of N and calls Fin_Id. If the handled statement sequence has
331 -- an exception handler, the statements will be wrapped in a block to avoid
332 -- unwanted interaction with the new At_End handler.
334 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
335 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
336 -- Has_Component_Component set and store them using the TSS mechanism.
338 procedure Check_Visibly_Controlled
339 (Prim
: Final_Primitives
;
341 E
: in out Entity_Id
;
342 Cref
: in out Node_Id
);
343 -- The controlled operation declared for a derived type may not be
344 -- overriding, if the controlled operations of the parent type are hidden,
345 -- for example when the parent is a private type whose full view is
346 -- controlled. For other primitive operations we modify the name of the
347 -- operation to indicate that it is not overriding, but this is not
348 -- possible for Initialize, etc. because they have to be retrievable by
349 -- name. Before generating the proper call to one of these operations we
350 -- check whether Typ is known to be controlled at the point of definition.
351 -- If it is not then we must retrieve the hidden operation of the parent
352 -- and use it instead. This is one case that might be solved more cleanly
353 -- once Overriding pragmas or declarations are in place.
355 function Convert_View
358 Ind
: Pos
:= 1) return Node_Id
;
359 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
360 -- argument being passed to it. Ind indicates which formal of procedure
361 -- Proc we are trying to match. This function will, if necessary, generate
362 -- a conversion between the partial and full view of Arg to match the type
363 -- of the formal of Proc, or force a conversion to the class-wide type in
364 -- the case where the operation is abstract.
366 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
367 -- Given an arbitrary entity, traverse the scope chain looking for the
368 -- first enclosing function. Return Empty if no function was found.
374 For_Parent
: Boolean := False) return Node_Id
;
375 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
376 -- routine [Deep_]Adjust / Finalize and an object parameter, create an
377 -- adjust / finalization call. Flag For_Parent should be set when field
378 -- _parent is being processed.
380 function Make_Deep_Proc
381 (Prim
: Final_Primitives
;
383 Stmts
: List_Id
) return Node_Id
;
384 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
385 -- Deep_Finalize procedures according to the first parameter, these
386 -- procedures operate on the type Typ. The Stmts parameter gives the body
389 function Make_Deep_Array_Body
390 (Prim
: Final_Primitives
;
391 Typ
: Entity_Id
) return List_Id
;
392 -- This function generates the list of statements for implementing
393 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
394 -- the first parameter, these procedures operate on the array type Typ.
396 function Make_Deep_Record_Body
397 (Prim
: Final_Primitives
;
399 Is_Local
: Boolean := False) return List_Id
;
400 -- This function generates the list of statements for implementing
401 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
402 -- the first parameter, these procedures operate on the record type Typ.
403 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
404 -- whether the inner logic should be dictated by state counters.
406 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
407 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
408 -- Make_Deep_Record_Body. Generate the following statements:
411 -- type Acc_Typ is access all Typ;
412 -- for Acc_Typ'Storage_Size use 0;
414 -- [Deep_]Finalize (Acc_Typ (V).all);
417 ----------------------------
418 -- Build_Array_Deep_Procs --
419 ----------------------------
421 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
425 (Prim
=> Initialize_Case
,
427 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
429 if not Is_Immutably_Limited_Type
(Typ
) then
432 (Prim
=> Adjust_Case
,
434 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
437 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
438 -- suppressed since these routine will not be used.
440 if not Restriction_Active
(No_Finalization
) then
443 (Prim
=> Finalize_Case
,
445 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
447 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
448 -- .NET do not support address arithmetic and unchecked conversions.
450 if VM_Target
= No_VM
then
453 (Prim
=> Address_Case
,
455 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
458 end Build_Array_Deep_Procs
;
460 ------------------------------
461 -- Build_Cleanup_Statements --
462 ------------------------------
464 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
is
465 Is_Asynchronous_Call
: constant Boolean :=
466 Nkind
(N
) = N_Block_Statement
467 and then Is_Asynchronous_Call_Block
(N
);
468 Is_Master
: constant Boolean :=
469 Nkind
(N
) /= N_Entry_Body
470 and then Is_Task_Master
(N
);
471 Is_Protected_Body
: constant Boolean :=
472 Nkind
(N
) = N_Subprogram_Body
473 and then Is_Protected_Subprogram_Body
(N
);
474 Is_Task_Allocation
: constant Boolean :=
475 Nkind
(N
) = N_Block_Statement
476 and then Is_Task_Allocation_Block
(N
);
477 Is_Task_Body
: constant Boolean :=
478 Nkind
(Original_Node
(N
)) = N_Task_Body
;
480 Loc
: constant Source_Ptr
:= Sloc
(N
);
481 Stmts
: constant List_Id
:= New_List
;
485 if Restricted_Profile
then
487 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
489 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
493 if Restriction_Active
(No_Task_Hierarchy
) = False then
494 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
497 -- Add statements to unlock the protected object parameter and to
498 -- undefer abort. If the context is a protected procedure and the object
499 -- has entries, call the entry service routine.
501 -- NOTE: The generated code references _object, a parameter to the
504 elsif Is_Protected_Body
then
506 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
507 Conc_Typ
: Entity_Id
;
510 Param_Typ
: Entity_Id
;
513 -- Find the _object parameter representing the protected object
515 Param
:= First
(Parameter_Specifications
(Spec
));
517 Param_Typ
:= Etype
(Parameter_Type
(Param
));
519 if Ekind
(Param_Typ
) = E_Record_Type
then
520 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
523 exit when No
(Param
) or else Present
(Conc_Typ
);
527 pragma Assert
(Present
(Param
));
529 -- If the associated protected object has entries, a protected
530 -- procedure has to service entry queues. In this case generate:
532 -- Service_Entries (_object._object'Access);
534 if Nkind
(Specification
(N
)) = N_Procedure_Specification
535 and then Has_Entries
(Conc_Typ
)
537 case Corresponding_Runtime_Package
(Conc_Typ
) is
538 when System_Tasking_Protected_Objects_Entries
=>
539 Nam
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
541 when System_Tasking_Protected_Objects_Single_Entry
=>
542 Nam
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
549 Make_Procedure_Call_Statement
(Loc
,
551 Parameter_Associations
=> New_List
(
552 Make_Attribute_Reference
(Loc
,
554 Make_Selected_Component
(Loc
,
555 Prefix
=> New_Reference_To
(
556 Defining_Identifier
(Param
), Loc
),
558 Make_Identifier
(Loc
, Name_uObject
)),
559 Attribute_Name
=> Name_Unchecked_Access
))));
563 -- Unlock (_object._object'Access);
565 case Corresponding_Runtime_Package
(Conc_Typ
) is
566 when System_Tasking_Protected_Objects_Entries
=>
567 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entries
), Loc
);
569 when System_Tasking_Protected_Objects_Single_Entry
=>
570 Nam
:= New_Reference_To
(RTE
(RE_Unlock_Entry
), Loc
);
572 when System_Tasking_Protected_Objects
=>
573 Nam
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
580 Make_Procedure_Call_Statement
(Loc
,
582 Parameter_Associations
=> New_List
(
583 Make_Attribute_Reference
(Loc
,
585 Make_Selected_Component
(Loc
,
588 (Defining_Identifier
(Param
), Loc
),
590 Make_Identifier
(Loc
, Name_uObject
)),
591 Attribute_Name
=> Name_Unchecked_Access
))));
597 if Abort_Allowed
then
599 Make_Procedure_Call_Statement
(Loc
,
601 New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
602 Parameter_Associations
=> Empty_List
));
606 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
607 -- tasks. Other unactivated tasks are completed by Complete_Task or
610 -- NOTE: The generated code references _chain, a local object
612 elsif Is_Task_Allocation
then
615 -- Expunge_Unactivated_Tasks (_chain);
617 -- where _chain is the list of tasks created by the allocator but not
618 -- yet activated. This list will be empty unless the block completes
622 Make_Procedure_Call_Statement
(Loc
,
625 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
626 Parameter_Associations
=> New_List
(
627 New_Reference_To
(Activation_Chain_Entity
(N
), Loc
))));
629 -- Attempt to cancel an asynchronous entry call whenever the block which
630 -- contains the abortable part is exited.
632 -- NOTE: The generated code references Cnn, a local object
634 elsif Is_Asynchronous_Call
then
636 Cancel_Param
: constant Entity_Id
:=
637 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
640 -- If it is of type Communication_Block, this must be a protected
641 -- entry call. Generate:
643 -- if Enqueued (Cancel_Param) then
644 -- Cancel_Protected_Entry_Call (Cancel_Param);
647 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
649 Make_If_Statement
(Loc
,
651 Make_Function_Call
(Loc
,
653 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
654 Parameter_Associations
=> New_List
(
655 New_Reference_To
(Cancel_Param
, Loc
))),
657 Then_Statements
=> New_List
(
658 Make_Procedure_Call_Statement
(Loc
,
661 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
662 Parameter_Associations
=> New_List
(
663 New_Reference_To
(Cancel_Param
, Loc
))))));
665 -- Asynchronous delay, generate:
666 -- Cancel_Async_Delay (Cancel_Param);
668 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
670 Make_Procedure_Call_Statement
(Loc
,
672 New_Reference_To
(RTE
(RE_Cancel_Async_Delay
), Loc
),
673 Parameter_Associations
=> New_List
(
674 Make_Attribute_Reference
(Loc
,
676 New_Reference_To
(Cancel_Param
, Loc
),
677 Attribute_Name
=> Name_Unchecked_Access
))));
679 -- Task entry call, generate:
680 -- Cancel_Task_Entry_Call (Cancel_Param);
684 Make_Procedure_Call_Statement
(Loc
,
686 New_Reference_To
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
687 Parameter_Associations
=> New_List
(
688 New_Reference_To
(Cancel_Param
, Loc
))));
694 end Build_Cleanup_Statements
;
696 -----------------------------
697 -- Build_Controlling_Procs --
698 -----------------------------
700 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
702 if Is_Array_Type
(Typ
) then
703 Build_Array_Deep_Procs
(Typ
);
704 else pragma Assert
(Is_Record_Type
(Typ
));
705 Build_Record_Deep_Procs
(Typ
);
707 end Build_Controlling_Procs
;
709 -----------------------------
710 -- Build_Exception_Handler --
711 -----------------------------
713 function Build_Exception_Handler
714 (Data
: Finalization_Exception_Data
;
715 For_Library
: Boolean := False) return Node_Id
718 Proc_To_Call
: Entity_Id
;
721 pragma Assert
(Present
(Data
.E_Id
));
722 pragma Assert
(Present
(Data
.Raised_Id
));
725 -- Get_Current_Excep.all.all
727 Actuals
:= New_List
(
728 Make_Explicit_Dereference
(Data
.Loc
,
730 Make_Function_Call
(Data
.Loc
,
732 Make_Explicit_Dereference
(Data
.Loc
,
734 New_Reference_To
(RTE
(RE_Get_Current_Excep
),
737 if For_Library
and then not Restricted_Profile
then
738 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
741 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
742 Prepend_To
(Actuals
, New_Reference_To
(Data
.E_Id
, Data
.Loc
));
747 -- if not Raised_Id then
748 -- Raised_Id := True;
750 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
752 -- Save_Library_Occurrence (Get_Current_Excep.all.all);
756 Make_Exception_Handler
(Data
.Loc
,
758 New_List
(Make_Others_Choice
(Data
.Loc
)),
759 Statements
=> New_List
(
760 Make_If_Statement
(Data
.Loc
,
762 Make_Op_Not
(Data
.Loc
,
763 Right_Opnd
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
)),
765 Then_Statements
=> New_List
(
766 Make_Assignment_Statement
(Data
.Loc
,
767 Name
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
768 Expression
=> New_Reference_To
(Standard_True
, Data
.Loc
)),
770 Make_Procedure_Call_Statement
(Data
.Loc
,
772 New_Reference_To
(Proc_To_Call
, Data
.Loc
),
773 Parameter_Associations
=> Actuals
)))));
774 end Build_Exception_Handler
;
776 -------------------------------
777 -- Build_Finalization_Master --
778 -------------------------------
780 procedure Build_Finalization_Master
782 Ins_Node
: Node_Id
:= Empty
;
783 Encl_Scope
: Entity_Id
:= Empty
)
785 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
786 Ptr_Typ
: Entity_Id
:= Root_Type
(Base_Type
(Typ
));
788 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
789 -- Determine whether entity E is inside a wrapper package created for
790 -- an instance of Ada.Unchecked_Deallocation.
792 ------------------------------
793 -- In_Deallocation_Instance --
794 ------------------------------
796 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
797 Pkg
: constant Entity_Id
:= Scope
(E
);
798 Par
: Node_Id
:= Empty
;
801 if Ekind
(Pkg
) = E_Package
802 and then Present
(Related_Instance
(Pkg
))
803 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
805 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
809 and then Chars
(Par
) = Name_Unchecked_Deallocation
810 and then Chars
(Scope
(Par
)) = Name_Ada
811 and then Scope
(Scope
(Par
)) = Standard_Standard
;
815 end In_Deallocation_Instance
;
817 -- Start of processing for Build_Finalization_Master
820 if Is_Private_Type
(Ptr_Typ
)
821 and then Present
(Full_View
(Ptr_Typ
))
823 Ptr_Typ
:= Full_View
(Ptr_Typ
);
826 -- Certain run-time configurations and targets do not provide support
827 -- for controlled types.
829 if Restriction_Active
(No_Finalization
) then
832 -- Do not process C, C++, CIL and Java types since it is assumend that
833 -- the non-Ada side will handle their clean up.
835 elsif Convention
(Desig_Typ
) = Convention_C
836 or else Convention
(Desig_Typ
) = Convention_CIL
837 or else Convention
(Desig_Typ
) = Convention_CPP
838 or else Convention
(Desig_Typ
) = Convention_Java
842 -- Various machinery such as freezing may have already created a
843 -- finalization master.
845 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
848 -- Do not process types that return on the secondary stack
850 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
851 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
855 -- Do not process types which may never allocate an object
857 elsif No_Pool_Assigned
(Ptr_Typ
) then
860 -- Do not process access types coming from Ada.Unchecked_Deallocation
861 -- instances. Even though the designated type may be controlled, the
862 -- access type will never participate in allocation.
864 elsif In_Deallocation_Instance
(Ptr_Typ
) then
867 -- Ignore the general use of anonymous access types unless the context
868 -- requires a finalization master.
870 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
871 and then No
(Ins_Node
)
875 -- Do not process non-library access types when restriction No_Nested_
876 -- Finalization is in effect since masters are controlled objects.
878 elsif Restriction_Active
(No_Nested_Finalization
)
879 and then not Is_Library_Level_Entity
(Ptr_Typ
)
883 -- For .NET/JVM targets, allow the processing of access-to-controlled
884 -- types where the designated type is explicitly derived from [Limited_]
887 elsif VM_Target
/= No_VM
888 and then not Is_Controlled
(Desig_Typ
)
892 -- Do not create finalization masters in Alfa mode because they result
893 -- in unwanted expansion.
900 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
901 Actions
: constant List_Id
:= New_List
;
902 Fin_Mas_Id
: Entity_Id
;
907 -- Fnn : aliased Finalization_Master;
909 -- Source access types use fixed master names since the master is
910 -- inserted in the same source unit only once. The only exception to
911 -- this are instances using the same access type as generic actual.
913 if Comes_From_Source
(Ptr_Typ
)
914 and then not Inside_A_Generic
917 Make_Defining_Identifier
(Loc
,
918 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
920 -- Internally generated access types use temporaries as their names
921 -- due to possible collision with identical names coming from other
925 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
929 Make_Object_Declaration
(Loc
,
930 Defining_Identifier
=> Fin_Mas_Id
,
931 Aliased_Present
=> True,
933 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
)));
935 -- Storage pool selection and attribute decoration of the generated
936 -- master. Since .NET/JVM compilers do not support pools, this step
939 if VM_Target
= No_VM
then
941 -- If the access type has a user-defined pool, use it as the base
942 -- storage medium for the finalization pool.
944 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
945 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
947 -- The default choice is the global pool
950 Pool_Id
:= Get_Global_Pool_For_Access_Type
(Ptr_Typ
);
951 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
955 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
958 Make_Procedure_Call_Statement
(Loc
,
960 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
961 Parameter_Associations
=> New_List
(
962 New_Reference_To
(Fin_Mas_Id
, Loc
),
963 Make_Attribute_Reference
(Loc
,
964 Prefix
=> New_Reference_To
(Pool_Id
, Loc
),
965 Attribute_Name
=> Name_Unrestricted_Access
))));
968 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
970 -- A finalization master created for an anonymous access type must be
971 -- inserted before a context-dependent node.
973 if Present
(Ins_Node
) then
974 Push_Scope
(Encl_Scope
);
976 -- Treat use clauses as declarations and insert directly in front
979 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
982 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
984 Insert_Actions
(Ins_Node
, Actions
);
989 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
990 and then Has_Completion_In_Body
(Desig_Typ
)
992 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
994 -- If the designated type is not yet frozen, then append the actions
995 -- to that type's freeze actions. The actions need to be appended to
996 -- whichever type is frozen later, similarly to what Freeze_Type does
997 -- for appending the storage pool declaration for an access type.
998 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
999 -- pool object before it's declared. However, it's not clear that
1000 -- this is exactly the right test to accomplish that here. ???
1002 elsif Present
(Freeze_Node
(Desig_Typ
))
1003 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
1005 Append_Freeze_Actions
(Desig_Typ
, Actions
);
1007 elsif Present
(Freeze_Node
(Ptr_Typ
))
1008 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
1010 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1012 -- If there's a pool created locally for the access type, then we
1013 -- need to ensure that the master gets created after the pool object,
1014 -- because otherwise we can have a forward reference, so we force the
1015 -- master actions to be inserted and analyzed after the pool entity.
1016 -- Note that both the access type and its designated type may have
1017 -- already been frozen and had their freezing actions analyzed at
1018 -- this point. (This seems a little unclean.???)
1020 elsif VM_Target
= No_VM
1021 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1023 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1026 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1029 end Build_Finalization_Master
;
1031 ---------------------
1032 -- Build_Finalizer --
1033 ---------------------
1035 procedure Build_Finalizer
1037 Clean_Stmts
: List_Id
;
1038 Mark_Id
: Entity_Id
;
1039 Top_Decls
: List_Id
;
1040 Defer_Abort
: Boolean;
1041 Fin_Id
: out Entity_Id
)
1043 Acts_As_Clean
: constant Boolean :=
1046 (Present
(Clean_Stmts
)
1047 and then Is_Non_Empty_List
(Clean_Stmts
));
1048 Exceptions_OK
: constant Boolean :=
1049 not Restriction_Active
(No_Exception_Propagation
);
1050 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1051 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1052 For_Package
: constant Boolean :=
1053 For_Package_Body
or else For_Package_Spec
;
1054 Loc
: constant Source_Ptr
:= Sloc
(N
);
1056 -- NOTE: Local variable declarations are conservative and do not create
1057 -- structures right from the start. Entities and lists are created once
1058 -- it has been established that N has at least one controlled object.
1060 Components_Built
: Boolean := False;
1061 -- A flag used to avoid double initialization of entities and lists. If
1062 -- the flag is set then the following variables have been initialized:
1068 Counter_Id
: Entity_Id
:= Empty
;
1069 Counter_Val
: Int
:= 0;
1070 -- Name and value of the state counter
1072 Decls
: List_Id
:= No_List
;
1073 -- Declarative region of N (if available). If N is a package declaration
1074 -- Decls denotes the visible declarations.
1076 Finalizer_Data
: Finalization_Exception_Data
;
1077 -- Data for the exception
1079 Finalizer_Decls
: List_Id
:= No_List
;
1080 -- Local variable declarations. This list holds the label declarations
1081 -- of all jump block alternatives as well as the declaration of the
1082 -- local exception occurence and the raised flag:
1083 -- E : Exception_Occurrence;
1084 -- Raised : Boolean := False;
1085 -- L<counter value> : label;
1087 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1088 -- Insertion point for the finalizer body. Depending on the context
1089 -- (Nkind of N) and the individual grouping of controlled objects, this
1090 -- node may denote a package declaration or body, package instantiation,
1091 -- block statement or a counter update statement.
1093 Finalizer_Stmts
: List_Id
:= No_List
;
1094 -- The statement list of the finalizer body. It contains the following:
1096 -- Abort_Defer; -- Added if abort is allowed
1097 -- <call to Prev_At_End> -- Added if exists
1098 -- <cleanup statements> -- Added if Acts_As_Clean
1099 -- <jump block> -- Added if Has_Ctrl_Objs
1100 -- <finalization statements> -- Added if Has_Ctrl_Objs
1101 -- <stack release> -- Added if Mark_Id exists
1102 -- Abort_Undefer; -- Added if abort is allowed
1104 Has_Ctrl_Objs
: Boolean := False;
1105 -- A general flag which denotes whether N has at least one controlled
1108 Has_Tagged_Types
: Boolean := False;
1109 -- A general flag which indicates whether N has at least one library-
1110 -- level tagged type declaration.
1112 HSS
: Node_Id
:= Empty
;
1113 -- The sequence of statements of N (if available)
1115 Jump_Alts
: List_Id
:= No_List
;
1116 -- Jump block alternatives. Depending on the value of the state counter,
1117 -- the control flow jumps to a sequence of finalization statements. This
1118 -- list contains the following:
1120 -- when <counter value> =>
1121 -- goto L<counter value>;
1123 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1124 -- Specific point in the finalizer statements where the jump block is
1127 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1128 -- The last controlled construct encountered when processing the top
1129 -- level lists of N. This can be a nested package, an instantiation or
1130 -- an object declaration.
1132 Prev_At_End
: Entity_Id
:= Empty
;
1133 -- The previous at end procedure of the handled statements block of N
1135 Priv_Decls
: List_Id
:= No_List
;
1136 -- The private declarations of N if N is a package declaration
1138 Spec_Id
: Entity_Id
:= Empty
;
1139 Spec_Decls
: List_Id
:= Top_Decls
;
1140 Stmts
: List_Id
:= No_List
;
1142 Tagged_Type_Stmts
: List_Id
:= No_List
;
1143 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1144 -- tagged types found in N.
1146 -----------------------
1147 -- Local subprograms --
1148 -----------------------
1150 procedure Build_Components
;
1151 -- Create all entites and initialize all lists used in the creation of
1154 procedure Create_Finalizer
;
1155 -- Create the spec and body of the finalizer and insert them in the
1156 -- proper place in the tree depending on the context.
1158 procedure Process_Declarations
1160 Preprocess
: Boolean := False;
1161 Top_Level
: Boolean := False);
1162 -- Inspect a list of declarations or statements which may contain
1163 -- objects that need finalization. When flag Preprocess is set, the
1164 -- routine will simply count the total number of controlled objects in
1165 -- Decls. Flag Top_Level denotes whether the processing is done for
1166 -- objects in nested package declarations or instances.
1168 procedure Process_Object_Declaration
1170 Has_No_Init
: Boolean := False;
1171 Is_Protected
: Boolean := False);
1172 -- Generate all the machinery associated with the finalization of a
1173 -- single object. Flag Has_No_Init is used to denote certain contexts
1174 -- where Decl does not have initialization call(s). Flag Is_Protected
1175 -- is set when Decl denotes a simple protected object.
1177 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1178 -- Generate all the code necessary to unregister the external tag of a
1181 ----------------------
1182 -- Build_Components --
1183 ----------------------
1185 procedure Build_Components
is
1186 Counter_Decl
: Node_Id
;
1187 Counter_Typ
: Entity_Id
;
1188 Counter_Typ_Decl
: Node_Id
;
1191 pragma Assert
(Present
(Decls
));
1193 -- This routine might be invoked several times when dealing with
1194 -- constructs that have two lists (either two declarative regions
1195 -- or declarations and statements). Avoid double initialization.
1197 if Components_Built
then
1201 Components_Built
:= True;
1203 if Has_Ctrl_Objs
then
1205 -- Create entities for the counter, its type, the local exception
1206 -- and the raised flag.
1208 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1209 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1211 Finalizer_Decls
:= New_List
;
1213 if Exceptions_OK
then
1214 Build_Object_Declarations
1215 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1218 -- Since the total number of controlled objects is always known,
1219 -- build a subtype of Natural with precise bounds. This allows
1220 -- the backend to optimize the case statement. Generate:
1222 -- subtype Tnn is Natural range 0 .. Counter_Val;
1225 Make_Subtype_Declaration
(Loc
,
1226 Defining_Identifier
=> Counter_Typ
,
1227 Subtype_Indication
=>
1228 Make_Subtype_Indication
(Loc
,
1229 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
1231 Make_Range_Constraint
(Loc
,
1235 Make_Integer_Literal
(Loc
, Uint_0
),
1237 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1239 -- Generate the declaration of the counter itself:
1241 -- Counter : Integer := 0;
1244 Make_Object_Declaration
(Loc
,
1245 Defining_Identifier
=> Counter_Id
,
1246 Object_Definition
=> New_Reference_To
(Counter_Typ
, Loc
),
1247 Expression
=> Make_Integer_Literal
(Loc
, 0));
1249 -- Set the type of the counter explicitly to prevent errors when
1250 -- examining object declarations later on.
1252 Set_Etype
(Counter_Id
, Counter_Typ
);
1254 -- The counter and its type are inserted before the source
1255 -- declarations of N.
1257 Prepend_To
(Decls
, Counter_Decl
);
1258 Prepend_To
(Decls
, Counter_Typ_Decl
);
1260 -- The counter and its associated type must be manually analized
1261 -- since N has already been analyzed. Use the scope of the spec
1262 -- when inserting in a package.
1265 Push_Scope
(Spec_Id
);
1266 Analyze
(Counter_Typ_Decl
);
1267 Analyze
(Counter_Decl
);
1271 Analyze
(Counter_Typ_Decl
);
1272 Analyze
(Counter_Decl
);
1275 Jump_Alts
:= New_List
;
1278 -- If the context requires additional clean up, the finalization
1279 -- machinery is added after the clean up code.
1281 if Acts_As_Clean
then
1282 Finalizer_Stmts
:= Clean_Stmts
;
1283 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1285 Finalizer_Stmts
:= New_List
;
1288 if Has_Tagged_Types
then
1289 Tagged_Type_Stmts
:= New_List
;
1291 end Build_Components
;
1293 ----------------------
1294 -- Create_Finalizer --
1295 ----------------------
1297 procedure Create_Finalizer
is
1298 Body_Id
: Entity_Id
;
1301 Jump_Block
: Node_Id
;
1303 Label_Id
: Entity_Id
;
1305 function New_Finalizer_Name
return Name_Id
;
1306 -- Create a fully qualified name of a package spec or body finalizer.
1307 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1309 ------------------------
1310 -- New_Finalizer_Name --
1311 ------------------------
1313 function New_Finalizer_Name
return Name_Id
is
1314 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1315 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1316 -- has a non-standard scope, process the scope first.
1318 ------------------------
1319 -- New_Finalizer_Name --
1320 ------------------------
1322 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1324 if Scope
(Id
) = Standard_Standard
then
1325 Get_Name_String
(Chars
(Id
));
1328 New_Finalizer_Name
(Scope
(Id
));
1329 Add_Str_To_Name_Buffer
("__");
1330 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1332 end New_Finalizer_Name
;
1334 -- Start of processing for New_Finalizer_Name
1337 -- Create the fully qualified name of the enclosing scope
1339 New_Finalizer_Name
(Spec_Id
);
1342 -- __finalize_[spec|body]
1344 Add_Str_To_Name_Buffer
("__finalize_");
1346 if For_Package_Spec
then
1347 Add_Str_To_Name_Buffer
("spec");
1349 Add_Str_To_Name_Buffer
("body");
1353 end New_Finalizer_Name
;
1355 -- Start of processing for Create_Finalizer
1358 -- Step 1: Creation of the finalizer name
1360 -- Packages must use a distinct name for their finalizers since the
1361 -- binder will have to generate calls to them by name. The name is
1362 -- of the following form:
1364 -- xx__yy__finalize_[spec|body]
1367 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1368 Set_Has_Qualified_Name
(Fin_Id
);
1369 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1371 -- The default name is _finalizer
1375 Make_Defining_Identifier
(Loc
,
1376 Chars
=> New_External_Name
(Name_uFinalizer
));
1379 -- Step 2: Creation of the finalizer specification
1382 -- procedure Fin_Id;
1385 Make_Subprogram_Declaration
(Loc
,
1387 Make_Procedure_Specification
(Loc
,
1388 Defining_Unit_Name
=> Fin_Id
));
1390 -- Step 3: Creation of the finalizer body
1392 if Has_Ctrl_Objs
then
1394 -- Add L0, the default destination to the jump block
1396 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1397 Set_Entity
(Label_Id
,
1398 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1399 Label
:= Make_Label
(Loc
, Label_Id
);
1404 Prepend_To
(Finalizer_Decls
,
1405 Make_Implicit_Label_Declaration
(Loc
,
1406 Defining_Identifier
=> Entity
(Label_Id
),
1407 Label_Construct
=> Label
));
1413 Append_To
(Jump_Alts
,
1414 Make_Case_Statement_Alternative
(Loc
,
1415 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1416 Statements
=> New_List
(
1417 Make_Goto_Statement
(Loc
,
1418 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
1423 Append_To
(Finalizer_Stmts
, Label
);
1425 -- The local exception does not need to be reraised for library-
1426 -- level finalizers. Generate:
1428 -- if Raised and then not Abort then
1429 -- Raise_From_Controlled_Operation (E);
1433 and then Exceptions_OK
1435 Append_To
(Finalizer_Stmts
,
1436 Build_Raise_Statement
(Finalizer_Data
));
1439 -- Create the jump block which controls the finalization flow
1440 -- depending on the value of the state counter.
1443 Make_Case_Statement
(Loc
,
1444 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1445 Alternatives
=> Jump_Alts
);
1448 and then Present
(Jump_Block_Insert_Nod
)
1450 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1452 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1456 -- Add the library-level tagged type unregistration machinery before
1457 -- the jump block circuitry. This ensures that external tags will be
1458 -- removed even if a finalization exception occurs at some point.
1460 if Has_Tagged_Types
then
1461 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1464 -- Add a call to the previous At_End handler if it exists. The call
1465 -- must always precede the jump block.
1467 if Present
(Prev_At_End
) then
1468 Prepend_To
(Finalizer_Stmts
,
1469 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1471 -- Clear the At_End handler since we have already generated the
1472 -- proper replacement call for it.
1474 Set_At_End_Proc
(HSS
, Empty
);
1477 -- Release the secondary stack mark
1479 if Present
(Mark_Id
) then
1480 Append_To
(Finalizer_Stmts
,
1481 Make_Procedure_Call_Statement
(Loc
,
1483 New_Reference_To
(RTE
(RE_SS_Release
), Loc
),
1484 Parameter_Associations
=> New_List
(
1485 New_Reference_To
(Mark_Id
, Loc
))));
1488 -- Protect the statements with abort defer/undefer. This is only when
1489 -- aborts are allowed and the clean up statements require deferral or
1490 -- there are controlled objects to be finalized.
1494 (Defer_Abort
or else Has_Ctrl_Objs
)
1496 Prepend_To
(Finalizer_Stmts
,
1497 Make_Procedure_Call_Statement
(Loc
,
1498 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
)));
1500 Append_To
(Finalizer_Stmts
,
1501 Make_Procedure_Call_Statement
(Loc
,
1502 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
1506 -- procedure Fin_Id is
1507 -- Abort : constant Boolean := Triggered_By_Abort;
1509 -- Abort : constant Boolean := False; -- no abort
1511 -- E : Exception_Occurrence; -- All added if flag
1512 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1518 -- Abort_Defer; -- Added if abort is allowed
1519 -- <call to Prev_At_End> -- Added if exists
1520 -- <cleanup statements> -- Added if Acts_As_Clean
1521 -- <jump block> -- Added if Has_Ctrl_Objs
1522 -- <finalization statements> -- Added if Has_Ctrl_Objs
1523 -- <stack release> -- Added if Mark_Id exists
1524 -- Abort_Undefer; -- Added if abort is allowed
1527 -- Create the body of the finalizer
1529 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1532 Set_Has_Qualified_Name
(Body_Id
);
1533 Set_Has_Fully_Qualified_Name
(Body_Id
);
1537 Make_Subprogram_Body
(Loc
,
1539 Make_Procedure_Specification
(Loc
,
1540 Defining_Unit_Name
=> Body_Id
),
1541 Declarations
=> Finalizer_Decls
,
1542 Handled_Statement_Sequence
=>
1543 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1545 -- Step 4: Spec and body insertion, analysis
1549 -- If the package spec has private declarations, the finalizer
1550 -- body must be added to the end of the list in order to have
1551 -- visibility of all private controlled objects.
1553 if For_Package_Spec
then
1554 if Present
(Priv_Decls
) then
1555 Append_To
(Priv_Decls
, Fin_Spec
);
1556 Append_To
(Priv_Decls
, Fin_Body
);
1558 Append_To
(Decls
, Fin_Spec
);
1559 Append_To
(Decls
, Fin_Body
);
1562 -- For package bodies, both the finalizer spec and body are
1563 -- inserted at the end of the package declarations.
1566 Append_To
(Decls
, Fin_Spec
);
1567 Append_To
(Decls
, Fin_Body
);
1570 -- Push the name of the package
1572 Push_Scope
(Spec_Id
);
1580 -- Create the spec for the finalizer. The At_End handler must be
1581 -- able to call the body which resides in a nested structure.
1585 -- procedure Fin_Id; -- Spec
1587 -- <objects and possibly statements>
1588 -- procedure Fin_Id is ... -- Body
1591 -- Fin_Id; -- At_End handler
1594 pragma Assert
(Present
(Spec_Decls
));
1596 Append_To
(Spec_Decls
, Fin_Spec
);
1599 -- When the finalizer acts solely as a clean up routine, the body
1600 -- is inserted right after the spec.
1603 and then not Has_Ctrl_Objs
1605 Insert_After
(Fin_Spec
, Fin_Body
);
1607 -- In all other cases the body is inserted after either:
1609 -- 1) The counter update statement of the last controlled object
1610 -- 2) The last top level nested controlled package
1611 -- 3) The last top level controlled instantiation
1614 -- Manually freeze the spec. This is somewhat of a hack because
1615 -- a subprogram is frozen when its body is seen and the freeze
1616 -- node appears right before the body. However, in this case,
1617 -- the spec must be frozen earlier since the At_End handler
1618 -- must be able to call it.
1621 -- procedure Fin_Id; -- Spec
1622 -- [Fin_Id] -- Freeze node
1626 -- Fin_Id; -- At_End handler
1629 Ensure_Freeze_Node
(Fin_Id
);
1630 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1631 Set_Is_Frozen
(Fin_Id
);
1633 -- In the case where the last construct to contain a controlled
1634 -- object is either a nested package, an instantiation or a
1635 -- freeze node, the body must be inserted directly after the
1638 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1640 N_Package_Declaration
,
1643 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1646 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1651 end Create_Finalizer
;
1653 --------------------------
1654 -- Process_Declarations --
1655 --------------------------
1657 procedure Process_Declarations
1659 Preprocess
: Boolean := False;
1660 Top_Level
: Boolean := False)
1665 Obj_Typ
: Entity_Id
;
1666 Pack_Id
: Entity_Id
;
1670 Old_Counter_Val
: Int
;
1671 -- This variable is used to determine whether a nested package or
1672 -- instance contains at least one controlled object.
1674 procedure Processing_Actions
1675 (Has_No_Init
: Boolean := False;
1676 Is_Protected
: Boolean := False);
1677 -- Depending on the mode of operation of Process_Declarations, either
1678 -- increment the controlled object counter, set the controlled object
1679 -- flag and store the last top level construct or process the current
1680 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1681 -- the current declaration may not have initialization proc(s). Flag
1682 -- Is_Protected should be set when the current declaration denotes a
1683 -- simple protected object.
1685 ------------------------
1686 -- Processing_Actions --
1687 ------------------------
1689 procedure Processing_Actions
1690 (Has_No_Init
: Boolean := False;
1691 Is_Protected
: Boolean := False)
1694 -- Library-level tagged type
1696 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1698 Has_Tagged_Types
:= True;
1701 and then No
(Last_Top_Level_Ctrl_Construct
)
1703 Last_Top_Level_Ctrl_Construct
:= Decl
;
1707 Process_Tagged_Type_Declaration
(Decl
);
1710 -- Controlled object declaration
1714 Counter_Val
:= Counter_Val
+ 1;
1715 Has_Ctrl_Objs
:= True;
1718 and then No
(Last_Top_Level_Ctrl_Construct
)
1720 Last_Top_Level_Ctrl_Construct
:= Decl
;
1724 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1727 end Processing_Actions
;
1729 -- Start of processing for Process_Declarations
1732 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1736 -- Process all declarations in reverse order
1738 Decl
:= Last_Non_Pragma
(Decls
);
1739 while Present
(Decl
) loop
1741 -- Library-level tagged types
1743 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1744 Typ
:= Defining_Identifier
(Decl
);
1746 if Is_Tagged_Type
(Typ
)
1747 and then Is_Library_Level_Entity
(Typ
)
1748 and then Convention
(Typ
) = Convention_Ada
1749 and then Present
(Access_Disp_Table
(Typ
))
1750 and then RTE_Available
(RE_Register_Tag
)
1751 and then not No_Run_Time_Mode
1752 and then not Is_Abstract_Type
(Typ
)
1757 -- Regular object declarations
1759 elsif Nkind
(Decl
) = N_Object_Declaration
then
1760 Obj_Id
:= Defining_Identifier
(Decl
);
1761 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1762 Expr
:= Expression
(Decl
);
1764 -- Bypass any form of processing for objects which have their
1765 -- finalization disabled. This applies only to objects at the
1769 and then Finalize_Storage_Only
(Obj_Typ
)
1773 -- Transient variables are treated separately in order to
1774 -- minimize the size of the generated code. For details, see
1775 -- Process_Transient_Objects.
1777 elsif Is_Processed_Transient
(Obj_Id
) then
1780 -- The object is of the form:
1781 -- Obj : Typ [:= Expr];
1783 -- Do not process the incomplete view of a deferred constant.
1784 -- Do not consider tag-to-class-wide conversions.
1786 elsif not Is_Imported
(Obj_Id
)
1787 and then Needs_Finalization
(Obj_Typ
)
1788 and then not (Ekind
(Obj_Id
) = E_Constant
1789 and then not Has_Completion
(Obj_Id
))
1790 and then not Is_Tag_To_CW_Conversion
(Obj_Id
)
1794 -- The object is of the form:
1795 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1797 -- Obj : Access_Typ :=
1798 -- BIP_Function_Call
1799 -- (..., BIPaccess => null, ...)'reference;
1801 elsif Is_Access_Type
(Obj_Typ
)
1802 and then Needs_Finalization
1803 (Available_View
(Designated_Type
(Obj_Typ
)))
1804 and then Present
(Expr
)
1806 (Is_Null_Access_BIP_Func_Call
(Expr
)
1808 (Is_Non_BIP_Func_Call
(Expr
)
1809 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1811 Processing_Actions
(Has_No_Init
=> True);
1813 -- Processing for "hook" objects generated for controlled
1814 -- transients declared inside an Expression_With_Actions.
1816 elsif Is_Access_Type
(Obj_Typ
)
1817 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
1818 and then Nkind
(Return_Flag_Or_Transient_Decl
(Obj_Id
)) =
1819 N_Object_Declaration
1820 and then Is_Finalizable_Transient
1821 (Return_Flag_Or_Transient_Decl
(Obj_Id
), Decl
)
1823 Processing_Actions
(Has_No_Init
=> True);
1825 -- Simple protected objects which use type System.Tasking.
1826 -- Protected_Objects.Protection to manage their locks should
1827 -- be treated as controlled since they require manual cleanup.
1828 -- The only exception is illustrated in the following example:
1831 -- type Ctrl is new Controlled ...
1832 -- procedure Finalize (Obj : in out Ctrl);
1836 -- package body Pkg is
1837 -- protected Prot is
1838 -- procedure Do_Something (Obj : in out Ctrl);
1841 -- protected body Prot is
1842 -- procedure Do_Something (Obj : in out Ctrl) is ...
1845 -- procedure Finalize (Obj : in out Ctrl) is
1847 -- Prot.Do_Something (Obj);
1851 -- Since for the most part entities in package bodies depend on
1852 -- those in package specs, Prot's lock should be cleaned up
1853 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1854 -- This act however attempts to invoke Do_Something and fails
1855 -- because the lock has disappeared.
1857 elsif Ekind
(Obj_Id
) = E_Variable
1858 and then not In_Library_Level_Package_Body
(Obj_Id
)
1860 (Is_Simple_Protected_Type
(Obj_Typ
)
1861 or else Has_Simple_Protected_Object
(Obj_Typ
))
1863 Processing_Actions
(Is_Protected
=> True);
1866 -- Specific cases of object renamings
1868 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
1869 and then Nkind
(Name
(Decl
)) = N_Explicit_Dereference
1870 and then Nkind
(Prefix
(Name
(Decl
))) = N_Identifier
1872 Obj_Id
:= Defining_Identifier
(Decl
);
1873 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1875 -- Bypass any form of processing for objects which have their
1876 -- finalization disabled. This applies only to objects at the
1880 and then Finalize_Storage_Only
(Obj_Typ
)
1884 -- Return object of a build-in-place function. This case is
1885 -- recognized and marked by the expansion of an extended return
1886 -- statement (see Expand_N_Extended_Return_Statement).
1888 elsif Needs_Finalization
(Obj_Typ
)
1889 and then Is_Return_Object
(Obj_Id
)
1890 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
1892 Processing_Actions
(Has_No_Init
=> True);
1895 -- Inspect the freeze node of an access-to-controlled type and
1896 -- look for a delayed finalization master. This case arises when
1897 -- the freeze actions are inserted at a later time than the
1898 -- expansion of the context. Since Build_Finalizer is never called
1899 -- on a single construct twice, the master will be ultimately
1900 -- left out and never finalized. This is also needed for freeze
1901 -- actions of designated types themselves, since in some cases the
1902 -- finalization master is associated with a designated type's
1903 -- freeze node rather than that of the access type (see handling
1904 -- for freeze actions in Build_Finalization_Master).
1906 elsif Nkind
(Decl
) = N_Freeze_Entity
1907 and then Present
(Actions
(Decl
))
1909 Typ
:= Entity
(Decl
);
1911 if (Is_Access_Type
(Typ
)
1912 and then not Is_Access_Subprogram_Type
(Typ
)
1913 and then Needs_Finalization
1914 (Available_View
(Designated_Type
(Typ
))))
1915 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
1917 Old_Counter_Val
:= Counter_Val
;
1919 -- Freeze nodes are considered to be identical to packages
1920 -- and blocks in terms of nesting. The difference is that
1921 -- a finalization master created inside the freeze node is
1922 -- at the same nesting level as the node itself.
1924 Process_Declarations
(Actions
(Decl
), Preprocess
);
1926 -- The freeze node contains a finalization master
1930 and then No
(Last_Top_Level_Ctrl_Construct
)
1931 and then Counter_Val
> Old_Counter_Val
1933 Last_Top_Level_Ctrl_Construct
:= Decl
;
1937 -- Nested package declarations, avoid generics
1939 elsif Nkind
(Decl
) = N_Package_Declaration
then
1940 Spec
:= Specification
(Decl
);
1941 Pack_Id
:= Defining_Unit_Name
(Spec
);
1943 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
1944 Pack_Id
:= Defining_Identifier
(Pack_Id
);
1947 if Ekind
(Pack_Id
) /= E_Generic_Package
then
1948 Old_Counter_Val
:= Counter_Val
;
1949 Process_Declarations
1950 (Private_Declarations
(Spec
), Preprocess
);
1951 Process_Declarations
1952 (Visible_Declarations
(Spec
), Preprocess
);
1954 -- Either the visible or the private declarations contain a
1955 -- controlled object. The nested package declaration is the
1956 -- last such construct.
1960 and then No
(Last_Top_Level_Ctrl_Construct
)
1961 and then Counter_Val
> Old_Counter_Val
1963 Last_Top_Level_Ctrl_Construct
:= Decl
;
1967 -- Nested package bodies, avoid generics
1969 elsif Nkind
(Decl
) = N_Package_Body
then
1970 Spec
:= Corresponding_Spec
(Decl
);
1972 if Ekind
(Spec
) /= E_Generic_Package
then
1973 Old_Counter_Val
:= Counter_Val
;
1974 Process_Declarations
(Declarations
(Decl
), Preprocess
);
1976 -- The nested package body is the last construct to contain
1977 -- a controlled object.
1981 and then No
(Last_Top_Level_Ctrl_Construct
)
1982 and then Counter_Val
> Old_Counter_Val
1984 Last_Top_Level_Ctrl_Construct
:= Decl
;
1988 -- Handle a rare case caused by a controlled transient variable
1989 -- created as part of a record init proc. The variable is wrapped
1990 -- in a block, but the block is not associated with a transient
1993 elsif Nkind
(Decl
) = N_Block_Statement
1994 and then Inside_Init_Proc
1996 Old_Counter_Val
:= Counter_Val
;
1998 if Present
(Handled_Statement_Sequence
(Decl
)) then
1999 Process_Declarations
2000 (Statements
(Handled_Statement_Sequence
(Decl
)),
2004 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2006 -- Either the declaration or statement list of the block has a
2007 -- controlled object.
2011 and then No
(Last_Top_Level_Ctrl_Construct
)
2012 and then Counter_Val
> Old_Counter_Val
2014 Last_Top_Level_Ctrl_Construct
:= Decl
;
2018 Prev_Non_Pragma
(Decl
);
2020 end Process_Declarations
;
2022 --------------------------------
2023 -- Process_Object_Declaration --
2024 --------------------------------
2026 procedure Process_Object_Declaration
2028 Has_No_Init
: Boolean := False;
2029 Is_Protected
: Boolean := False)
2031 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2032 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2034 Count_Ins
: Node_Id
;
2036 Fin_Stmts
: List_Id
;
2039 Label_Id
: Entity_Id
;
2041 Obj_Typ
: Entity_Id
;
2043 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2044 -- Once it has been established that the current object is in fact a
2045 -- return object of build-in-place function Func_Id, generate the
2046 -- following cleanup code:
2048 -- if BIPallocfrom > Secondary_Stack'Pos
2049 -- and then BIPfinalizationmaster /= null
2052 -- type Ptr_Typ is access Obj_Typ;
2053 -- for Ptr_Typ'Storage_Pool
2054 -- use Base_Pool (BIPfinalizationmaster);
2056 -- Free (Ptr_Typ (Temp));
2060 -- Obj_Typ is the type of the current object, Temp is the original
2061 -- allocation which Obj_Id renames.
2063 procedure Find_Last_Init
2066 Last_Init
: out Node_Id
;
2067 Body_Insert
: out Node_Id
);
2068 -- An object declaration has at least one and at most two init calls:
2069 -- that of the type and the user-defined initialize. Given an object
2070 -- declaration, Last_Init denotes the last initialization call which
2071 -- follows the declaration. Body_Insert denotes the place where the
2072 -- finalizer body could be potentially inserted.
2074 -----------------------------
2075 -- Build_BIP_Cleanup_Stmts --
2076 -----------------------------
2078 function Build_BIP_Cleanup_Stmts
2079 (Func_Id
: Entity_Id
) return Node_Id
2081 Decls
: constant List_Id
:= New_List
;
2082 Fin_Mas_Id
: constant Entity_Id
:=
2083 Build_In_Place_Formal
2084 (Func_Id
, BIP_Finalization_Master
);
2085 Obj_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2086 Temp_Id
: constant Entity_Id
:=
2087 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2091 Free_Stmt
: Node_Id
;
2092 Pool_Id
: Entity_Id
;
2093 Ptr_Typ
: Entity_Id
;
2097 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2099 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2102 Make_Object_Renaming_Declaration
(Loc
,
2103 Defining_Identifier
=> Pool_Id
,
2105 New_Reference_To
(RTE
(RE_Root_Storage_Pool
), Loc
),
2107 Make_Explicit_Dereference
(Loc
,
2109 Make_Function_Call
(Loc
,
2111 New_Reference_To
(RTE
(RE_Base_Pool
), Loc
),
2112 Parameter_Associations
=> New_List
(
2113 Make_Explicit_Dereference
(Loc
,
2114 Prefix
=> New_Reference_To
(Fin_Mas_Id
, Loc
)))))));
2116 -- Create an access type which uses the storage pool of the
2117 -- caller's finalization master.
2120 -- type Ptr_Typ is access Obj_Typ;
2122 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2125 Make_Full_Type_Declaration
(Loc
,
2126 Defining_Identifier
=> Ptr_Typ
,
2128 Make_Access_To_Object_Definition
(Loc
,
2129 Subtype_Indication
=> New_Reference_To
(Obj_Typ
, Loc
))));
2131 -- Perform minor decoration in order to set the master and the
2132 -- storage pool attributes.
2134 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2135 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2136 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2138 -- Create an explicit free statement. Note that the free uses the
2139 -- caller's pool expressed as a renaming.
2142 Make_Free_Statement
(Loc
,
2144 Unchecked_Convert_To
(Ptr_Typ
,
2145 New_Reference_To
(Temp_Id
, Loc
)));
2147 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2149 -- Create a block to house the dummy type and the instantiation as
2150 -- well as to perform the cleanup the temporary.
2156 -- Free (Ptr_Typ (Temp_Id));
2160 Make_Block_Statement
(Loc
,
2161 Declarations
=> Decls
,
2162 Handled_Statement_Sequence
=>
2163 Make_Handled_Sequence_Of_Statements
(Loc
,
2164 Statements
=> New_List
(Free_Stmt
)));
2167 -- if BIPfinalizationmaster /= null then
2171 Left_Opnd
=> New_Reference_To
(Fin_Mas_Id
, Loc
),
2172 Right_Opnd
=> Make_Null
(Loc
));
2174 -- For constrained or tagged results escalate the condition to
2175 -- include the allocation format. Generate:
2177 -- if BIPallocform > Secondary_Stack'Pos
2178 -- and then BIPfinalizationmaster /= null
2181 if not Is_Constrained
(Obj_Typ
)
2182 or else Is_Tagged_Type
(Obj_Typ
)
2185 Alloc
: constant Entity_Id
:=
2186 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2192 Left_Opnd
=> New_Reference_To
(Alloc
, Loc
),
2194 Make_Integer_Literal
(Loc
,
2196 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2198 Right_Opnd
=> Cond
);
2208 Make_If_Statement
(Loc
,
2210 Then_Statements
=> New_List
(Free_Blk
));
2211 end Build_BIP_Cleanup_Stmts
;
2213 --------------------
2214 -- Find_Last_Init --
2215 --------------------
2217 procedure Find_Last_Init
2220 Last_Init
: out Node_Id
;
2221 Body_Insert
: out Node_Id
)
2223 Nod_1
: Node_Id
:= Empty
;
2224 Nod_2
: Node_Id
:= Empty
;
2227 function Is_Init_Call
2229 Typ
: Entity_Id
) return Boolean;
2230 -- Given an arbitrary node, determine whether N is a procedure
2231 -- call and if it is, try to match the name of the call with the
2232 -- [Deep_]Initialize proc of Typ.
2234 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2235 -- Given a statement which is part of a list, return the next
2236 -- real statement while skipping over dynamic elab checks.
2242 function Is_Init_Call
2244 Typ
: Entity_Id
) return Boolean
2247 -- A call to [Deep_]Initialize is always direct
2249 if Nkind
(N
) = N_Procedure_Call_Statement
2250 and then Nkind
(Name
(N
)) = N_Identifier
2253 Call_Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2254 Deep_Init
: constant Entity_Id
:=
2255 TSS
(Typ
, TSS_Deep_Initialize
);
2256 Init
: Entity_Id
:= Empty
;
2259 -- A type may have controlled components but not be
2262 if Is_Controlled
(Typ
) then
2263 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2265 if Present
(Init
) then
2266 Init
:= Ultimate_Alias
(Init
);
2271 (Present
(Deep_Init
) and then Call_Ent
= Deep_Init
)
2273 (Present
(Init
) and then Call_Ent
= Init
);
2280 -----------------------------
2281 -- Next_Suitable_Statement --
2282 -----------------------------
2284 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2285 Result
: Node_Id
:= Next
(Stmt
);
2288 -- Skip over access-before-elaboration checks
2290 if Dynamic_Elaboration_Checks
2291 and then Nkind
(Result
) = N_Raise_Program_Error
2293 Result
:= Next
(Result
);
2297 end Next_Suitable_Statement
;
2299 -- Start of processing for Find_Last_Init
2303 Body_Insert
:= Empty
;
2305 -- Object renamings and objects associated with controlled
2306 -- function results do not have initialization calls.
2312 if Is_Concurrent_Type
(Typ
) then
2313 Utyp
:= Corresponding_Record_Type
(Typ
);
2318 if Is_Private_Type
(Utyp
)
2319 and then Present
(Full_View
(Utyp
))
2321 Utyp
:= Full_View
(Utyp
);
2324 -- The init procedures are arranged as follows:
2326 -- Object : Controlled_Type;
2327 -- Controlled_TypeIP (Object);
2328 -- [[Deep_]Initialize (Object);]
2330 -- where the user-defined initialize may be optional or may appear
2331 -- inside a block when abort deferral is needed.
2333 Nod_1
:= Next_Suitable_Statement
(Decl
);
2334 if Present
(Nod_1
) then
2335 Nod_2
:= Next_Suitable_Statement
(Nod_1
);
2337 -- The statement following an object declaration is always a
2338 -- call to the type init proc.
2343 -- Optional user-defined init or deep init processing
2345 if Present
(Nod_2
) then
2347 -- The statement following the type init proc may be a block
2348 -- statement in cases where abort deferral is required.
2350 if Nkind
(Nod_2
) = N_Block_Statement
then
2352 HSS
: constant Node_Id
:=
2353 Handled_Statement_Sequence
(Nod_2
);
2358 and then Present
(Statements
(HSS
))
2360 Stmt
:= First
(Statements
(HSS
));
2362 -- Examine individual block statements and locate the
2363 -- call to [Deep_]Initialze.
2365 while Present
(Stmt
) loop
2366 if Is_Init_Call
(Stmt
, Utyp
) then
2368 Body_Insert
:= Nod_2
;
2378 elsif Is_Init_Call
(Nod_2
, Utyp
) then
2384 -- Start of processing for Process_Object_Declaration
2387 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
2388 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2390 -- Handle access types
2392 if Is_Access_Type
(Obj_Typ
) then
2393 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2394 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2397 Set_Etype
(Obj_Ref
, Obj_Typ
);
2399 -- Set a new value for the state counter and insert the statement
2400 -- after the object declaration. Generate:
2402 -- Counter := <value>;
2405 Make_Assignment_Statement
(Loc
,
2406 Name
=> New_Reference_To
(Counter_Id
, Loc
),
2407 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2409 -- Insert the counter after all initialization has been done. The
2410 -- place of insertion depends on the context. When dealing with a
2411 -- controlled function, the counter is inserted directly after the
2412 -- declaration because such objects lack init calls.
2414 Find_Last_Init
(Decl
, Obj_Typ
, Count_Ins
, Body_Ins
);
2416 Insert_After
(Count_Ins
, Inc_Decl
);
2419 -- If the current declaration is the last in the list, the finalizer
2420 -- body needs to be inserted after the set counter statement for the
2421 -- current object declaration. This is complicated by the fact that
2422 -- the set counter statement may appear in abort deferred block. In
2423 -- that case, the proper insertion place is after the block.
2425 if No
(Finalizer_Insert_Nod
) then
2427 -- Insertion after an abort deffered block
2429 if Present
(Body_Ins
) then
2430 Finalizer_Insert_Nod
:= Body_Ins
;
2432 Finalizer_Insert_Nod
:= Inc_Decl
;
2436 -- Create the associated label with this object, generate:
2438 -- L<counter> : label;
2441 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2443 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2444 Label
:= Make_Label
(Loc
, Label_Id
);
2446 Prepend_To
(Finalizer_Decls
,
2447 Make_Implicit_Label_Declaration
(Loc
,
2448 Defining_Identifier
=> Entity
(Label_Id
),
2449 Label_Construct
=> Label
));
2451 -- Create the associated jump with this object, generate:
2453 -- when <counter> =>
2456 Prepend_To
(Jump_Alts
,
2457 Make_Case_Statement_Alternative
(Loc
,
2458 Discrete_Choices
=> New_List
(
2459 Make_Integer_Literal
(Loc
, Counter_Val
)),
2460 Statements
=> New_List
(
2461 Make_Goto_Statement
(Loc
,
2462 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
2464 -- Insert the jump destination, generate:
2468 Append_To
(Finalizer_Stmts
, Label
);
2470 -- Processing for simple protected objects. Such objects require
2471 -- manual finalization of their lock managers.
2473 if Is_Protected
then
2474 Fin_Stmts
:= No_List
;
2476 if Is_Simple_Protected_Type
(Obj_Typ
) then
2477 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2479 if Present
(Fin_Call
) then
2480 Fin_Stmts
:= New_List
(Fin_Call
);
2483 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2484 if Is_Record_Type
(Obj_Typ
) then
2485 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2486 elsif Is_Array_Type
(Obj_Typ
) then
2487 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2493 -- System.Tasking.Protected_Objects.Finalize_Protection
2501 if Present
(Fin_Stmts
) then
2502 Append_To
(Finalizer_Stmts
,
2503 Make_Block_Statement
(Loc
,
2504 Handled_Statement_Sequence
=>
2505 Make_Handled_Sequence_Of_Statements
(Loc
,
2506 Statements
=> Fin_Stmts
,
2508 Exception_Handlers
=> New_List
(
2509 Make_Exception_Handler
(Loc
,
2510 Exception_Choices
=> New_List
(
2511 Make_Others_Choice
(Loc
)),
2513 Statements
=> New_List
(
2514 Make_Null_Statement
(Loc
)))))));
2517 -- Processing for regular controlled objects
2521 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2523 -- begin -- Exception handlers allowed
2524 -- [Deep_]Finalize (Obj);
2527 -- when Id : others =>
2528 -- if not Raised then
2530 -- Save_Occurrence (E, Id);
2539 if Exceptions_OK
then
2540 Fin_Stmts
:= New_List
(
2541 Make_Block_Statement
(Loc
,
2542 Handled_Statement_Sequence
=>
2543 Make_Handled_Sequence_Of_Statements
(Loc
,
2544 Statements
=> New_List
(Fin_Call
),
2546 Exception_Handlers
=> New_List
(
2547 Build_Exception_Handler
2548 (Finalizer_Data
, For_Package
)))));
2550 -- When exception handlers are prohibited, the finalization call
2551 -- appears unprotected. Any exception raised during finalization
2552 -- will bypass the circuitry which ensures the cleanup of all
2553 -- remaining objects.
2556 Fin_Stmts
:= New_List
(Fin_Call
);
2559 -- If we are dealing with a return object of a build-in-place
2560 -- function, generate the following cleanup statements:
2562 -- if BIPallocfrom > Secondary_Stack'Pos
2563 -- and then BIPfinalizationmaster /= null
2566 -- type Ptr_Typ is access Obj_Typ;
2567 -- for Ptr_Typ'Storage_Pool use
2568 -- Base_Pool (BIPfinalizationmaster.all).all;
2570 -- Free (Ptr_Typ (Temp));
2574 -- The generated code effectively detaches the temporary from the
2575 -- caller finalization master and deallocates the object. This is
2576 -- disabled on .NET/JVM because pools are not supported.
2578 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2580 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2582 if Is_Build_In_Place_Function
(Func_Id
)
2583 and then Needs_BIP_Finalization_Master
(Func_Id
)
2585 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2590 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2591 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
2593 -- Return objects use a flag to aid their potential
2594 -- finalization when the enclosing function fails to return
2595 -- properly. Generate:
2598 -- <object finalization statements>
2601 if Is_Return_Object
(Obj_Id
) then
2602 Fin_Stmts
:= New_List
(
2603 Make_If_Statement
(Loc
,
2608 (Return_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2610 Then_Statements
=> Fin_Stmts
));
2612 -- Temporaries created for the purpose of "exporting" a
2613 -- controlled transient out of an Expression_With_Actions (EWA)
2614 -- need guards. The following illustrates the usage of such
2617 -- Access_Typ : access [all] Obj_Typ;
2618 -- Temp : Access_Typ := null;
2619 -- <Counter> := ...;
2622 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2623 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2625 -- Temp := Ctrl_Trans'Unchecked_Access;
2628 -- The finalization machinery does not process EWA nodes as
2629 -- this may lead to premature finalization of expressions. Note
2630 -- that Temp is marked as being properly initialized regardless
2631 -- of whether the initialization of Ctrl_Trans succeeded. Since
2632 -- a failed initialization may leave Temp with a value of null,
2633 -- add a guard to handle this case:
2635 -- if Obj /= null then
2636 -- <object finalization statements>
2641 (Nkind
(Return_Flag_Or_Transient_Decl
(Obj_Id
)) =
2642 N_Object_Declaration
);
2644 Fin_Stmts
:= New_List
(
2645 Make_If_Statement
(Loc
,
2648 Left_Opnd
=> New_Reference_To
(Obj_Id
, Loc
),
2649 Right_Opnd
=> Make_Null
(Loc
)),
2651 Then_Statements
=> Fin_Stmts
));
2656 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2658 -- Since the declarations are examined in reverse, the state counter
2659 -- must be decremented in order to keep with the true position of
2662 Counter_Val
:= Counter_Val
- 1;
2663 end Process_Object_Declaration
;
2665 -------------------------------------
2666 -- Process_Tagged_Type_Declaration --
2667 -------------------------------------
2669 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2670 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2671 DT_Ptr
: constant Entity_Id
:=
2672 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2675 -- Ada.Tags.Unregister_Tag (<Typ>P);
2677 Append_To
(Tagged_Type_Stmts
,
2678 Make_Procedure_Call_Statement
(Loc
,
2680 New_Reference_To
(RTE
(RE_Unregister_Tag
), Loc
),
2681 Parameter_Associations
=> New_List
(
2682 New_Reference_To
(DT_Ptr
, Loc
))));
2683 end Process_Tagged_Type_Declaration
;
2685 -- Start of processing for Build_Finalizer
2690 -- Do not perform this expansion in Alfa mode because it is not
2697 -- Step 1: Extract all lists which may contain controlled objects or
2698 -- library-level tagged types.
2700 if For_Package_Spec
then
2701 Decls
:= Visible_Declarations
(Specification
(N
));
2702 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2704 -- Retrieve the package spec id
2706 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2708 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2709 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2712 -- Accept statement, block, entry body, package body, protected body,
2713 -- subprogram body or task body.
2716 Decls
:= Declarations
(N
);
2717 HSS
:= Handled_Statement_Sequence
(N
);
2719 if Present
(HSS
) then
2720 if Present
(Statements
(HSS
)) then
2721 Stmts
:= Statements
(HSS
);
2724 if Present
(At_End_Proc
(HSS
)) then
2725 Prev_At_End
:= At_End_Proc
(HSS
);
2729 -- Retrieve the package spec id for package bodies
2731 if For_Package_Body
then
2732 Spec_Id
:= Corresponding_Spec
(N
);
2736 -- Do not process nested packages since those are handled by the
2737 -- enclosing scope's finalizer. Do not process non-expanded package
2738 -- instantiations since those will be re-analyzed and re-expanded.
2742 (not Is_Library_Level_Entity
(Spec_Id
)
2744 -- Nested packages are considered to be library level entities,
2745 -- but do not need to be processed separately. True library level
2746 -- packages have a scope value of 1.
2748 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2749 or else (Is_Generic_Instance
(Spec_Id
)
2750 and then Package_Instantiation
(Spec_Id
) /= N
))
2755 -- Step 2: Object [pre]processing
2759 -- Preprocess the visible declarations now in order to obtain the
2760 -- correct number of controlled object by the time the private
2761 -- declarations are processed.
2763 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2765 -- From all the possible contexts, only package specifications may
2766 -- have private declarations.
2768 if For_Package_Spec
then
2769 Process_Declarations
2770 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2773 -- The current context may lack controlled objects, but require some
2774 -- other form of completion (task termination for instance). In such
2775 -- cases, the finalizer must be created and carry the additional
2778 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2782 -- The preprocessing has determined that the context has controlled
2783 -- objects or library-level tagged types.
2785 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2787 -- Private declarations are processed first in order to preserve
2788 -- possible dependencies between public and private objects.
2790 if For_Package_Spec
then
2791 Process_Declarations
(Priv_Decls
);
2794 Process_Declarations
(Decls
);
2800 -- Preprocess both declarations and statements
2802 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2803 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
2805 -- At this point it is known that N has controlled objects. Ensure
2806 -- that N has a declarative list since the finalizer spec will be
2809 if Has_Ctrl_Objs
and then No
(Decls
) then
2810 Set_Declarations
(N
, New_List
);
2811 Decls
:= Declarations
(N
);
2812 Spec_Decls
:= Decls
;
2815 -- The current context may lack controlled objects, but require some
2816 -- other form of completion (task termination for instance). In such
2817 -- cases, the finalizer must be created and carry the additional
2820 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2824 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2825 Process_Declarations
(Stmts
);
2826 Process_Declarations
(Decls
);
2830 -- Step 3: Finalizer creation
2832 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2835 end Build_Finalizer
;
2837 --------------------------
2838 -- Build_Finalizer_Call --
2839 --------------------------
2841 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
2842 Loc
: constant Source_Ptr
:= Sloc
(N
);
2843 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
2845 Is_Prot_Body
: constant Boolean :=
2846 Nkind
(N
) = N_Subprogram_Body
2847 and then Is_Protected_Subprogram_Body
(N
);
2848 -- Determine whether N denotes the protected version of a subprogram
2849 -- which belongs to a protected type.
2852 -- Do not perform this expansion in Alfa mode because we do not create
2853 -- finalizers in the first place.
2859 -- The At_End handler should have been assimilated by the finalizer
2861 pragma Assert
(No
(At_End_Proc
(HSS
)));
2863 -- If the construct to be cleaned up is a protected subprogram body, the
2864 -- finalizer call needs to be associated with the block which wraps the
2865 -- unprotected version of the subprogram. The following illustrates this
2868 -- procedure Prot_SubpP is
2869 -- procedure finalizer is
2871 -- Service_Entries (Prot_Obj);
2878 -- Prot_SubpN (Prot_Obj);
2884 if Is_Prot_Body
then
2885 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
2887 -- An At_End handler and regular exception handlers cannot coexist in
2888 -- the same statement sequence. Wrap the original statements in a block.
2890 elsif Present
(Exception_Handlers
(HSS
)) then
2892 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
2897 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
2899 Set_Handled_Statement_Sequence
(N
,
2900 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
2902 HSS
:= Handled_Statement_Sequence
(N
);
2903 Set_End_Label
(HSS
, End_Lab
);
2907 Set_At_End_Proc
(HSS
, New_Reference_To
(Fin_Id
, Loc
));
2909 Analyze
(At_End_Proc
(HSS
));
2910 Expand_At_End_Handler
(HSS
, Empty
);
2911 end Build_Finalizer_Call
;
2913 ---------------------
2914 -- Build_Late_Proc --
2915 ---------------------
2917 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
2919 for Final_Prim
in Name_Of
'Range loop
2920 if Name_Of
(Final_Prim
) = Nam
then
2923 (Prim
=> Final_Prim
,
2925 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
2928 end Build_Late_Proc
;
2930 -------------------------------
2931 -- Build_Object_Declarations --
2932 -------------------------------
2934 procedure Build_Object_Declarations
2935 (Data
: out Finalization_Exception_Data
;
2938 For_Package
: Boolean := False)
2944 pragma Assert
(Decls
/= No_List
);
2946 if Restriction_Active
(No_Exception_Propagation
) then
2947 Data
.Abort_Id
:= Empty
;
2949 Data
.Raised_Id
:= Empty
;
2953 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
2954 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
2955 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
2958 -- In certain scenarios, finalization can be triggered by an abort. If
2959 -- the finalization itself fails and raises an exception, the resulting
2960 -- Program_Error must be supressed and replaced by an abort signal. In
2961 -- order to detect this scenario, save the state of entry into the
2962 -- finalization code.
2964 -- No need to do this for VM case, since VM version of Ada.Exceptions
2965 -- does not include routine Raise_From_Controlled_Operation which is the
2966 -- the sole user of flag Abort.
2968 -- This is not needed for library-level finalizers as they are called
2969 -- by the environment task and cannot be aborted.
2972 and then VM_Target
= No_VM
2973 and then not For_Package
2975 A_Expr
:= New_Reference_To
(RTE
(RE_Triggered_By_Abort
), Loc
);
2977 -- No abort, .NET/JVM or library-level finalizers
2980 A_Expr
:= New_Reference_To
(Standard_False
, Loc
);
2984 -- Abort_Id : constant Boolean := <A_Expr>;
2987 Make_Object_Declaration
(Loc
,
2988 Defining_Identifier
=> Data
.Abort_Id
,
2989 Constant_Present
=> True,
2990 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
2991 Expression
=> A_Expr
));
2994 -- E_Id : Exception_Occurrence;
2997 Make_Object_Declaration
(Loc
,
2998 Defining_Identifier
=> Data
.E_Id
,
2999 Object_Definition
=>
3000 New_Reference_To
(RTE
(RE_Exception_Occurrence
), Loc
));
3001 Set_No_Initialization
(E_Decl
);
3003 Append_To
(Decls
, E_Decl
);
3006 -- Raised_Id : Boolean := False;
3009 Make_Object_Declaration
(Loc
,
3010 Defining_Identifier
=> Data
.Raised_Id
,
3011 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3012 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
3013 end Build_Object_Declarations
;
3015 ---------------------------
3016 -- Build_Raise_Statement --
3017 ---------------------------
3019 function Build_Raise_Statement
3020 (Data
: Finalization_Exception_Data
) return Node_Id
3025 -- Standard run-time and .NET/JVM targets use the specialized routine
3026 -- Raise_From_Controlled_Operation.
3028 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
3030 Make_Procedure_Call_Statement
(Data
.Loc
,
3033 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3034 Parameter_Associations
=>
3035 New_List
(New_Reference_To
(Data
.E_Id
, Data
.Loc
)));
3037 -- Restricted run-time: exception messages are not supported and hence
3038 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3043 Make_Raise_Program_Error
(Data
.Loc
,
3044 Reason
=> PE_Finalize_Raised_Exception
);
3048 -- if Raised_Id and then not Abort_Id then
3049 -- Raise_From_Controlled_Operation (E_Id);
3051 -- raise Program_Error; -- restricted runtime
3055 Make_If_Statement
(Data
.Loc
,
3057 Make_And_Then
(Data
.Loc
,
3058 Left_Opnd
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
3060 Make_Op_Not
(Data
.Loc
,
3061 Right_Opnd
=> New_Reference_To
(Data
.Abort_Id
, Data
.Loc
))),
3063 Then_Statements
=> New_List
(Stmt
));
3064 end Build_Raise_Statement
;
3066 -----------------------------
3067 -- Build_Record_Deep_Procs --
3068 -----------------------------
3070 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3074 (Prim
=> Initialize_Case
,
3076 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3078 if not Is_Immutably_Limited_Type
(Typ
) then
3081 (Prim
=> Adjust_Case
,
3083 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3086 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3087 -- suppressed since these routine will not be used.
3089 if not Restriction_Active
(No_Finalization
) then
3092 (Prim
=> Finalize_Case
,
3094 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3096 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3097 -- .NET do not support address arithmetic and unchecked conversions.
3099 if VM_Target
= No_VM
then
3102 (Prim
=> Address_Case
,
3104 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3107 end Build_Record_Deep_Procs
;
3113 function Cleanup_Array
3116 Typ
: Entity_Id
) return List_Id
3118 Loc
: constant Source_Ptr
:= Sloc
(N
);
3119 Index_List
: constant List_Id
:= New_List
;
3121 function Free_Component
return List_Id
;
3122 -- Generate the code to finalize the task or protected subcomponents
3123 -- of a single component of the array.
3125 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3126 -- Generate a loop over one dimension of the array
3128 --------------------
3129 -- Free_Component --
3130 --------------------
3132 function Free_Component
return List_Id
is
3133 Stmts
: List_Id
:= New_List
;
3135 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3138 -- Component type is known to contain tasks or protected objects
3141 Make_Indexed_Component
(Loc
,
3142 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3143 Expressions
=> Index_List
);
3145 Set_Etype
(Tsk
, C_Typ
);
3147 if Is_Task_Type
(C_Typ
) then
3148 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3150 elsif Is_Simple_Protected_Type
(C_Typ
) then
3151 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3153 elsif Is_Record_Type
(C_Typ
) then
3154 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3156 elsif Is_Array_Type
(C_Typ
) then
3157 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3163 ------------------------
3164 -- Free_One_Dimension --
3165 ------------------------
3167 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3171 if Dim
> Number_Dimensions
(Typ
) then
3172 return Free_Component
;
3174 -- Here we generate the required loop
3177 Index
:= Make_Temporary
(Loc
, 'J');
3178 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
3181 Make_Implicit_Loop_Statement
(N
,
3182 Identifier
=> Empty
,
3184 Make_Iteration_Scheme
(Loc
,
3185 Loop_Parameter_Specification
=>
3186 Make_Loop_Parameter_Specification
(Loc
,
3187 Defining_Identifier
=> Index
,
3188 Discrete_Subtype_Definition
=>
3189 Make_Attribute_Reference
(Loc
,
3190 Prefix
=> Duplicate_Subexpr
(Obj
),
3191 Attribute_Name
=> Name_Range
,
3192 Expressions
=> New_List
(
3193 Make_Integer_Literal
(Loc
, Dim
))))),
3194 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3196 end Free_One_Dimension
;
3198 -- Start of processing for Cleanup_Array
3201 return Free_One_Dimension
(1);
3204 --------------------
3205 -- Cleanup_Record --
3206 --------------------
3208 function Cleanup_Record
3211 Typ
: Entity_Id
) return List_Id
3213 Loc
: constant Source_Ptr
:= Sloc
(N
);
3216 Stmts
: constant List_Id
:= New_List
;
3217 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3220 if Has_Discriminants
(U_Typ
)
3221 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3223 Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3226 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3228 -- For now, do not attempt to free a component that may appear in a
3229 -- variant, and instead issue a warning. Doing this "properly" would
3230 -- require building a case statement and would be quite a mess. Note
3231 -- that the RM only requires that free "work" for the case of a task
3232 -- access value, so already we go way beyond this in that we deal
3233 -- with the array case and non-discriminated record cases.
3236 ("task/protected object in variant record will not be freed?", N
);
3237 return New_List
(Make_Null_Statement
(Loc
));
3240 Comp
:= First_Component
(Typ
);
3241 while Present
(Comp
) loop
3242 if Has_Task
(Etype
(Comp
))
3243 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3246 Make_Selected_Component
(Loc
,
3247 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3248 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3249 Set_Etype
(Tsk
, Etype
(Comp
));
3251 if Is_Task_Type
(Etype
(Comp
)) then
3252 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3254 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3255 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3257 elsif Is_Record_Type
(Etype
(Comp
)) then
3259 -- Recurse, by generating the prefix of the argument to
3260 -- the eventual cleanup call.
3262 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3264 elsif Is_Array_Type
(Etype
(Comp
)) then
3265 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3269 Next_Component
(Comp
);
3275 ------------------------------
3276 -- Cleanup_Protected_Object --
3277 ------------------------------
3279 function Cleanup_Protected_Object
3281 Ref
: Node_Id
) return Node_Id
3283 Loc
: constant Source_Ptr
:= Sloc
(N
);
3286 -- For restricted run-time libraries (Ravenscar), tasks are
3287 -- non-terminating, and protected objects can only appear at library
3288 -- level, so we do not want finalization of protected objects.
3290 if Restricted_Profile
then
3295 Make_Procedure_Call_Statement
(Loc
,
3297 New_Reference_To
(RTE
(RE_Finalize_Protection
), Loc
),
3298 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3300 end Cleanup_Protected_Object
;
3306 function Cleanup_Task
3308 Ref
: Node_Id
) return Node_Id
3310 Loc
: constant Source_Ptr
:= Sloc
(N
);
3313 -- For restricted run-time libraries (Ravenscar), tasks are
3314 -- non-terminating and they can only appear at library level, so we do
3315 -- not want finalization of task objects.
3317 if Restricted_Profile
then
3322 Make_Procedure_Call_Statement
(Loc
,
3324 New_Reference_To
(RTE
(RE_Free_Task
), Loc
),
3325 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3329 ------------------------------
3330 -- Check_Visibly_Controlled --
3331 ------------------------------
3333 procedure Check_Visibly_Controlled
3334 (Prim
: Final_Primitives
;
3336 E
: in out Entity_Id
;
3337 Cref
: in out Node_Id
)
3339 Parent_Type
: Entity_Id
;
3343 if Is_Derived_Type
(Typ
)
3344 and then Comes_From_Source
(E
)
3345 and then not Present
(Overridden_Operation
(E
))
3347 -- We know that the explicit operation on the type does not override
3348 -- the inherited operation of the parent, and that the derivation
3349 -- is from a private type that is not visibly controlled.
3351 Parent_Type
:= Etype
(Typ
);
3352 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3354 if Present
(Op
) then
3357 -- Wrap the object to be initialized into the proper
3358 -- unchecked conversion, to be compatible with the operation
3361 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3362 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3364 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3368 end Check_Visibly_Controlled
;
3370 -------------------------------
3371 -- CW_Or_Has_Controlled_Part --
3372 -------------------------------
3374 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3376 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3377 end CW_Or_Has_Controlled_Part
;
3383 function Convert_View
3386 Ind
: Pos
:= 1) return Node_Id
3388 Fent
: Entity_Id
:= First_Entity
(Proc
);
3393 for J
in 2 .. Ind
loop
3397 Ftyp
:= Etype
(Fent
);
3399 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3400 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3402 Atyp
:= Etype
(Arg
);
3405 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3406 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3409 and then Present
(Atyp
)
3410 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3411 and then Base_Type
(Underlying_Type
(Atyp
)) =
3412 Base_Type
(Underlying_Type
(Ftyp
))
3414 return Unchecked_Convert_To
(Ftyp
, Arg
);
3416 -- If the argument is already a conversion, as generated by
3417 -- Make_Init_Call, set the target type to the type of the formal
3418 -- directly, to avoid spurious typing problems.
3420 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3421 and then not Is_Class_Wide_Type
(Atyp
)
3423 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3424 Set_Etype
(Arg
, Ftyp
);
3432 ------------------------
3433 -- Enclosing_Function --
3434 ------------------------
3436 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3437 Func_Id
: Entity_Id
;
3441 while Present
(Func_Id
)
3442 and then Func_Id
/= Standard_Standard
3444 if Ekind
(Func_Id
) = E_Function
then
3448 Func_Id
:= Scope
(Func_Id
);
3452 end Enclosing_Function
;
3454 -------------------------------
3455 -- Establish_Transient_Scope --
3456 -------------------------------
3458 -- This procedure is called each time a transient block has to be inserted
3459 -- that is to say for each call to a function with unconstrained or tagged
3460 -- result. It creates a new scope on the stack scope in order to enclose
3461 -- all transient variables generated
3463 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3464 Loc
: constant Source_Ptr
:= Sloc
(N
);
3465 Wrap_Node
: Node_Id
;
3468 -- Do not create a transient scope if we are already inside one
3470 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3471 if Scope_Stack
.Table
(S
).Is_Transient
then
3473 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3478 -- If we have encountered Standard there are no enclosing
3479 -- transient scopes.
3481 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3486 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3488 -- Case of no wrap node, false alert, no transient scope needed
3490 if No
(Wrap_Node
) then
3493 -- If the node to wrap is an iteration_scheme, the expression is
3494 -- one of the bounds, and the expansion will make an explicit
3495 -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3496 -- so do not apply any transformations here.
3498 elsif Nkind
(Wrap_Node
) = N_Iteration_Scheme
then
3501 -- In formal verification mode, if the node to wrap is a pragma check,
3502 -- this node and enclosed expression are not expanded, so do not apply
3503 -- any transformations here.
3506 and then Nkind
(Wrap_Node
) = N_Pragma
3507 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3512 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3513 Set_Scope_Is_Transient
;
3516 Set_Uses_Sec_Stack
(Current_Scope
);
3517 Check_Restriction
(No_Secondary_Stack
, N
);
3520 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3521 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3523 if Debug_Flag_W
then
3524 Write_Str
(" <Transient>");
3528 end Establish_Transient_Scope
;
3530 ----------------------------
3531 -- Expand_Cleanup_Actions --
3532 ----------------------------
3534 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3535 Scop
: constant Entity_Id
:= Current_Scope
;
3537 Is_Asynchronous_Call
: constant Boolean :=
3538 Nkind
(N
) = N_Block_Statement
3539 and then Is_Asynchronous_Call_Block
(N
);
3540 Is_Master
: constant Boolean :=
3541 Nkind
(N
) /= N_Entry_Body
3542 and then Is_Task_Master
(N
);
3543 Is_Protected_Body
: constant Boolean :=
3544 Nkind
(N
) = N_Subprogram_Body
3545 and then Is_Protected_Subprogram_Body
(N
);
3546 Is_Task_Allocation
: constant Boolean :=
3547 Nkind
(N
) = N_Block_Statement
3548 and then Is_Task_Allocation_Block
(N
);
3549 Is_Task_Body
: constant Boolean :=
3550 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3551 Needs_Sec_Stack_Mark
: constant Boolean :=
3552 Uses_Sec_Stack
(Scop
)
3554 not Sec_Stack_Needed_For_Return
(Scop
)
3555 and then VM_Target
= No_VM
;
3557 Actions_Required
: constant Boolean :=
3558 Requires_Cleanup_Actions
(N
)
3559 or else Is_Asynchronous_Call
3561 or else Is_Protected_Body
3562 or else Is_Task_Allocation
3563 or else Is_Task_Body
3564 or else Needs_Sec_Stack_Mark
;
3566 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3569 procedure Wrap_HSS_In_Block
;
3570 -- Move HSS inside a new block along with the original exception
3571 -- handlers. Make the newly generated block the sole statement of HSS.
3573 -----------------------
3574 -- Wrap_HSS_In_Block --
3575 -----------------------
3577 procedure Wrap_HSS_In_Block
is
3582 -- Preserve end label to provide proper cross-reference information
3584 End_Lab
:= End_Label
(HSS
);
3586 Make_Block_Statement
(Loc
,
3587 Handled_Statement_Sequence
=> HSS
);
3589 Set_Handled_Statement_Sequence
(N
,
3590 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3591 HSS
:= Handled_Statement_Sequence
(N
);
3593 Set_First_Real_Statement
(HSS
, Block
);
3594 Set_End_Label
(HSS
, End_Lab
);
3596 -- Comment needed here, see RH for 1.306 ???
3598 if Nkind
(N
) = N_Subprogram_Body
then
3599 Set_Has_Nested_Block_With_Handler
(Scop
);
3601 end Wrap_HSS_In_Block
;
3603 -- Start of processing for Expand_Cleanup_Actions
3606 -- The current construct does not need any form of servicing
3608 if not Actions_Required
then
3611 -- If the current node is a rewritten task body and the descriptors have
3612 -- not been delayed (due to some nested instantiations), do not generate
3613 -- redundant cleanup actions.
3616 and then Nkind
(N
) = N_Subprogram_Body
3617 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3623 Decls
: List_Id
:= Declarations
(N
);
3625 Mark
: Entity_Id
:= Empty
;
3626 New_Decls
: List_Id
;
3630 -- If we are generating expanded code for debugging purposes, use the
3631 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3632 -- be updated subsequently to reference the proper line in .dg files.
3633 -- If we are not debugging generated code, use No_Location instead,
3634 -- so that no debug information is generated for the cleanup code.
3635 -- This makes the behavior of the NEXT command in GDB monotonic, and
3636 -- makes the placement of breakpoints more accurate.
3638 if Debug_Generated_Code
then
3644 -- Set polling off. The finalization and cleanup code is executed
3645 -- with aborts deferred.
3647 Old_Poll
:= Polling_Required
;
3648 Polling_Required
:= False;
3650 -- A task activation call has already been built for a task
3651 -- allocation block.
3653 if not Is_Task_Allocation
then
3654 Build_Task_Activation_Call
(N
);
3658 Establish_Task_Master
(N
);
3661 New_Decls
:= New_List
;
3663 -- If secondary stack is in use, generate:
3665 -- Mnn : constant Mark_Id := SS_Mark;
3667 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3668 -- secondary stack is never used on a VM.
3670 if Needs_Sec_Stack_Mark
then
3671 Mark
:= Make_Temporary
(Loc
, 'M');
3673 Append_To
(New_Decls
,
3674 Make_Object_Declaration
(Loc
,
3675 Defining_Identifier
=> Mark
,
3676 Object_Definition
=>
3677 New_Reference_To
(RTE
(RE_Mark_Id
), Loc
),
3679 Make_Function_Call
(Loc
,
3680 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
))));
3682 Set_Uses_Sec_Stack
(Scop
, False);
3685 -- If exception handlers are present, wrap the sequence of statements
3686 -- in a block since it is not possible to have exception handlers and
3687 -- an At_End handler in the same construct.
3689 if Present
(Exception_Handlers
(HSS
)) then
3692 -- Ensure that the First_Real_Statement field is set
3694 elsif No
(First_Real_Statement
(HSS
)) then
3695 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3698 -- Do not move the Activation_Chain declaration in the context of
3699 -- task allocation blocks. Task allocation blocks use _chain in their
3700 -- cleanup handlers and gigi complains if it is declared in the
3701 -- sequence of statements of the scope that declares the handler.
3703 if Is_Task_Allocation
then
3705 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3709 Decl
:= First
(Decls
);
3710 while Nkind
(Decl
) /= N_Object_Declaration
3711 or else Defining_Identifier
(Decl
) /= Chain
3715 -- A task allocation block should always include a _chain
3718 pragma Assert
(Present
(Decl
));
3722 Prepend_To
(New_Decls
, Decl
);
3726 -- Ensure the presence of a declaration list in order to successfully
3727 -- append all original statements to it.
3730 Set_Declarations
(N
, New_List
);
3731 Decls
:= Declarations
(N
);
3734 -- Move the declarations into the sequence of statements in order to
3735 -- have them protected by the At_End handler. It may seem weird to
3736 -- put declarations in the sequence of statement but in fact nothing
3737 -- forbids that at the tree level.
3739 Append_List_To
(Decls
, Statements
(HSS
));
3740 Set_Statements
(HSS
, Decls
);
3742 -- Reset the Sloc of the handled statement sequence to properly
3743 -- reflect the new initial "statement" in the sequence.
3745 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
3747 -- The declarations of finalizer spec and auxiliary variables replace
3748 -- the old declarations that have been moved inward.
3750 Set_Declarations
(N
, New_Decls
);
3751 Analyze_Declarations
(New_Decls
);
3753 -- Generate finalization calls for all controlled objects appearing
3754 -- in the statements of N. Add context specific cleanup for various
3759 Clean_Stmts
=> Build_Cleanup_Statements
(N
),
3761 Top_Decls
=> New_Decls
,
3762 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
3766 if Present
(Fin_Id
) then
3767 Build_Finalizer_Call
(N
, Fin_Id
);
3770 -- Restore saved polling mode
3772 Polling_Required
:= Old_Poll
;
3774 end Expand_Cleanup_Actions
;
3776 ---------------------------
3777 -- Expand_N_Package_Body --
3778 ---------------------------
3780 -- Add call to Activate_Tasks if body is an activator (actual processing
3781 -- is in chapter 9).
3783 -- Generate subprogram descriptor for elaboration routine
3785 -- Encode entity names in package body
3787 procedure Expand_N_Package_Body
(N
: Node_Id
) is
3788 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
3792 -- This is done only for non-generic packages
3794 if Ekind
(Spec_Ent
) = E_Package
then
3795 Push_Scope
(Corresponding_Spec
(N
));
3797 -- Build dispatch tables of library level tagged types
3799 if Tagged_Type_Expansion
3800 and then Is_Library_Level_Entity
(Spec_Ent
)
3802 Build_Static_Dispatch_Tables
(N
);
3805 Build_Task_Activation_Call
(N
);
3809 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
3810 Set_In_Package_Body
(Spec_Ent
, False);
3812 -- Set to encode entity names in package body before gigi is called
3814 Qualify_Entity_Names
(N
);
3816 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
3819 Clean_Stmts
=> No_List
,
3821 Top_Decls
=> No_List
,
3822 Defer_Abort
=> False,
3825 if Present
(Fin_Id
) then
3827 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
3830 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
3831 Body_Ent
:= Defining_Identifier
(Body_Ent
);
3834 Set_Finalizer
(Body_Ent
, Fin_Id
);
3838 end Expand_N_Package_Body
;
3840 ----------------------------------
3841 -- Expand_N_Package_Declaration --
3842 ----------------------------------
3844 -- Add call to Activate_Tasks if there are tasks declared and the package
3845 -- has no body. Note that in Ada 83 this may result in premature activation
3846 -- of some tasks, given that we cannot tell whether a body will eventually
3849 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
3850 Id
: constant Entity_Id
:= Defining_Entity
(N
);
3851 Spec
: constant Node_Id
:= Specification
(N
);
3855 No_Body
: Boolean := False;
3856 -- True in the case of a package declaration that is a compilation
3857 -- unit and for which no associated body will be compiled in this
3861 -- Case of a package declaration other than a compilation unit
3863 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3866 -- Case of a compilation unit that does not require a body
3868 elsif not Body_Required
(Parent
(N
))
3869 and then not Unit_Requires_Body
(Id
)
3873 -- Special case of generating calling stubs for a remote call interface
3874 -- package: even though the package declaration requires one, the body
3875 -- won't be processed in this compilation (so any stubs for RACWs
3876 -- declared in the package must be generated here, along with the spec).
3878 elsif Parent
(N
) = Cunit
(Main_Unit
)
3879 and then Is_Remote_Call_Interface
(Id
)
3880 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
3885 -- For a nested instance, delay processing until freeze point
3887 if Has_Delayed_Freeze
(Id
)
3888 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3893 -- For a package declaration that implies no associated body, generate
3894 -- task activation call and RACW supporting bodies now (since we won't
3895 -- have a specific separate compilation unit for that).
3900 if Has_RACW
(Id
) then
3902 -- Generate RACW subprogram bodies
3904 Decls
:= Private_Declarations
(Spec
);
3907 Decls
:= Visible_Declarations
(Spec
);
3912 Set_Visible_Declarations
(Spec
, Decls
);
3915 Append_RACW_Bodies
(Decls
, Id
);
3916 Analyze_List
(Decls
);
3919 if Present
(Activation_Chain_Entity
(N
)) then
3921 -- Generate task activation call as last step of elaboration
3923 Build_Task_Activation_Call
(N
);
3929 -- Build dispatch tables of library level tagged types
3931 if Tagged_Type_Expansion
3932 and then (Is_Compilation_Unit
(Id
)
3933 or else (Is_Generic_Instance
(Id
)
3934 and then Is_Library_Level_Entity
(Id
)))
3936 Build_Static_Dispatch_Tables
(N
);
3939 -- Note: it is not necessary to worry about generating a subprogram
3940 -- descriptor, since the only way to get exception handlers into a
3941 -- package spec is to include instantiations, and that would cause
3942 -- generation of subprogram descriptors to be delayed in any case.
3944 -- Set to encode entity names in package spec before gigi is called
3946 Qualify_Entity_Names
(N
);
3948 if Ekind
(Id
) /= E_Generic_Package
then
3951 Clean_Stmts
=> No_List
,
3953 Top_Decls
=> No_List
,
3954 Defer_Abort
=> False,
3957 Set_Finalizer
(Id
, Fin_Id
);
3959 end Expand_N_Package_Declaration
;
3961 -----------------------------
3962 -- Find_Node_To_Be_Wrapped --
3963 -----------------------------
3965 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
3967 The_Parent
: Node_Id
;
3973 pragma Assert
(P
/= Empty
);
3974 The_Parent
:= Parent
(P
);
3976 case Nkind
(The_Parent
) is
3978 -- Simple statement can be wrapped
3983 -- Usually assignments are good candidate for wrapping except
3984 -- when they have been generated as part of a controlled aggregate
3985 -- where the wrapping should take place more globally.
3987 when N_Assignment_Statement
=>
3988 if No_Ctrl_Actions
(The_Parent
) then
3994 -- An entry call statement is a special case if it occurs in the
3995 -- context of a Timed_Entry_Call. In this case we wrap the entire
3996 -- timed entry call.
3998 when N_Entry_Call_Statement |
3999 N_Procedure_Call_Statement
=>
4000 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4001 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4003 N_Conditional_Entry_Call
)
4005 return Parent
(Parent
(The_Parent
));
4010 -- Object declarations are also a boundary for the transient scope
4011 -- even if they are not really wrapped. For further details, see
4012 -- Wrap_Transient_Declaration.
4014 when N_Object_Declaration |
4015 N_Object_Renaming_Declaration |
4016 N_Subtype_Declaration
=>
4019 -- The expression itself is to be wrapped if its parent is a
4020 -- compound statement or any other statement where the expression
4021 -- is known to be scalar
4023 when N_Accept_Alternative |
4024 N_Attribute_Definition_Clause |
4027 N_Delay_Alternative |
4028 N_Delay_Until_Statement |
4029 N_Delay_Relative_Statement |
4030 N_Discriminant_Association |
4032 N_Entry_Body_Formal_Part |
4035 N_Iteration_Scheme |
4036 N_Terminate_Alternative
=>
4039 when N_Attribute_Reference
=>
4041 if Is_Procedure_Attribute_Name
4042 (Attribute_Name
(The_Parent
))
4047 -- A raise statement can be wrapped. This will arise when the
4048 -- expression in a raise_with_expression uses the secondary
4049 -- stack, for example.
4051 when N_Raise_Statement
=>
4054 -- If the expression is within the iteration scheme of a loop,
4055 -- we must create a declaration for it, followed by an assignment
4056 -- in order to have a usable statement to wrap.
4058 when N_Loop_Parameter_Specification
=>
4059 return Parent
(The_Parent
);
4061 -- The following nodes contains "dummy calls" which don't need to
4064 when N_Parameter_Specification |
4065 N_Discriminant_Specification |
4066 N_Component_Declaration
=>
4069 -- The return statement is not to be wrapped when the function
4070 -- itself needs wrapping at the outer-level
4072 when N_Simple_Return_Statement
=>
4074 Applies_To
: constant Entity_Id
:=
4076 (Return_Statement_Entity
(The_Parent
));
4077 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4079 if Requires_Transient_Scope
(Return_Type
) then
4086 -- If we leave a scope without having been able to find a node to
4087 -- wrap, something is going wrong but this can happen in error
4088 -- situation that are not detected yet (such as a dynamic string
4089 -- in a pragma export)
4091 when N_Subprogram_Body |
4092 N_Package_Declaration |
4094 N_Block_Statement
=>
4097 -- Otherwise continue the search
4103 end Find_Node_To_Be_Wrapped
;
4105 -------------------------------------
4106 -- Get_Global_Pool_For_Access_Type --
4107 -------------------------------------
4109 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4111 -- Access types whose size is smaller than System.Address size can exist
4112 -- only on VMS. We can't use the usual global pool which returns an
4113 -- object of type Address as truncation will make it invalid. To handle
4114 -- this case, VMS has a dedicated global pool that returns addresses
4115 -- that fit into 32 bit accesses.
4117 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4118 return RTE
(RE_Global_Pool_32_Object
);
4120 return RTE
(RE_Global_Pool_Object
);
4122 end Get_Global_Pool_For_Access_Type
;
4124 ----------------------------------
4125 -- Has_New_Controlled_Component --
4126 ----------------------------------
4128 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4132 if not Is_Tagged_Type
(E
) then
4133 return Has_Controlled_Component
(E
);
4134 elsif not Is_Derived_Type
(E
) then
4135 return Has_Controlled_Component
(E
);
4138 Comp
:= First_Component
(E
);
4139 while Present
(Comp
) loop
4140 if Chars
(Comp
) = Name_uParent
then
4143 elsif Scope
(Original_Record_Component
(Comp
)) = E
4144 and then Needs_Finalization
(Etype
(Comp
))
4149 Next_Component
(Comp
);
4153 end Has_New_Controlled_Component
;
4155 ---------------------------------
4156 -- Has_Simple_Protected_Object --
4157 ---------------------------------
4159 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4161 if Has_Task
(T
) then
4164 elsif Is_Simple_Protected_Type
(T
) then
4167 elsif Is_Array_Type
(T
) then
4168 return Has_Simple_Protected_Object
(Component_Type
(T
));
4170 elsif Is_Record_Type
(T
) then
4175 Comp
:= First_Component
(T
);
4176 while Present
(Comp
) loop
4177 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4181 Next_Component
(Comp
);
4190 end Has_Simple_Protected_Object
;
4192 ------------------------------------
4193 -- Insert_Actions_In_Scope_Around --
4194 ------------------------------------
4196 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
) is
4197 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
4198 After
: List_Id
renames SE
.Actions_To_Be_Wrapped_After
;
4199 Before
: List_Id
renames SE
.Actions_To_Be_Wrapped_Before
;
4201 procedure Process_Transient_Objects
4202 (First_Object
: Node_Id
;
4203 Last_Object
: Node_Id
;
4204 Related_Node
: Node_Id
);
4205 -- First_Object and Last_Object define a list which contains potential
4206 -- controlled transient objects. Finalization flags are inserted before
4207 -- First_Object and finalization calls are inserted after Last_Object.
4208 -- Related_Node is the node for which transient objects have been
4211 -------------------------------
4212 -- Process_Transient_Objects --
4213 -------------------------------
4215 procedure Process_Transient_Objects
4216 (First_Object
: Node_Id
;
4217 Last_Object
: Node_Id
;
4218 Related_Node
: Node_Id
)
4220 Requires_Hooking
: constant Boolean :=
4221 Nkind_In
(N
, N_Function_Call
,
4222 N_Procedure_Call_Statement
);
4224 Built
: Boolean := False;
4225 Desig_Typ
: Entity_Id
;
4226 Fin_Block
: Node_Id
;
4227 Fin_Data
: Finalization_Exception_Data
;
4228 Fin_Decls
: List_Id
;
4229 Last_Fin
: Node_Id
:= Empty
;
4233 Obj_Typ
: Entity_Id
;
4236 Temp_Id
: Entity_Id
;
4239 -- Examine all objects in the list First_Object .. Last_Object
4241 Stmt
:= First_Object
;
4242 while Present
(Stmt
) loop
4243 if Nkind
(Stmt
) = N_Object_Declaration
4244 and then Analyzed
(Stmt
)
4245 and then Is_Finalizable_Transient
(Stmt
, N
)
4247 -- Do not process the node to be wrapped since it will be
4248 -- handled by the enclosing finalizer.
4250 and then Stmt
/= Related_Node
4253 Obj_Id
:= Defining_Identifier
(Stmt
);
4254 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4255 Desig_Typ
:= Obj_Typ
;
4257 Set_Is_Processed_Transient
(Obj_Id
);
4259 -- Handle access types
4261 if Is_Access_Type
(Desig_Typ
) then
4262 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4265 -- Create the necessary entities and declarations the first
4269 Fin_Decls
:= New_List
;
4271 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4272 Insert_List_Before_And_Analyze
(First_Object
, Fin_Decls
);
4277 -- Transient variables associated with subprogram calls need
4278 -- extra processing. These variables are usually created right
4279 -- before the call and finalized immediately after the call.
4280 -- If an exception occurs during the call, the clean up code
4281 -- is skipped due to the sudden change in control and the
4282 -- transient is never finalized.
4284 -- To handle this case, such variables are "exported" to the
4285 -- enclosing sequence of statements where their corresponding
4286 -- "hooks" are picked up by the finalization machinery.
4288 if Requires_Hooking
then
4294 -- Step 1: Create an access type which provides a
4295 -- reference to the transient object. Generate:
4297 -- Ann : access [all] <Desig_Typ>;
4299 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4301 Insert_Action
(Stmt
,
4302 Make_Full_Type_Declaration
(Loc
,
4303 Defining_Identifier
=> Ptr_Id
,
4305 Make_Access_To_Object_Definition
(Loc
,
4307 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4308 Subtype_Indication
=>
4309 New_Reference_To
(Desig_Typ
, Loc
))));
4311 -- Step 2: Create a temporary which acts as a hook to
4312 -- the transient object. Generate:
4314 -- Temp : Ptr_Id := null;
4316 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4318 Insert_Action
(Stmt
,
4319 Make_Object_Declaration
(Loc
,
4320 Defining_Identifier
=> Temp_Id
,
4321 Object_Definition
=>
4322 New_Reference_To
(Ptr_Id
, Loc
)));
4324 -- Mark the temporary as a transient hook. This signals
4325 -- the machinery in Build_Finalizer to recognize this
4328 Set_Return_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4330 -- Step 3: Hook the transient object to the temporary
4332 if Is_Access_Type
(Obj_Typ
) then
4334 Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
4337 Make_Attribute_Reference
(Loc
,
4338 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
4339 Attribute_Name
=> Name_Unrestricted_Access
);
4343 -- Temp := Ptr_Id (Obj_Id);
4345 -- Temp := Obj_Id'Unrestricted_Access;
4347 Insert_After_And_Analyze
(Stmt
,
4348 Make_Assignment_Statement
(Loc
,
4349 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4350 Expression
=> Expr
));
4356 -- The transient object is about to be finalized by the clean
4357 -- up code following the subprogram call. In order to avoid
4358 -- double finalization, clear the hook.
4363 if Requires_Hooking
then
4365 Make_Assignment_Statement
(Loc
,
4366 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4367 Expression
=> Make_Null
(Loc
)));
4371 -- [Deep_]Finalize (Obj_Ref);
4373 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
4375 if Is_Access_Type
(Obj_Typ
) then
4376 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4380 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4385 -- [Deep_]Finalize (Obj_Ref);
4389 -- if not Raised then
4392 -- (Enn, Get_Current_Excep.all.all);
4397 Make_Block_Statement
(Loc
,
4398 Handled_Statement_Sequence
=>
4399 Make_Handled_Sequence_Of_Statements
(Loc
,
4400 Statements
=> Stmts
,
4401 Exception_Handlers
=> New_List
(
4402 Build_Exception_Handler
(Fin_Data
))));
4404 Insert_After_And_Analyze
(Last_Object
, Fin_Block
);
4406 -- The raise statement must be inserted after all the
4407 -- finalization blocks.
4409 if No
(Last_Fin
) then
4410 Last_Fin
:= Fin_Block
;
4413 -- When the associated node is an array object, the expander may
4414 -- sometimes generate a loop and create transient objects inside
4417 elsif Nkind
(Related_Node
) = N_Object_Declaration
4418 and then Is_Array_Type
4420 (Etype
(Defining_Identifier
(Related_Node
))))
4421 and then Nkind
(Stmt
) = N_Loop_Statement
4424 Block_HSS
: Node_Id
:= First
(Statements
(Stmt
));
4427 -- The loop statements may have been wrapped in a block by
4428 -- Process_Statements_For_Controlled_Objects, inspect the
4429 -- handled sequence of statements.
4431 if Nkind
(Block_HSS
) = N_Block_Statement
4432 and then No
(Next
(Block_HSS
))
4434 Block_HSS
:= Handled_Statement_Sequence
(Block_HSS
);
4436 Process_Transient_Objects
4437 (First_Object
=> First
(Statements
(Block_HSS
)),
4438 Last_Object
=> Last
(Statements
(Block_HSS
)),
4439 Related_Node
=> Related_Node
);
4441 -- Inspect the statements of the loop
4444 Process_Transient_Objects
4445 (First_Object
=> First
(Statements
(Stmt
)),
4446 Last_Object
=> Last
(Statements
(Stmt
)),
4447 Related_Node
=> Related_Node
);
4451 -- Terminate the scan after the last object has been processed
4453 elsif Stmt
= Last_Object
then
4461 -- if Raised and then not Abort then
4462 -- Raise_From_Controlled_Operation (E);
4466 and then Present
(Last_Fin
)
4468 Insert_After_And_Analyze
(Last_Fin
,
4469 Build_Raise_Statement
(Fin_Data
));
4471 end Process_Transient_Objects
;
4473 -- Start of processing for Insert_Actions_In_Scope_Around
4476 if No
(Before
) and then No
(After
) then
4481 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4482 First_Obj
: Node_Id
;
4487 -- If the node to be wrapped is the trigger of an asynchronous
4488 -- select, it is not part of a statement list. The actions must be
4489 -- inserted before the select itself, which is part of some list of
4490 -- statements. Note that the triggering alternative includes the
4491 -- triggering statement and an optional statement list. If the node
4492 -- to be wrapped is part of that list, the normal insertion applies.
4494 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4495 and then not Is_List_Member
(Node_To_Wrap
)
4497 Target
:= Parent
(Parent
(Node_To_Wrap
));
4502 First_Obj
:= Target
;
4505 -- Add all actions associated with a transient scope into the main
4506 -- tree. There are several scenarios here:
4508 -- +--- Before ----+ +----- After ---+
4509 -- 1) First_Obj ....... Target ........ Last_Obj
4511 -- 2) First_Obj ....... Target
4513 -- 3) Target ........ Last_Obj
4515 if Present
(Before
) then
4517 -- Flag declarations are inserted before the first object
4519 First_Obj
:= First
(Before
);
4521 Insert_List_Before
(Target
, Before
);
4524 if Present
(After
) then
4526 -- Finalization calls are inserted after the last object
4528 Last_Obj
:= Last
(After
);
4530 Insert_List_After
(Target
, After
);
4533 -- Check for transient controlled objects associated with Target and
4534 -- generate the appropriate finalization actions for them.
4536 Process_Transient_Objects
4537 (First_Object
=> First_Obj
,
4538 Last_Object
=> Last_Obj
,
4539 Related_Node
=> Target
);
4541 -- Reset the action lists
4543 if Present
(Before
) then
4547 if Present
(After
) then
4551 end Insert_Actions_In_Scope_Around
;
4553 ------------------------------
4554 -- Is_Simple_Protected_Type --
4555 ------------------------------
4557 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4560 Is_Protected_Type
(T
)
4561 and then not Has_Entries
(T
)
4562 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4563 end Is_Simple_Protected_Type
;
4565 -----------------------
4566 -- Make_Adjust_Call --
4567 -----------------------
4569 function Make_Adjust_Call
4572 For_Parent
: Boolean := False) return Node_Id
4574 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4575 Adj_Id
: Entity_Id
:= Empty
;
4576 Ref
: Node_Id
:= Obj_Ref
;
4580 -- Recover the proper type which contains Deep_Adjust
4582 if Is_Class_Wide_Type
(Typ
) then
4583 Utyp
:= Root_Type
(Typ
);
4588 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4589 Set_Assignment_OK
(Ref
);
4591 -- Deal with non-tagged derivation of private views
4593 if Is_Untagged_Derivation
(Typ
) then
4594 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4595 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4596 Set_Assignment_OK
(Ref
);
4599 -- When dealing with the completion of a private type, use the base
4602 if Utyp
/= Base_Type
(Utyp
) then
4603 pragma Assert
(Is_Private_Type
(Typ
));
4605 Utyp
:= Base_Type
(Utyp
);
4606 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4609 -- Select the appropriate version of adjust
4612 if Has_Controlled_Component
(Utyp
) then
4613 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4616 -- Class-wide types, interfaces and types with controlled components
4618 elsif Is_Class_Wide_Type
(Typ
)
4619 or else Is_Interface
(Typ
)
4620 or else Has_Controlled_Component
(Utyp
)
4622 if Is_Tagged_Type
(Utyp
) then
4623 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4625 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
4628 -- Derivations from [Limited_]Controlled
4630 elsif Is_Controlled
(Utyp
) then
4631 if Has_Controlled_Component
(Utyp
) then
4632 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4634 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
4639 elsif Is_Tagged_Type
(Utyp
) then
4640 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4643 raise Program_Error
;
4646 if Present
(Adj_Id
) then
4648 -- If the object is unanalyzed, set its expected type for use in
4649 -- Convert_View in case an additional conversion is needed.
4652 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
4654 Set_Etype
(Ref
, Typ
);
4657 -- The object reference may need another conversion depending on the
4658 -- type of the formal and that of the actual.
4660 if not Is_Class_Wide_Type
(Typ
) then
4661 Ref
:= Convert_View
(Adj_Id
, Ref
);
4664 return Make_Call
(Loc
, Adj_Id
, New_Copy_Tree
(Ref
), For_Parent
);
4668 end Make_Adjust_Call
;
4670 ----------------------
4671 -- Make_Attach_Call --
4672 ----------------------
4674 function Make_Attach_Call
4676 Ptr_Typ
: Entity_Id
) return Node_Id
4678 pragma Assert
(VM_Target
/= No_VM
);
4680 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4683 Make_Procedure_Call_Statement
(Loc
,
4685 New_Reference_To
(RTE
(RE_Attach
), Loc
),
4686 Parameter_Associations
=> New_List
(
4687 New_Reference_To
(Finalization_Master
(Ptr_Typ
), Loc
),
4688 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4689 end Make_Attach_Call
;
4691 ----------------------
4692 -- Make_Detach_Call --
4693 ----------------------
4695 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
4696 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4700 Make_Procedure_Call_Statement
(Loc
,
4702 New_Reference_To
(RTE
(RE_Detach
), Loc
),
4703 Parameter_Associations
=> New_List
(
4704 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4705 end Make_Detach_Call
;
4713 Proc_Id
: Entity_Id
;
4715 For_Parent
: Boolean := False) return Node_Id
4717 Params
: constant List_Id
:= New_List
(Param
);
4720 -- When creating a call to Deep_Finalize for a _parent field of a
4721 -- derived type, disable the invocation of the nested Finalize by giving
4722 -- the corresponding flag a False value.
4725 Append_To
(Params
, New_Reference_To
(Standard_False
, Loc
));
4729 Make_Procedure_Call_Statement
(Loc
,
4730 Name
=> New_Reference_To
(Proc_Id
, Loc
),
4731 Parameter_Associations
=> Params
);
4734 --------------------------
4735 -- Make_Deep_Array_Body --
4736 --------------------------
4738 function Make_Deep_Array_Body
4739 (Prim
: Final_Primitives
;
4740 Typ
: Entity_Id
) return List_Id
4742 function Build_Adjust_Or_Finalize_Statements
4743 (Typ
: Entity_Id
) return List_Id
;
4744 -- Create the statements necessary to adjust or finalize an array of
4745 -- controlled elements. Generate:
4748 -- Abort : constant Boolean := Triggered_By_Abort;
4750 -- Abort : constant Boolean := False; -- no abort
4752 -- E : Exception_Occurrence;
4753 -- Raised : Boolean := False;
4756 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4757 -- ^-- in the finalization case
4759 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4761 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4765 -- if not Raised then
4767 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4774 -- if Raised and then not Abort then
4775 -- Raise_From_Controlled_Operation (E);
4779 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
4780 -- Create the statements necessary to initialize an array of controlled
4781 -- elements. Include a mechanism to carry out partial finalization if an
4782 -- exception occurs. Generate:
4785 -- Counter : Integer := 0;
4788 -- for J1 in V'Range (1) loop
4790 -- for JN in V'Range (N) loop
4792 -- [Deep_]Initialize (V (J1, ..., JN));
4794 -- Counter := Counter + 1;
4799 -- Abort : constant Boolean := Triggered_By_Abort;
4801 -- Abort : constant Boolean := False; -- no abort
4802 -- E : Exception_Occurence;
4803 -- Raised : Boolean := False;
4810 -- V'Length (N) - Counter;
4812 -- for F1 in reverse V'Range (1) loop
4814 -- for FN in reverse V'Range (N) loop
4815 -- if Counter > 0 then
4816 -- Counter := Counter - 1;
4819 -- [Deep_]Finalize (V (F1, ..., FN));
4823 -- if not Raised then
4825 -- Save_Occurrence (E,
4826 -- Get_Current_Excep.all.all);
4835 -- if Raised and then not Abort then
4836 -- Raise_From_Controlled_Operation (E);
4845 function New_References_To
4847 Loc
: Source_Ptr
) return List_Id
;
4848 -- Given a list of defining identifiers, return a list of references to
4849 -- the original identifiers, in the same order as they appear.
4851 -----------------------------------------
4852 -- Build_Adjust_Or_Finalize_Statements --
4853 -----------------------------------------
4855 function Build_Adjust_Or_Finalize_Statements
4856 (Typ
: Entity_Id
) return List_Id
4858 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4859 Index_List
: constant List_Id
:= New_List
;
4860 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4861 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
4862 Finalizer_Decls
: List_Id
:= No_List
;
4863 Finalizer_Data
: Finalization_Exception_Data
;
4866 Core_Loop
: Node_Id
;
4869 Loop_Id
: Entity_Id
;
4872 Exceptions_OK
: constant Boolean :=
4873 not Restriction_Active
(No_Exception_Propagation
);
4875 procedure Build_Indices
;
4876 -- Generate the indices used in the dimension loops
4882 procedure Build_Indices
is
4884 -- Generate the following identifiers:
4885 -- Jnn - for initialization
4887 for Dim
in 1 .. Num_Dims
loop
4888 Append_To
(Index_List
,
4889 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
4893 -- Start of processing for Build_Adjust_Or_Finalize_Statements
4898 if Exceptions_OK
then
4899 Finalizer_Decls
:= New_List
;
4900 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
4904 Make_Indexed_Component
(Loc
,
4905 Prefix
=> Make_Identifier
(Loc
, Name_V
),
4906 Expressions
=> New_References_To
(Index_List
, Loc
));
4907 Set_Etype
(Comp_Ref
, Comp_Typ
);
4910 -- [Deep_]Adjust (V (J1, ..., JN))
4912 if Prim
= Adjust_Case
then
4913 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
4916 -- [Deep_]Finalize (V (J1, ..., JN))
4918 else pragma Assert
(Prim
= Finalize_Case
);
4919 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
4922 -- Generate the block which houses the adjust or finalize call:
4924 -- <adjust or finalize call>; -- No_Exception_Propagation
4926 -- begin -- Exception handlers allowed
4927 -- <adjust or finalize call>
4931 -- if not Raised then
4933 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4937 if Exceptions_OK
then
4939 Make_Block_Statement
(Loc
,
4940 Handled_Statement_Sequence
=>
4941 Make_Handled_Sequence_Of_Statements
(Loc
,
4942 Statements
=> New_List
(Call
),
4943 Exception_Handlers
=> New_List
(
4944 Build_Exception_Handler
(Finalizer_Data
))));
4949 -- Generate the dimension loops starting from the innermost one
4951 -- for Jnn in [reverse] V'Range (Dim) loop
4955 J
:= Last
(Index_List
);
4957 while Present
(J
) and then Dim
> 0 loop
4963 Make_Loop_Statement
(Loc
,
4965 Make_Iteration_Scheme
(Loc
,
4966 Loop_Parameter_Specification
=>
4967 Make_Loop_Parameter_Specification
(Loc
,
4968 Defining_Identifier
=> Loop_Id
,
4969 Discrete_Subtype_Definition
=>
4970 Make_Attribute_Reference
(Loc
,
4971 Prefix
=> Make_Identifier
(Loc
, Name_V
),
4972 Attribute_Name
=> Name_Range
,
4973 Expressions
=> New_List
(
4974 Make_Integer_Literal
(Loc
, Dim
))),
4976 Reverse_Present
=> Prim
= Finalize_Case
)),
4978 Statements
=> New_List
(Core_Loop
),
4979 End_Label
=> Empty
);
4984 -- Generate the block which contains the core loop, the declarations
4985 -- of the abort flag, the exception occurrence, the raised flag and
4986 -- the conditional raise:
4989 -- Abort : constant Boolean := Triggered_By_Abort;
4991 -- Abort : constant Boolean := False; -- no abort
4993 -- E : Exception_Occurrence;
4994 -- Raised : Boolean := False;
4999 -- if Raised and then not Abort then -- Expection handlers OK
5000 -- Raise_From_Controlled_Operation (E);
5004 Stmts
:= New_List
(Core_Loop
);
5006 if Exceptions_OK
then
5008 Build_Raise_Statement
(Finalizer_Data
));
5013 Make_Block_Statement
(Loc
,
5016 Handled_Statement_Sequence
=>
5017 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5018 end Build_Adjust_Or_Finalize_Statements
;
5020 ---------------------------------
5021 -- Build_Initialize_Statements --
5022 ---------------------------------
5024 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5025 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5026 Final_List
: constant List_Id
:= New_List
;
5027 Index_List
: constant List_Id
:= New_List
;
5028 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5029 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5030 Counter_Id
: Entity_Id
;
5034 Final_Block
: Node_Id
;
5035 Final_Loop
: Node_Id
;
5036 Finalizer_Data
: Finalization_Exception_Data
;
5037 Finalizer_Decls
: List_Id
:= No_List
;
5038 Init_Loop
: Node_Id
;
5043 Exceptions_OK
: constant Boolean :=
5044 not Restriction_Active
(No_Exception_Propagation
);
5046 function Build_Counter_Assignment
return Node_Id
;
5047 -- Generate the following assignment:
5048 -- Counter := V'Length (1) *
5050 -- V'Length (N) - Counter;
5052 function Build_Finalization_Call
return Node_Id
;
5053 -- Generate a deep finalization call for an array element
5055 procedure Build_Indices
;
5056 -- Generate the initialization and finalization indices used in the
5059 function Build_Initialization_Call
return Node_Id
;
5060 -- Generate a deep initialization call for an array element
5062 ------------------------------
5063 -- Build_Counter_Assignment --
5064 ------------------------------
5066 function Build_Counter_Assignment
return Node_Id
is
5071 -- Start from the first dimension and generate:
5076 Make_Attribute_Reference
(Loc
,
5077 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5078 Attribute_Name
=> Name_Length
,
5079 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5081 -- Process the rest of the dimensions, generate:
5082 -- Expr * V'Length (N)
5085 while Dim
<= Num_Dims
loop
5087 Make_Op_Multiply
(Loc
,
5090 Make_Attribute_Reference
(Loc
,
5091 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5092 Attribute_Name
=> Name_Length
,
5093 Expressions
=> New_List
(
5094 Make_Integer_Literal
(Loc
, Dim
))));
5100 -- Counter := Expr - Counter;
5103 Make_Assignment_Statement
(Loc
,
5104 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5106 Make_Op_Subtract
(Loc
,
5108 Right_Opnd
=> New_Reference_To
(Counter_Id
, Loc
)));
5109 end Build_Counter_Assignment
;
5111 -----------------------------
5112 -- Build_Finalization_Call --
5113 -----------------------------
5115 function Build_Finalization_Call
return Node_Id
is
5116 Comp_Ref
: constant Node_Id
:=
5117 Make_Indexed_Component
(Loc
,
5118 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5119 Expressions
=> New_References_To
(Final_List
, Loc
));
5122 Set_Etype
(Comp_Ref
, Comp_Typ
);
5125 -- [Deep_]Finalize (V);
5127 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5128 end Build_Finalization_Call
;
5134 procedure Build_Indices
is
5136 -- Generate the following identifiers:
5137 -- Jnn - for initialization
5138 -- Fnn - for finalization
5140 for Dim
in 1 .. Num_Dims
loop
5141 Append_To
(Index_List
,
5142 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5144 Append_To
(Final_List
,
5145 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5149 -------------------------------
5150 -- Build_Initialization_Call --
5151 -------------------------------
5153 function Build_Initialization_Call
return Node_Id
is
5154 Comp_Ref
: constant Node_Id
:=
5155 Make_Indexed_Component
(Loc
,
5156 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5157 Expressions
=> New_References_To
(Index_List
, Loc
));
5160 Set_Etype
(Comp_Ref
, Comp_Typ
);
5163 -- [Deep_]Initialize (V (J1, ..., JN));
5165 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5166 end Build_Initialization_Call
;
5168 -- Start of processing for Build_Initialize_Statements
5173 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5175 if Exceptions_OK
then
5176 Finalizer_Decls
:= New_List
;
5177 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5180 -- Generate the block which houses the finalization call, the index
5181 -- guard and the handler which triggers Program_Error later on.
5183 -- if Counter > 0 then
5184 -- Counter := Counter - 1;
5186 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5188 -- begin -- Exceptions allowed
5189 -- [Deep_]Finalize (V (F1, ..., FN));
5192 -- if not Raised then
5194 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5199 if Exceptions_OK
then
5201 Make_Block_Statement
(Loc
,
5202 Handled_Statement_Sequence
=>
5203 Make_Handled_Sequence_Of_Statements
(Loc
,
5204 Statements
=> New_List
(Build_Finalization_Call
),
5205 Exception_Handlers
=> New_List
(
5206 Build_Exception_Handler
(Finalizer_Data
))));
5208 Fin_Stmt
:= Build_Finalization_Call
;
5211 -- This is the core of the loop, the dimension iterators are added
5212 -- one by one in reverse.
5215 Make_If_Statement
(Loc
,
5218 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5219 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5221 Then_Statements
=> New_List
(
5222 Make_Assignment_Statement
(Loc
,
5223 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5225 Make_Op_Subtract
(Loc
,
5226 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5227 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5229 Else_Statements
=> New_List
(Fin_Stmt
));
5231 -- Generate all finalization loops starting from the innermost
5234 -- for Fnn in reverse V'Range (Dim) loop
5238 F
:= Last
(Final_List
);
5240 while Present
(F
) and then Dim
> 0 loop
5246 Make_Loop_Statement
(Loc
,
5248 Make_Iteration_Scheme
(Loc
,
5249 Loop_Parameter_Specification
=>
5250 Make_Loop_Parameter_Specification
(Loc
,
5251 Defining_Identifier
=> Loop_Id
,
5252 Discrete_Subtype_Definition
=>
5253 Make_Attribute_Reference
(Loc
,
5254 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5255 Attribute_Name
=> Name_Range
,
5256 Expressions
=> New_List
(
5257 Make_Integer_Literal
(Loc
, Dim
))),
5259 Reverse_Present
=> True)),
5261 Statements
=> New_List
(Final_Loop
),
5262 End_Label
=> Empty
);
5267 -- Generate the block which contains the finalization loops, the
5268 -- declarations of the abort flag, the exception occurrence, the
5269 -- raised flag and the conditional raise.
5272 -- Abort : constant Boolean := Triggered_By_Abort;
5274 -- Abort : constant Boolean := False; -- no abort
5276 -- E : Exception_Occurrence;
5277 -- Raised : Boolean := False;
5283 -- V'Length (N) - Counter;
5287 -- if Raised and then not Abort then -- Exception handlers OK
5288 -- Raise_From_Controlled_Operation (E);
5291 -- raise; -- Exception handlers OK
5294 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5296 if Exceptions_OK
then
5298 Build_Raise_Statement
(Finalizer_Data
));
5299 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5303 Make_Block_Statement
(Loc
,
5306 Handled_Statement_Sequence
=>
5307 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5309 -- Generate the block which contains the initialization call and
5310 -- the partial finalization code.
5313 -- [Deep_]Initialize (V (J1, ..., JN));
5315 -- Counter := Counter + 1;
5319 -- <finalization code>
5323 Make_Block_Statement
(Loc
,
5324 Handled_Statement_Sequence
=>
5325 Make_Handled_Sequence_Of_Statements
(Loc
,
5326 Statements
=> New_List
(Build_Initialization_Call
),
5327 Exception_Handlers
=> New_List
(
5328 Make_Exception_Handler
(Loc
,
5329 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5330 Statements
=> New_List
(Final_Block
)))));
5332 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5333 Make_Assignment_Statement
(Loc
,
5334 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5337 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5338 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5340 -- Generate all initialization loops starting from the innermost
5343 -- for Jnn in V'Range (Dim) loop
5347 J
:= Last
(Index_List
);
5349 while Present
(J
) and then Dim
> 0 loop
5355 Make_Loop_Statement
(Loc
,
5357 Make_Iteration_Scheme
(Loc
,
5358 Loop_Parameter_Specification
=>
5359 Make_Loop_Parameter_Specification
(Loc
,
5360 Defining_Identifier
=> Loop_Id
,
5361 Discrete_Subtype_Definition
=>
5362 Make_Attribute_Reference
(Loc
,
5363 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5364 Attribute_Name
=> Name_Range
,
5365 Expressions
=> New_List
(
5366 Make_Integer_Literal
(Loc
, Dim
))))),
5368 Statements
=> New_List
(Init_Loop
),
5369 End_Label
=> Empty
);
5374 -- Generate the block which contains the counter variable and the
5375 -- initialization loops.
5378 -- Counter : Integer := 0;
5385 Make_Block_Statement
(Loc
,
5386 Declarations
=> New_List
(
5387 Make_Object_Declaration
(Loc
,
5388 Defining_Identifier
=> Counter_Id
,
5389 Object_Definition
=>
5390 New_Reference_To
(Standard_Integer
, Loc
),
5391 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5393 Handled_Statement_Sequence
=>
5394 Make_Handled_Sequence_Of_Statements
(Loc
,
5395 Statements
=> New_List
(Init_Loop
))));
5396 end Build_Initialize_Statements
;
5398 -----------------------
5399 -- New_References_To --
5400 -----------------------
5402 function New_References_To
5404 Loc
: Source_Ptr
) return List_Id
5406 Refs
: constant List_Id
:= New_List
;
5411 while Present
(Id
) loop
5412 Append_To
(Refs
, New_Reference_To
(Id
, Loc
));
5417 end New_References_To
;
5419 -- Start of processing for Make_Deep_Array_Body
5423 when Address_Case
=>
5424 return Make_Finalize_Address_Stmts
(Typ
);
5428 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5430 when Initialize_Case
=>
5431 return Build_Initialize_Statements
(Typ
);
5433 end Make_Deep_Array_Body
;
5435 --------------------
5436 -- Make_Deep_Proc --
5437 --------------------
5439 function Make_Deep_Proc
5440 (Prim
: Final_Primitives
;
5442 Stmts
: List_Id
) return Entity_Id
5444 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5446 Proc_Id
: Entity_Id
;
5449 -- Create the object formal, generate:
5450 -- V : System.Address
5452 if Prim
= Address_Case
then
5453 Formals
:= New_List
(
5454 Make_Parameter_Specification
(Loc
,
5455 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5456 Parameter_Type
=> New_Reference_To
(RTE
(RE_Address
), Loc
)));
5463 Formals
:= New_List
(
5464 Make_Parameter_Specification
(Loc
,
5465 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5467 Out_Present
=> True,
5468 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5470 -- F : Boolean := True
5472 if Prim
= Adjust_Case
5473 or else Prim
= Finalize_Case
5476 Make_Parameter_Specification
(Loc
,
5477 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5479 New_Reference_To
(Standard_Boolean
, Loc
),
5481 New_Reference_To
(Standard_True
, Loc
)));
5486 Make_Defining_Identifier
(Loc
,
5487 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5490 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5493 -- exception -- Finalize and Adjust cases only
5494 -- raise Program_Error;
5495 -- end Deep_Initialize / Adjust / Finalize;
5499 -- procedure Finalize_Address (V : System.Address) is
5502 -- end Finalize_Address;
5505 Make_Subprogram_Body
(Loc
,
5507 Make_Procedure_Specification
(Loc
,
5508 Defining_Unit_Name
=> Proc_Id
,
5509 Parameter_Specifications
=> Formals
),
5511 Declarations
=> Empty_List
,
5513 Handled_Statement_Sequence
=>
5514 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5519 ---------------------------
5520 -- Make_Deep_Record_Body --
5521 ---------------------------
5523 function Make_Deep_Record_Body
5524 (Prim
: Final_Primitives
;
5526 Is_Local
: Boolean := False) return List_Id
5528 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5529 -- Build the statements necessary to adjust a record type. The type may
5530 -- have discriminants and contain variant parts. Generate:
5534 -- [Deep_]Adjust (V.Comp_1);
5536 -- when Id : others =>
5537 -- if not Raised then
5539 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5544 -- [Deep_]Adjust (V.Comp_N);
5546 -- when Id : others =>
5547 -- if not Raised then
5549 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5554 -- Deep_Adjust (V._parent, False); -- If applicable
5556 -- when Id : others =>
5557 -- if not Raised then
5559 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5565 -- Adjust (V); -- If applicable
5568 -- if not Raised then
5570 -- Save_Occurence (E, Get_Current_Excep.all.all);
5575 -- if Raised and then not Abort then
5576 -- Raise_From_Controlled_Operation (E);
5580 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5581 -- Build the statements necessary to finalize a record type. The type
5582 -- may have discriminants and contain variant parts. Generate:
5585 -- Abort : constant Boolean := Triggered_By_Abort;
5587 -- Abort : constant Boolean := False; -- no abort
5588 -- E : Exception_Occurence;
5589 -- Raised : Boolean := False;
5594 -- Finalize (V); -- If applicable
5597 -- if not Raised then
5599 -- Save_Occurence (E, Get_Current_Excep.all.all);
5604 -- case Variant_1 is
5606 -- case State_Counter_N => -- If Is_Local is enabled
5616 -- <<LN>> -- If Is_Local is enabled
5618 -- [Deep_]Finalize (V.Comp_N);
5621 -- if not Raised then
5623 -- Save_Occurence (E, Get_Current_Excep.all.all);
5629 -- [Deep_]Finalize (V.Comp_1);
5632 -- if not Raised then
5634 -- Save_Occurence (E, Get_Current_Excep.all.all);
5640 -- case State_Counter_1 => -- If Is_Local is enabled
5646 -- Deep_Finalize (V._parent, False); -- If applicable
5648 -- when Id : others =>
5649 -- if not Raised then
5651 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5655 -- if Raised and then not Abort then
5656 -- Raise_From_Controlled_Operation (E);
5660 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
5661 -- Given a derived tagged type Typ, traverse all components, find field
5662 -- _parent and return its type.
5664 procedure Preprocess_Components
5666 Num_Comps
: out Int
;
5667 Has_POC
: out Boolean);
5668 -- Examine all components in component list Comps, count all controlled
5669 -- components and determine whether at least one of them is per-object
5670 -- constrained. Component _parent is always skipped.
5672 -----------------------------
5673 -- Build_Adjust_Statements --
5674 -----------------------------
5676 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
5677 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5678 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
5679 Bod_Stmts
: List_Id
;
5680 Finalizer_Data
: Finalization_Exception_Data
;
5681 Finalizer_Decls
: List_Id
:= No_List
;
5685 Exceptions_OK
: constant Boolean :=
5686 not Restriction_Active
(No_Exception_Propagation
);
5688 function Process_Component_List_For_Adjust
5689 (Comps
: Node_Id
) return List_Id
;
5690 -- Build all necessary adjust statements for a single component list
5692 ---------------------------------------
5693 -- Process_Component_List_For_Adjust --
5694 ---------------------------------------
5696 function Process_Component_List_For_Adjust
5697 (Comps
: Node_Id
) return List_Id
5699 Stmts
: constant List_Id
:= New_List
;
5701 Decl_Id
: Entity_Id
;
5702 Decl_Typ
: Entity_Id
;
5706 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
5707 -- Process the declaration of a single controlled component
5709 ----------------------------------
5710 -- Process_Component_For_Adjust --
5711 ----------------------------------
5713 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
5714 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
5715 Typ
: constant Entity_Id
:= Etype
(Id
);
5720 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
5722 -- begin -- Exception handlers allowed
5723 -- [Deep_]Adjust (V.Id);
5726 -- if not Raised then
5728 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5735 Make_Selected_Component
(Loc
,
5736 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5737 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
5740 if Exceptions_OK
then
5742 Make_Block_Statement
(Loc
,
5743 Handled_Statement_Sequence
=>
5744 Make_Handled_Sequence_Of_Statements
(Loc
,
5745 Statements
=> New_List
(Adj_Stmt
),
5746 Exception_Handlers
=> New_List
(
5747 Build_Exception_Handler
(Finalizer_Data
))));
5750 Append_To
(Stmts
, Adj_Stmt
);
5751 end Process_Component_For_Adjust
;
5753 -- Start of processing for Process_Component_List_For_Adjust
5756 -- Perform an initial check, determine the number of controlled
5757 -- components in the current list and whether at least one of them
5758 -- is per-object constrained.
5760 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
5762 -- The processing in this routine is done in the following order:
5763 -- 1) Regular components
5764 -- 2) Per-object constrained components
5767 if Num_Comps
> 0 then
5769 -- Process all regular components in order of declarations
5771 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5772 while Present
(Decl
) loop
5773 Decl_Id
:= Defining_Identifier
(Decl
);
5774 Decl_Typ
:= Etype
(Decl_Id
);
5776 -- Skip _parent as well as per-object constrained components
5778 if Chars
(Decl_Id
) /= Name_uParent
5779 and then Needs_Finalization
(Decl_Typ
)
5781 if Has_Access_Constraint
(Decl_Id
)
5782 and then No
(Expression
(Decl
))
5786 Process_Component_For_Adjust
(Decl
);
5790 Next_Non_Pragma
(Decl
);
5793 -- Process all per-object constrained components in order of
5797 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5798 while Present
(Decl
) loop
5799 Decl_Id
:= Defining_Identifier
(Decl
);
5800 Decl_Typ
:= Etype
(Decl_Id
);
5804 if Chars
(Decl_Id
) /= Name_uParent
5805 and then Needs_Finalization
(Decl_Typ
)
5806 and then Has_Access_Constraint
(Decl_Id
)
5807 and then No
(Expression
(Decl
))
5809 Process_Component_For_Adjust
(Decl
);
5812 Next_Non_Pragma
(Decl
);
5817 -- Process all variants, if any
5820 if Present
(Variant_Part
(Comps
)) then
5822 Var_Alts
: constant List_Id
:= New_List
;
5826 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
5827 while Present
(Var
) loop
5830 -- when <discrete choices> =>
5831 -- <adjust statements>
5833 Append_To
(Var_Alts
,
5834 Make_Case_Statement_Alternative
(Loc
,
5836 New_Copy_List
(Discrete_Choices
(Var
)),
5838 Process_Component_List_For_Adjust
(
5839 Component_List
(Var
))));
5841 Next_Non_Pragma
(Var
);
5845 -- case V.<discriminant> is
5846 -- when <discrete choices 1> =>
5847 -- <adjust statements 1>
5849 -- when <discrete choices N> =>
5850 -- <adjust statements N>
5854 Make_Case_Statement
(Loc
,
5856 Make_Selected_Component
(Loc
,
5857 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5859 Make_Identifier
(Loc
,
5860 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
5861 Alternatives
=> Var_Alts
);
5865 -- Add the variant case statement to the list of statements
5867 if Present
(Var_Case
) then
5868 Append_To
(Stmts
, Var_Case
);
5871 -- If the component list did not have any controlled components
5872 -- nor variants, return null.
5874 if Is_Empty_List
(Stmts
) then
5875 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
5879 end Process_Component_List_For_Adjust
;
5881 -- Start of processing for Build_Adjust_Statements
5884 if Exceptions_OK
then
5885 Finalizer_Decls
:= New_List
;
5886 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5889 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
5890 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
5895 -- Create an adjust sequence for all record components
5897 if Present
(Component_List
(Rec_Def
)) then
5899 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
5902 -- A derived record type must adjust all inherited components. This
5903 -- action poses the following problem:
5905 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
5910 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
5912 -- Deep_Adjust (Obj._parent);
5917 -- Adjusting the derived type will invoke Adjust of the parent and
5918 -- then that of the derived type. This is undesirable because both
5919 -- routines may modify shared components. Only the Adjust of the
5920 -- derived type should be invoked.
5922 -- To prevent this double adjustment of shared components,
5923 -- Deep_Adjust uses a flag to control the invocation of Adjust:
5925 -- procedure Deep_Adjust
5926 -- (Obj : in out Some_Type;
5927 -- Flag : Boolean := True)
5935 -- When Deep_Adjust is invokes for field _parent, a value of False is
5936 -- provided for the flag:
5938 -- Deep_Adjust (Obj._parent, False);
5940 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
5942 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
5947 if Needs_Finalization
(Par_Typ
) then
5951 Make_Selected_Component
(Loc
,
5952 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5954 Make_Identifier
(Loc
, Name_uParent
)),
5956 For_Parent
=> True);
5959 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
5961 -- begin -- Exceptions OK
5962 -- Deep_Adjust (V._parent, False);
5964 -- when Id : others =>
5965 -- if not Raised then
5967 -- Save_Occurrence (E,
5968 -- Get_Current_Excep.all.all);
5972 if Present
(Call
) then
5975 if Exceptions_OK
then
5977 Make_Block_Statement
(Loc
,
5978 Handled_Statement_Sequence
=>
5979 Make_Handled_Sequence_Of_Statements
(Loc
,
5980 Statements
=> New_List
(Adj_Stmt
),
5981 Exception_Handlers
=> New_List
(
5982 Build_Exception_Handler
(Finalizer_Data
))));
5985 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
5991 -- Adjust the object. This action must be performed last after all
5992 -- components have been adjusted.
5994 if Is_Controlled
(Typ
) then
6000 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6004 -- Adjust (V); -- No_Exception_Propagation
6006 -- begin -- Exception handlers allowed
6010 -- if not Raised then
6012 -- Save_Occurrence (E,
6013 -- Get_Current_Excep.all.all);
6018 if Present
(Proc
) then
6020 Make_Procedure_Call_Statement
(Loc
,
6021 Name
=> New_Reference_To
(Proc
, Loc
),
6022 Parameter_Associations
=> New_List
(
6023 Make_Identifier
(Loc
, Name_V
)));
6025 if Exceptions_OK
then
6027 Make_Block_Statement
(Loc
,
6028 Handled_Statement_Sequence
=>
6029 Make_Handled_Sequence_Of_Statements
(Loc
,
6030 Statements
=> New_List
(Adj_Stmt
),
6031 Exception_Handlers
=> New_List
(
6032 Build_Exception_Handler
6033 (Finalizer_Data
))));
6036 Append_To
(Bod_Stmts
,
6037 Make_If_Statement
(Loc
,
6038 Condition
=> Make_Identifier
(Loc
, Name_F
),
6039 Then_Statements
=> New_List
(Adj_Stmt
)));
6044 -- At this point either all adjustment statements have been generated
6045 -- or the type is not controlled.
6047 if Is_Empty_List
(Bod_Stmts
) then
6048 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6054 -- Abort : constant Boolean := Triggered_By_Abort;
6056 -- Abort : constant Boolean := False; -- no abort
6058 -- E : Exception_Occurence;
6059 -- Raised : Boolean := False;
6062 -- <adjust statements>
6064 -- if Raised and then not Abort then
6065 -- Raise_From_Controlled_Operation (E);
6070 if Exceptions_OK
then
6071 Append_To
(Bod_Stmts
,
6072 Build_Raise_Statement
(Finalizer_Data
));
6077 Make_Block_Statement
(Loc
,
6080 Handled_Statement_Sequence
=>
6081 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6083 end Build_Adjust_Statements
;
6085 -------------------------------
6086 -- Build_Finalize_Statements --
6087 -------------------------------
6089 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6090 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6091 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6092 Bod_Stmts
: List_Id
;
6094 Finalizer_Data
: Finalization_Exception_Data
;
6095 Finalizer_Decls
: List_Id
:= No_List
;
6099 Exceptions_OK
: constant Boolean :=
6100 not Restriction_Active
(No_Exception_Propagation
);
6102 function Process_Component_List_For_Finalize
6103 (Comps
: Node_Id
) return List_Id
;
6104 -- Build all necessary finalization statements for a single component
6105 -- list. The statements may include a jump circuitry if flag Is_Local
6108 -----------------------------------------
6109 -- Process_Component_List_For_Finalize --
6110 -----------------------------------------
6112 function Process_Component_List_For_Finalize
6113 (Comps
: Node_Id
) return List_Id
6116 Counter_Id
: Entity_Id
;
6118 Decl_Id
: Entity_Id
;
6119 Decl_Typ
: Entity_Id
;
6122 Jump_Block
: Node_Id
;
6124 Label_Id
: Entity_Id
;
6128 procedure Process_Component_For_Finalize
6133 -- Process the declaration of a single controlled component. If
6134 -- flag Is_Local is enabled, create the corresponding label and
6135 -- jump circuitry. Alts is the list of case alternatives, Decls
6136 -- is the top level declaration list where labels are declared
6137 -- and Stmts is the list of finalization actions.
6139 ------------------------------------
6140 -- Process_Component_For_Finalize --
6141 ------------------------------------
6143 procedure Process_Component_For_Finalize
6149 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6150 Typ
: constant Entity_Id
:= Etype
(Id
);
6157 Label_Id
: Entity_Id
;
6164 Make_Identifier
(Loc
,
6165 Chars
=> New_External_Name
('L', Num_Comps
));
6166 Set_Entity
(Label_Id
,
6167 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6168 Label
:= Make_Label
(Loc
, Label_Id
);
6171 Make_Implicit_Label_Declaration
(Loc
,
6172 Defining_Identifier
=> Entity
(Label_Id
),
6173 Label_Construct
=> Label
));
6180 Make_Case_Statement_Alternative
(Loc
,
6181 Discrete_Choices
=> New_List
(
6182 Make_Integer_Literal
(Loc
, Num_Comps
)),
6184 Statements
=> New_List
(
6185 Make_Goto_Statement
(Loc
,
6187 New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6192 Append_To
(Stmts
, Label
);
6194 -- Decrease the number of components to be processed.
6195 -- This action yields a new Label_Id in future calls.
6197 Num_Comps
:= Num_Comps
- 1;
6202 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6204 -- begin -- Exception handlers allowed
6205 -- [Deep_]Finalize (V.Id);
6208 -- if not Raised then
6210 -- Save_Occurrence (E,
6211 -- Get_Current_Excep.all.all);
6218 Make_Selected_Component
(Loc
,
6219 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6220 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6223 if not Restriction_Active
(No_Exception_Propagation
) then
6225 Make_Block_Statement
(Loc
,
6226 Handled_Statement_Sequence
=>
6227 Make_Handled_Sequence_Of_Statements
(Loc
,
6228 Statements
=> New_List
(Fin_Stmt
),
6229 Exception_Handlers
=> New_List
(
6230 Build_Exception_Handler
(Finalizer_Data
))));
6233 Append_To
(Stmts
, Fin_Stmt
);
6234 end Process_Component_For_Finalize
;
6236 -- Start of processing for Process_Component_List_For_Finalize
6239 -- Perform an initial check, look for controlled and per-object
6240 -- constrained components.
6242 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6244 -- Create a state counter to service the current component list.
6245 -- This step is performed before the variants are inspected in
6246 -- order to generate the same state counter names as those from
6247 -- Build_Initialize_Statements.
6252 Counter
:= Counter
+ 1;
6255 Make_Defining_Identifier
(Loc
,
6256 Chars
=> New_External_Name
('C', Counter
));
6259 -- Process the component in the following order:
6261 -- 2) Per-object constrained components
6262 -- 3) Regular components
6264 -- Start with the variant parts
6267 if Present
(Variant_Part
(Comps
)) then
6269 Var_Alts
: constant List_Id
:= New_List
;
6273 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6274 while Present
(Var
) loop
6277 -- when <discrete choices> =>
6278 -- <finalize statements>
6280 Append_To
(Var_Alts
,
6281 Make_Case_Statement_Alternative
(Loc
,
6283 New_Copy_List
(Discrete_Choices
(Var
)),
6285 Process_Component_List_For_Finalize
(
6286 Component_List
(Var
))));
6288 Next_Non_Pragma
(Var
);
6292 -- case V.<discriminant> is
6293 -- when <discrete choices 1> =>
6294 -- <finalize statements 1>
6296 -- when <discrete choices N> =>
6297 -- <finalize statements N>
6301 Make_Case_Statement
(Loc
,
6303 Make_Selected_Component
(Loc
,
6304 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6306 Make_Identifier
(Loc
,
6307 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6308 Alternatives
=> Var_Alts
);
6312 -- The current component list does not have a single controlled
6313 -- component, however it may contain variants. Return the case
6314 -- statement for the variants or nothing.
6316 if Num_Comps
= 0 then
6317 if Present
(Var_Case
) then
6318 return New_List
(Var_Case
);
6320 return New_List
(Make_Null_Statement
(Loc
));
6324 -- Prepare all lists
6330 -- Process all per-object constrained components in reverse order
6333 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6334 while Present
(Decl
) loop
6335 Decl_Id
:= Defining_Identifier
(Decl
);
6336 Decl_Typ
:= Etype
(Decl_Id
);
6340 if Chars
(Decl_Id
) /= Name_uParent
6341 and then Needs_Finalization
(Decl_Typ
)
6342 and then Has_Access_Constraint
(Decl_Id
)
6343 and then No
(Expression
(Decl
))
6345 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6348 Prev_Non_Pragma
(Decl
);
6352 -- Process the rest of the components in reverse order
6354 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6355 while Present
(Decl
) loop
6356 Decl_Id
:= Defining_Identifier
(Decl
);
6357 Decl_Typ
:= Etype
(Decl_Id
);
6361 if Chars
(Decl_Id
) /= Name_uParent
6362 and then Needs_Finalization
(Decl_Typ
)
6364 -- Skip per-object constrained components since they were
6365 -- handled in the above step.
6367 if Has_Access_Constraint
(Decl_Id
)
6368 and then No
(Expression
(Decl
))
6372 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6376 Prev_Non_Pragma
(Decl
);
6381 -- LN : label; -- If Is_Local is enabled
6386 -- case CounterX is .
6396 -- <<LN>> -- If Is_Local is enabled
6398 -- [Deep_]Finalize (V.CompY);
6400 -- when Id : others =>
6401 -- if not Raised then
6403 -- Save_Occurrence (E,
6404 -- Get_Current_Excep.all.all);
6408 -- <<L0>> -- If Is_Local is enabled
6413 -- Add the declaration of default jump location L0, its
6414 -- corresponding alternative and its place in the statements.
6416 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6417 Set_Entity
(Label_Id
,
6418 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6419 Label
:= Make_Label
(Loc
, Label_Id
);
6421 Append_To
(Decls
, -- declaration
6422 Make_Implicit_Label_Declaration
(Loc
,
6423 Defining_Identifier
=> Entity
(Label_Id
),
6424 Label_Construct
=> Label
));
6426 Append_To
(Alts
, -- alternative
6427 Make_Case_Statement_Alternative
(Loc
,
6428 Discrete_Choices
=> New_List
(
6429 Make_Others_Choice
(Loc
)),
6431 Statements
=> New_List
(
6432 Make_Goto_Statement
(Loc
,
6433 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6435 Append_To
(Stmts
, Label
); -- statement
6437 -- Create the jump block
6440 Make_Case_Statement
(Loc
,
6441 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6442 Alternatives
=> Alts
));
6446 Make_Block_Statement
(Loc
,
6447 Declarations
=> Decls
,
6448 Handled_Statement_Sequence
=>
6449 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6451 if Present
(Var_Case
) then
6452 return New_List
(Var_Case
, Jump_Block
);
6454 return New_List
(Jump_Block
);
6456 end Process_Component_List_For_Finalize
;
6458 -- Start of processing for Build_Finalize_Statements
6461 if Exceptions_OK
then
6462 Finalizer_Decls
:= New_List
;
6463 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6466 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6467 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6472 -- Create a finalization sequence for all record components
6474 if Present
(Component_List
(Rec_Def
)) then
6476 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6479 -- A derived record type must finalize all inherited components. This
6480 -- action poses the following problem:
6482 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6487 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6489 -- Deep_Finalize (Obj._parent);
6494 -- Finalizing the derived type will invoke Finalize of the parent and
6495 -- then that of the derived type. This is undesirable because both
6496 -- routines may modify shared components. Only the Finalize of the
6497 -- derived type should be invoked.
6499 -- To prevent this double adjustment of shared components,
6500 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6502 -- procedure Deep_Finalize
6503 -- (Obj : in out Some_Type;
6504 -- Flag : Boolean := True)
6512 -- When Deep_Finalize is invokes for field _parent, a value of False
6513 -- is provided for the flag:
6515 -- Deep_Finalize (Obj._parent, False);
6517 if Is_Tagged_Type
(Typ
)
6518 and then Is_Derived_Type
(Typ
)
6521 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6526 if Needs_Finalization
(Par_Typ
) then
6530 Make_Selected_Component
(Loc
,
6531 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6533 Make_Identifier
(Loc
, Name_uParent
)),
6535 For_Parent
=> True);
6538 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6540 -- begin -- Exceptions OK
6541 -- Deep_Finalize (V._parent, False);
6543 -- when Id : others =>
6544 -- if not Raised then
6546 -- Save_Occurrence (E,
6547 -- Get_Current_Excep.all.all);
6551 if Present
(Call
) then
6554 if Exceptions_OK
then
6556 Make_Block_Statement
(Loc
,
6557 Handled_Statement_Sequence
=>
6558 Make_Handled_Sequence_Of_Statements
(Loc
,
6559 Statements
=> New_List
(Fin_Stmt
),
6560 Exception_Handlers
=> New_List
(
6561 Build_Exception_Handler
6562 (Finalizer_Data
))));
6565 Append_To
(Bod_Stmts
, Fin_Stmt
);
6571 -- Finalize the object. This action must be performed first before
6572 -- all components have been finalized.
6574 if Is_Controlled
(Typ
)
6575 and then not Is_Local
6582 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6586 -- Finalize (V); -- No_Exception_Propagation
6592 -- if not Raised then
6594 -- Save_Occurrence (E,
6595 -- Get_Current_Excep.all.all);
6600 if Present
(Proc
) then
6602 Make_Procedure_Call_Statement
(Loc
,
6603 Name
=> New_Reference_To
(Proc
, Loc
),
6604 Parameter_Associations
=> New_List
(
6605 Make_Identifier
(Loc
, Name_V
)));
6607 if Exceptions_OK
then
6609 Make_Block_Statement
(Loc
,
6610 Handled_Statement_Sequence
=>
6611 Make_Handled_Sequence_Of_Statements
(Loc
,
6612 Statements
=> New_List
(Fin_Stmt
),
6613 Exception_Handlers
=> New_List
(
6614 Build_Exception_Handler
6615 (Finalizer_Data
))));
6618 Prepend_To
(Bod_Stmts
,
6619 Make_If_Statement
(Loc
,
6620 Condition
=> Make_Identifier
(Loc
, Name_F
),
6621 Then_Statements
=> New_List
(Fin_Stmt
)));
6626 -- At this point either all finalization statements have been
6627 -- generated or the type is not controlled.
6629 if No
(Bod_Stmts
) then
6630 return New_List
(Make_Null_Statement
(Loc
));
6634 -- Abort : constant Boolean := Triggered_By_Abort;
6636 -- Abort : constant Boolean := False; -- no abort
6638 -- E : Exception_Occurence;
6639 -- Raised : Boolean := False;
6642 -- <finalize statements>
6644 -- if Raised and then not Abort then
6645 -- Raise_From_Controlled_Operation (E);
6650 if Exceptions_OK
then
6651 Append_To
(Bod_Stmts
,
6652 Build_Raise_Statement
(Finalizer_Data
));
6657 Make_Block_Statement
(Loc
,
6660 Handled_Statement_Sequence
=>
6661 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6663 end Build_Finalize_Statements
;
6665 -----------------------
6666 -- Parent_Field_Type --
6667 -----------------------
6669 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
6673 Field
:= First_Entity
(Typ
);
6674 while Present
(Field
) loop
6675 if Chars
(Field
) = Name_uParent
then
6676 return Etype
(Field
);
6679 Next_Entity
(Field
);
6682 -- A derived tagged type should always have a parent field
6684 raise Program_Error
;
6685 end Parent_Field_Type
;
6687 ---------------------------
6688 -- Preprocess_Components --
6689 ---------------------------
6691 procedure Preprocess_Components
6693 Num_Comps
: out Int
;
6694 Has_POC
: out Boolean)
6704 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6705 while Present
(Decl
) loop
6706 Id
:= Defining_Identifier
(Decl
);
6709 -- Skip field _parent
6711 if Chars
(Id
) /= Name_uParent
6712 and then Needs_Finalization
(Typ
)
6714 Num_Comps
:= Num_Comps
+ 1;
6716 if Has_Access_Constraint
(Id
)
6717 and then No
(Expression
(Decl
))
6723 Next_Non_Pragma
(Decl
);
6725 end Preprocess_Components
;
6727 -- Start of processing for Make_Deep_Record_Body
6731 when Address_Case
=>
6732 return Make_Finalize_Address_Stmts
(Typ
);
6735 return Build_Adjust_Statements
(Typ
);
6737 when Finalize_Case
=>
6738 return Build_Finalize_Statements
(Typ
);
6740 when Initialize_Case
=>
6742 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6745 if Is_Controlled
(Typ
) then
6747 Make_Procedure_Call_Statement
(Loc
,
6750 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
6751 Parameter_Associations
=> New_List
(
6752 Make_Identifier
(Loc
, Name_V
))));
6758 end Make_Deep_Record_Body
;
6760 ----------------------
6761 -- Make_Final_Call --
6762 ----------------------
6764 function Make_Final_Call
6767 For_Parent
: Boolean := False) return Node_Id
6769 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6771 Fin_Id
: Entity_Id
:= Empty
;
6776 -- Recover the proper type which contains [Deep_]Finalize
6778 if Is_Class_Wide_Type
(Typ
) then
6779 Utyp
:= Root_Type
(Typ
);
6783 elsif Is_Concurrent_Type
(Typ
) then
6784 Utyp
:= Corresponding_Record_Type
(Typ
);
6786 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
6788 elsif Is_Private_Type
(Typ
)
6789 and then Present
(Full_View
(Typ
))
6790 and then Is_Concurrent_Type
(Full_View
(Typ
))
6792 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
6794 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
6802 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6803 Set_Assignment_OK
(Ref
);
6805 -- Deal with non-tagged derivation of private views. If the parent type
6806 -- is a protected type, Deep_Finalize is found on the corresponding
6807 -- record of the ancestor.
6809 if Is_Untagged_Derivation
(Typ
) then
6810 if Is_Protected_Type
(Typ
) then
6811 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
6813 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6815 if Is_Protected_Type
(Utyp
) then
6816 Utyp
:= Corresponding_Record_Type
(Utyp
);
6820 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6821 Set_Assignment_OK
(Ref
);
6824 -- Deal with derived private types which do not inherit primitives from
6825 -- their parents. In this case, [Deep_]Finalize can be found in the full
6826 -- view of the parent type.
6828 if Is_Tagged_Type
(Utyp
)
6829 and then Is_Derived_Type
(Utyp
)
6830 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
6831 and then Is_Private_Type
(Etype
(Utyp
))
6832 and then Present
(Full_View
(Etype
(Utyp
)))
6834 Utyp
:= Full_View
(Etype
(Utyp
));
6835 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6836 Set_Assignment_OK
(Ref
);
6839 -- When dealing with the completion of a private type, use the base type
6842 if Utyp
/= Base_Type
(Utyp
) then
6843 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
6845 Utyp
:= Base_Type
(Utyp
);
6846 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6847 Set_Assignment_OK
(Ref
);
6850 -- Select the appropriate version of Finalize
6853 if Has_Controlled_Component
(Utyp
) then
6854 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6857 -- Class-wide types, interfaces and types with controlled components
6859 elsif Is_Class_Wide_Type
(Typ
)
6860 or else Is_Interface
(Typ
)
6861 or else Has_Controlled_Component
(Utyp
)
6863 if Is_Tagged_Type
(Utyp
) then
6864 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6866 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
6869 -- Derivations from [Limited_]Controlled
6871 elsif Is_Controlled
(Utyp
) then
6872 if Has_Controlled_Component
(Utyp
) then
6873 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6875 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
6880 elsif Is_Tagged_Type
(Utyp
) then
6881 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6884 raise Program_Error
;
6887 if Present
(Fin_Id
) then
6889 -- When finalizing a class-wide object, do not convert to the root
6890 -- type in order to produce a dispatching call.
6892 if Is_Class_Wide_Type
(Typ
) then
6895 -- Ensure that a finalization routine is at least decorated in order
6896 -- to inspect the object parameter.
6898 elsif Analyzed
(Fin_Id
)
6899 or else Ekind
(Fin_Id
) = E_Procedure
6901 -- In certain cases, such as the creation of Stream_Read, the
6902 -- visible entity of the type is its full view. Since Stream_Read
6903 -- will have to create an object of type Typ, the local object
6904 -- will be finalzed by the scope finalizer generated later on. The
6905 -- object parameter of Deep_Finalize will always use the private
6906 -- view of the type. To avoid such a clash between a private and a
6907 -- full view, perform an unchecked conversion of the object
6908 -- reference to the private view.
6911 Formal_Typ
: constant Entity_Id
:=
6912 Etype
(First_Formal
(Fin_Id
));
6914 if Is_Private_Type
(Formal_Typ
)
6915 and then Present
(Full_View
(Formal_Typ
))
6916 and then Full_View
(Formal_Typ
) = Utyp
6918 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
6922 Ref
:= Convert_View
(Fin_Id
, Ref
);
6925 return Make_Call
(Loc
, Fin_Id
, New_Copy_Tree
(Ref
), For_Parent
);
6929 end Make_Final_Call
;
6931 --------------------------------
6932 -- Make_Finalize_Address_Body --
6933 --------------------------------
6935 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
6936 Is_Task
: constant Boolean :=
6937 Ekind
(Typ
) = E_Record_Type
6938 and then Is_Concurrent_Record_Type
(Typ
)
6939 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
6941 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6942 Proc_Id
: Entity_Id
;
6946 -- The corresponding records of task types are not controlled by design.
6947 -- For the sake of completeness, create an empty Finalize_Address to be
6948 -- used in task class-wide allocations.
6953 -- Nothing to do if the type is not controlled or it already has a
6954 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
6955 -- come from source. These are usually generated for completeness and
6956 -- do not need the Finalize_Address primitive.
6958 elsif not Needs_Finalization
(Typ
)
6959 or else Is_Abstract_Type
(Typ
)
6960 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
6962 (Is_Class_Wide_Type
(Typ
)
6963 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
6964 and then not Comes_From_Source
(Root_Type
(Typ
)))
6970 Make_Defining_Identifier
(Loc
,
6971 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
6975 -- procedure <Typ>FD (V : System.Address) is
6977 -- null; -- for tasks
6979 -- declare -- for all other types
6980 -- type Pnn is access all Typ;
6981 -- for Pnn'Storage_Size use 0;
6983 -- [Deep_]Finalize (Pnn (V).all);
6988 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
6990 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
6994 Make_Subprogram_Body
(Loc
,
6996 Make_Procedure_Specification
(Loc
,
6997 Defining_Unit_Name
=> Proc_Id
,
6999 Parameter_Specifications
=> New_List
(
7000 Make_Parameter_Specification
(Loc
,
7001 Defining_Identifier
=>
7002 Make_Defining_Identifier
(Loc
, Name_V
),
7004 New_Reference_To
(RTE
(RE_Address
), Loc
)))),
7006 Declarations
=> No_List
,
7008 Handled_Statement_Sequence
=>
7009 Make_Handled_Sequence_Of_Statements
(Loc
,
7010 Statements
=> Stmts
)));
7012 Set_TSS
(Typ
, Proc_Id
);
7013 end Make_Finalize_Address_Body
;
7015 ---------------------------------
7016 -- Make_Finalize_Address_Stmts --
7017 ---------------------------------
7019 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7020 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7021 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7023 Desg_Typ
: Entity_Id
;
7027 if Is_Array_Type
(Typ
) then
7028 if Is_Constrained
(First_Subtype
(Typ
)) then
7029 Desg_Typ
:= First_Subtype
(Typ
);
7031 Desg_Typ
:= Base_Type
(Typ
);
7034 -- Class-wide types of constrained root types
7036 elsif Is_Class_Wide_Type
(Typ
)
7037 and then Has_Discriminants
(Root_Type
(Typ
))
7039 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7042 Parent_Typ
: Entity_Id
;
7045 -- Climb the parent type chain looking for a non-constrained type
7047 Parent_Typ
:= Root_Type
(Typ
);
7048 while Parent_Typ
/= Etype
(Parent_Typ
)
7049 and then Has_Discriminants
(Parent_Typ
)
7051 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7053 Parent_Typ
:= Etype
(Parent_Typ
);
7056 -- Handle views created for tagged types with unknown
7059 if Is_Underlying_Record_View
(Parent_Typ
) then
7060 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7063 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7073 -- type Ptr_Typ is access all Typ;
7074 -- for Ptr_Typ'Storage_Size use 0;
7077 Make_Full_Type_Declaration
(Loc
,
7078 Defining_Identifier
=> Ptr_Typ
,
7080 Make_Access_To_Object_Definition
(Loc
,
7081 All_Present
=> True,
7082 Subtype_Indication
=> New_Reference_To
(Desg_Typ
, Loc
))),
7084 Make_Attribute_Definition_Clause
(Loc
,
7085 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7086 Chars
=> Name_Storage_Size
,
7087 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7089 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7091 -- Unconstrained arrays require special processing in order to retrieve
7092 -- the elements. To achieve this, we have to skip the dope vector which
7093 -- lays in front of the elements and then use a thin pointer to perform
7094 -- the address-to-access conversion.
7096 if Is_Array_Type
(Typ
)
7097 and then not Is_Constrained
(First_Subtype
(Typ
))
7100 Dope_Id
: Entity_Id
;
7103 -- Ensure that Ptr_Typ a thin pointer, generate:
7104 -- for Ptr_Typ'Size use System.Address'Size;
7107 Make_Attribute_Definition_Clause
(Loc
,
7108 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7111 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7114 -- Dnn : constant Storage_Offset :=
7115 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7117 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7120 Make_Object_Declaration
(Loc
,
7121 Defining_Identifier
=> Dope_Id
,
7122 Constant_Present
=> True,
7123 Object_Definition
=>
7124 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
7126 Make_Op_Divide
(Loc
,
7128 Make_Attribute_Reference
(Loc
,
7129 Prefix
=> New_Reference_To
(Desg_Typ
, Loc
),
7130 Attribute_Name
=> Name_Descriptor_Size
),
7132 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7134 -- Shift the address from the start of the dope vector to the
7135 -- start of the elements:
7139 -- Note that this is done through a wrapper routine since RTSfind
7140 -- cannot retrieve operations with string names of the form "+".
7143 Make_Function_Call
(Loc
,
7145 New_Reference_To
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7146 Parameter_Associations
=> New_List
(
7148 New_Reference_To
(Dope_Id
, Loc
)));
7152 -- Create the block and the finalization call
7155 Make_Block_Statement
(Loc
,
7156 Declarations
=> Decls
,
7158 Handled_Statement_Sequence
=>
7159 Make_Handled_Sequence_Of_Statements
(Loc
,
7160 Statements
=> New_List
(
7163 Make_Explicit_Dereference
(Loc
,
7164 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7165 Typ
=> Desg_Typ
)))));
7166 end Make_Finalize_Address_Stmts
;
7168 -------------------------------------
7169 -- Make_Handler_For_Ctrl_Operation --
7170 -------------------------------------
7174 -- when E : others =>
7175 -- Raise_From_Controlled_Operation (E);
7180 -- raise Program_Error [finalize raised exception];
7182 -- depending on whether Raise_From_Controlled_Operation is available
7184 function Make_Handler_For_Ctrl_Operation
7185 (Loc
: Source_Ptr
) return Node_Id
7188 -- Choice parameter (for the first case above)
7190 Raise_Node
: Node_Id
;
7191 -- Procedure call or raise statement
7194 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7195 -- it to Raise_From_Controlled_Operation so that the original exception
7196 -- name and message can be recorded in the exception message for
7199 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7200 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7202 Make_Procedure_Call_Statement
(Loc
,
7205 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7206 Parameter_Associations
=> New_List
(
7207 New_Reference_To
(E_Occ
, Loc
)));
7209 -- Restricted run-time: exception messages are not supported
7214 Make_Raise_Program_Error
(Loc
,
7215 Reason
=> PE_Finalize_Raised_Exception
);
7219 Make_Implicit_Exception_Handler
(Loc
,
7220 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7221 Choice_Parameter
=> E_Occ
,
7222 Statements
=> New_List
(Raise_Node
));
7223 end Make_Handler_For_Ctrl_Operation
;
7225 --------------------
7226 -- Make_Init_Call --
7227 --------------------
7229 function Make_Init_Call
7231 Typ
: Entity_Id
) return Node_Id
7233 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7240 -- Deal with the type and object reference. Depending on the context, an
7241 -- object reference may need several conversions.
7243 if Is_Concurrent_Type
(Typ
) then
7245 Utyp
:= Corresponding_Record_Type
(Typ
);
7246 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7248 elsif Is_Private_Type
(Typ
)
7249 and then Present
(Full_View
(Typ
))
7250 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7253 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7254 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7262 Set_Assignment_OK
(Ref
);
7264 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7266 -- Deal with non-tagged derivation of private views
7268 if Is_Untagged_Derivation
(Typ
)
7269 and then not Is_Conc
7271 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7272 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7274 -- The following is to prevent problems with UC see 1.156 RH ???
7276 Set_Assignment_OK
(Ref
);
7279 -- If the underlying_type is a subtype, then we are dealing with the
7280 -- completion of a private type. We need to access the base type and
7281 -- generate a conversion to it.
7283 if Utyp
/= Base_Type
(Utyp
) then
7284 pragma Assert
(Is_Private_Type
(Typ
));
7285 Utyp
:= Base_Type
(Utyp
);
7286 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7289 -- Select the appropriate version of initialize
7291 if Has_Controlled_Component
(Utyp
) then
7292 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7294 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7295 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7298 -- The object reference may need another conversion depending on the
7299 -- type of the formal and that of the actual.
7301 Ref
:= Convert_View
(Proc
, Ref
);
7304 -- [Deep_]Initialize (Ref);
7307 Make_Procedure_Call_Statement
(Loc
,
7309 New_Reference_To
(Proc
, Loc
),
7310 Parameter_Associations
=> New_List
(Ref
));
7313 ------------------------------
7314 -- Make_Local_Deep_Finalize --
7315 ------------------------------
7317 function Make_Local_Deep_Finalize
7319 Nam
: Entity_Id
) return Node_Id
7321 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7325 Formals
:= New_List
(
7329 Make_Parameter_Specification
(Loc
,
7330 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7332 Out_Present
=> True,
7333 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7335 -- F : Boolean := True
7337 Make_Parameter_Specification
(Loc
,
7338 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7339 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
),
7340 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
7342 -- Add the necessary number of counters to represent the initialization
7343 -- state of an object.
7346 Make_Subprogram_Body
(Loc
,
7348 Make_Procedure_Specification
(Loc
,
7349 Defining_Unit_Name
=> Nam
,
7350 Parameter_Specifications
=> Formals
),
7352 Declarations
=> No_List
,
7354 Handled_Statement_Sequence
=>
7355 Make_Handled_Sequence_Of_Statements
(Loc
,
7356 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7357 end Make_Local_Deep_Finalize
;
7359 ------------------------------------
7360 -- Make_Set_Finalize_Address_Call --
7361 ------------------------------------
7363 function Make_Set_Finalize_Address_Call
7366 Ptr_Typ
: Entity_Id
) return Node_Id
7368 Desig_Typ
: constant Entity_Id
:=
7369 Available_View
(Designated_Type
(Ptr_Typ
));
7370 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7371 Fin_Mas_Ref
: Node_Id
;
7375 -- If the context is a class-wide allocator, we use the class-wide type
7376 -- to obtain the proper Finalize_Address routine.
7378 if Is_Class_Wide_Type
(Desig_Typ
) then
7384 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7385 Utyp
:= Full_View
(Utyp
);
7388 if Is_Concurrent_Type
(Utyp
) then
7389 Utyp
:= Corresponding_Record_Type
(Utyp
);
7393 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7395 -- Deal with non-tagged derivation of private views. If the parent is
7396 -- now known to be protected, the finalization routine is the one
7397 -- defined on the corresponding record of the ancestor (corresponding
7398 -- records do not automatically inherit operations, but maybe they
7401 if Is_Untagged_Derivation
(Typ
) then
7402 if Is_Protected_Type
(Typ
) then
7403 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7405 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7407 if Is_Protected_Type
(Utyp
) then
7408 Utyp
:= Corresponding_Record_Type
(Utyp
);
7413 -- If the underlying_type is a subtype, we are dealing with the
7414 -- completion of a private type. We need to access the base type and
7415 -- generate a conversion to it.
7417 if Utyp
/= Base_Type
(Utyp
) then
7418 pragma Assert
(Is_Private_Type
(Typ
));
7420 Utyp
:= Base_Type
(Utyp
);
7423 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7425 -- If the call is from a build-in-place function, the Master parameter
7426 -- is actually a pointer. Dereference it for the call.
7428 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7429 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7433 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7436 Make_Procedure_Call_Statement
(Loc
,
7438 New_Reference_To
(RTE
(RE_Set_Finalize_Address
), Loc
),
7439 Parameter_Associations
=> New_List
(
7441 Make_Attribute_Reference
(Loc
,
7443 New_Reference_To
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7444 Attribute_Name
=> Name_Unrestricted_Access
)));
7445 end Make_Set_Finalize_Address_Call
;
7447 --------------------------
7448 -- Make_Transient_Block --
7449 --------------------------
7451 function Make_Transient_Block
7454 Par
: Node_Id
) return Node_Id
7456 Decls
: constant List_Id
:= New_List
;
7457 Instrs
: constant List_Id
:= New_List
(Action
);
7462 -- Case where only secondary stack use is involved
7464 if VM_Target
= No_VM
7465 and then Uses_Sec_Stack
(Current_Scope
)
7466 and then Nkind
(Action
) /= N_Simple_Return_Statement
7467 and then Nkind
(Par
) /= N_Exception_Handler
7473 S
:= Scope
(Current_Scope
);
7475 -- At the outer level, no need to release the sec stack
7477 if S
= Standard_Standard
then
7478 Set_Uses_Sec_Stack
(Current_Scope
, False);
7481 -- In a function, only release the sec stack if the function
7482 -- does not return on the sec stack otherwise the result may
7483 -- be lost. The caller is responsible for releasing.
7485 elsif Ekind
(S
) = E_Function
then
7486 Set_Uses_Sec_Stack
(Current_Scope
, False);
7488 if not Requires_Transient_Scope
(Etype
(S
)) then
7489 Set_Uses_Sec_Stack
(S
, True);
7490 Check_Restriction
(No_Secondary_Stack
, Action
);
7495 -- In a loop or entry we should install a block encompassing
7496 -- all the construct. For now just release right away.
7498 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7501 -- In a procedure or a block, we release on exit of the
7502 -- procedure or block. ??? memory leak can be created by
7505 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7506 Set_Uses_Sec_Stack
(S
, True);
7507 Check_Restriction
(No_Secondary_Stack
, Action
);
7508 Set_Uses_Sec_Stack
(Current_Scope
, False);
7518 -- Create the transient block. Set the parent now since the block itself
7519 -- is not part of the tree.
7522 Make_Block_Statement
(Loc
,
7523 Identifier
=> New_Reference_To
(Current_Scope
, Loc
),
7524 Declarations
=> Decls
,
7525 Handled_Statement_Sequence
=>
7526 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7527 Has_Created_Identifier
=> True);
7528 Set_Parent
(Block
, Par
);
7530 -- Insert actions stuck in the transient scopes as well as all freezing
7531 -- nodes needed by those actions.
7533 Insert_Actions_In_Scope_Around
(Action
);
7535 Insert
:= Prev
(Action
);
7536 if Present
(Insert
) then
7537 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7540 -- When the transient scope was established, we pushed the entry for the
7541 -- transient scope onto the scope stack, so that the scope was active
7542 -- for the installation of finalizable entities etc. Now we must remove
7543 -- this entry, since we have constructed a proper block.
7548 end Make_Transient_Block
;
7550 ------------------------
7551 -- Node_To_Be_Wrapped --
7552 ------------------------
7554 function Node_To_Be_Wrapped
return Node_Id
is
7556 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7557 end Node_To_Be_Wrapped
;
7559 ----------------------------
7560 -- Set_Node_To_Be_Wrapped --
7561 ----------------------------
7563 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7565 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7566 end Set_Node_To_Be_Wrapped
;
7568 ----------------------------------
7569 -- Store_After_Actions_In_Scope --
7570 ----------------------------------
7572 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
7573 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7576 if Present
(SE
.Actions_To_Be_Wrapped_After
) then
7577 Insert_List_Before_And_Analyze
(
7578 First
(SE
.Actions_To_Be_Wrapped_After
), L
);
7581 SE
.Actions_To_Be_Wrapped_After
:= L
;
7583 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7584 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7586 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7591 end Store_After_Actions_In_Scope
;
7593 -----------------------------------
7594 -- Store_Before_Actions_In_Scope --
7595 -----------------------------------
7597 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
7598 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7601 if Present
(SE
.Actions_To_Be_Wrapped_Before
) then
7602 Insert_List_After_And_Analyze
(
7603 Last
(SE
.Actions_To_Be_Wrapped_Before
), L
);
7606 SE
.Actions_To_Be_Wrapped_Before
:= L
;
7608 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7609 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7611 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7616 end Store_Before_Actions_In_Scope
;
7618 --------------------------------
7619 -- Wrap_Transient_Declaration --
7620 --------------------------------
7622 -- If a transient scope has been established during the processing of the
7623 -- Expression of an Object_Declaration, it is not possible to wrap the
7624 -- declaration into a transient block as usual case, otherwise the object
7625 -- would be itself declared in the wrong scope. Therefore, all entities (if
7626 -- any) defined in the transient block are moved to the proper enclosing
7627 -- scope, furthermore, if they are controlled variables they are finalized
7628 -- right after the declaration. The finalization list of the transient
7629 -- scope is defined as a renaming of the enclosing one so during their
7630 -- initialization they will be attached to the proper finalization list.
7631 -- For instance, the following declaration :
7633 -- X : Typ := F (G (A), G (B));
7635 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7636 -- is expanded into :
7638 -- X : Typ := [ complex Expression-Action ];
7639 -- [Deep_]Finalize (_v1);
7640 -- [Deep_]Finalize (_v2);
7642 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
7649 Encl_S
:= Scope
(S
);
7651 -- Insert Actions kept in the Scope stack
7653 Insert_Actions_In_Scope_Around
(N
);
7655 -- If the declaration is consuming some secondary stack, mark the
7656 -- enclosing scope appropriately.
7658 Uses_SS
:= Uses_Sec_Stack
(S
);
7661 -- Put the local entities back in the enclosing scope, and set the
7662 -- Is_Public flag appropriately.
7664 Transfer_Entities
(S
, Encl_S
);
7666 -- Mark the enclosing dynamic scope so that the sec stack will be
7667 -- released upon its exit unless this is a function that returns on
7668 -- the sec stack in which case this will be done by the caller.
7670 if VM_Target
= No_VM
and then Uses_SS
then
7671 S
:= Enclosing_Dynamic_Scope
(S
);
7673 if Ekind
(S
) = E_Function
7674 and then Requires_Transient_Scope
(Etype
(S
))
7678 Set_Uses_Sec_Stack
(S
);
7679 Check_Restriction
(No_Secondary_Stack
, N
);
7682 end Wrap_Transient_Declaration
;
7684 -------------------------------
7685 -- Wrap_Transient_Expression --
7686 -------------------------------
7688 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
7689 Expr
: constant Node_Id
:= Relocate_Node
(N
);
7690 Loc
: constant Source_Ptr
:= Sloc
(N
);
7691 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
7692 Typ
: constant Entity_Id
:= Etype
(N
);
7699 -- M : constant Mark_Id := SS_Mark;
7700 -- procedure Finalizer is ... (See Build_Finalizer)
7709 Insert_Actions
(N
, New_List
(
7710 Make_Object_Declaration
(Loc
,
7711 Defining_Identifier
=> Temp
,
7712 Object_Definition
=> New_Reference_To
(Typ
, Loc
)),
7714 Make_Transient_Block
(Loc
,
7716 Make_Assignment_Statement
(Loc
,
7717 Name
=> New_Reference_To
(Temp
, Loc
),
7718 Expression
=> Expr
),
7719 Par
=> Parent
(N
))));
7721 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
7722 Analyze_And_Resolve
(N
, Typ
);
7723 end Wrap_Transient_Expression
;
7725 ------------------------------
7726 -- Wrap_Transient_Statement --
7727 ------------------------------
7729 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
7730 Loc
: constant Source_Ptr
:= Sloc
(N
);
7731 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
7736 -- M : constant Mark_Id := SS_Mark;
7737 -- procedure Finalizer is ... (See Build_Finalizer)
7747 Make_Transient_Block
(Loc
,
7749 Par
=> Parent
(N
)));
7751 -- With the scope stack back to normal, we can call analyze on the
7752 -- resulting block. At this point, the transient scope is being
7753 -- treated like a perfectly normal scope, so there is nothing
7754 -- special about it.
7756 -- Note: Wrap_Transient_Statement is called with the node already
7757 -- analyzed (i.e. Analyzed (N) is True). This is important, since
7758 -- otherwise we would get a recursive processing of the node when
7759 -- we do this Analyze call.
7762 end Wrap_Transient_Statement
;