1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Build_Object_Declarations
1214 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1216 -- Since the total number of controlled objects is always known,
1217 -- build a subtype of Natural with precise bounds. This allows
1218 -- the backend to optimize the case statement. Generate:
1220 -- subtype Tnn is Natural range 0 .. Counter_Val;
1223 Make_Subtype_Declaration
(Loc
,
1224 Defining_Identifier
=> Counter_Typ
,
1225 Subtype_Indication
=>
1226 Make_Subtype_Indication
(Loc
,
1227 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
1229 Make_Range_Constraint
(Loc
,
1233 Make_Integer_Literal
(Loc
, Uint_0
),
1235 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1237 -- Generate the declaration of the counter itself:
1239 -- Counter : Integer := 0;
1242 Make_Object_Declaration
(Loc
,
1243 Defining_Identifier
=> Counter_Id
,
1244 Object_Definition
=> New_Reference_To
(Counter_Typ
, Loc
),
1245 Expression
=> Make_Integer_Literal
(Loc
, 0));
1247 -- Set the type of the counter explicitly to prevent errors when
1248 -- examining object declarations later on.
1250 Set_Etype
(Counter_Id
, Counter_Typ
);
1252 -- The counter and its type are inserted before the source
1253 -- declarations of N.
1255 Prepend_To
(Decls
, Counter_Decl
);
1256 Prepend_To
(Decls
, Counter_Typ_Decl
);
1258 -- The counter and its associated type must be manually analized
1259 -- since N has already been analyzed. Use the scope of the spec
1260 -- when inserting in a package.
1263 Push_Scope
(Spec_Id
);
1264 Analyze
(Counter_Typ_Decl
);
1265 Analyze
(Counter_Decl
);
1269 Analyze
(Counter_Typ_Decl
);
1270 Analyze
(Counter_Decl
);
1273 Jump_Alts
:= New_List
;
1276 -- If the context requires additional clean up, the finalization
1277 -- machinery is added after the clean up code.
1279 if Acts_As_Clean
then
1280 Finalizer_Stmts
:= Clean_Stmts
;
1281 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1283 Finalizer_Stmts
:= New_List
;
1286 if Has_Tagged_Types
then
1287 Tagged_Type_Stmts
:= New_List
;
1289 end Build_Components
;
1291 ----------------------
1292 -- Create_Finalizer --
1293 ----------------------
1295 procedure Create_Finalizer
is
1296 Body_Id
: Entity_Id
;
1299 Jump_Block
: Node_Id
;
1301 Label_Id
: Entity_Id
;
1303 function New_Finalizer_Name
return Name_Id
;
1304 -- Create a fully qualified name of a package spec or body finalizer.
1305 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1307 ------------------------
1308 -- New_Finalizer_Name --
1309 ------------------------
1311 function New_Finalizer_Name
return Name_Id
is
1312 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1313 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1314 -- has a non-standard scope, process the scope first.
1316 ------------------------
1317 -- New_Finalizer_Name --
1318 ------------------------
1320 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1322 if Scope
(Id
) = Standard_Standard
then
1323 Get_Name_String
(Chars
(Id
));
1326 New_Finalizer_Name
(Scope
(Id
));
1327 Add_Str_To_Name_Buffer
("__");
1328 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1330 end New_Finalizer_Name
;
1332 -- Start of processing for New_Finalizer_Name
1335 -- Create the fully qualified name of the enclosing scope
1337 New_Finalizer_Name
(Spec_Id
);
1340 -- __finalize_[spec|body]
1342 Add_Str_To_Name_Buffer
("__finalize_");
1344 if For_Package_Spec
then
1345 Add_Str_To_Name_Buffer
("spec");
1347 Add_Str_To_Name_Buffer
("body");
1351 end New_Finalizer_Name
;
1353 -- Start of processing for Create_Finalizer
1356 -- Step 1: Creation of the finalizer name
1358 -- Packages must use a distinct name for their finalizers since the
1359 -- binder will have to generate calls to them by name. The name is
1360 -- of the following form:
1362 -- xx__yy__finalize_[spec|body]
1365 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1366 Set_Has_Qualified_Name
(Fin_Id
);
1367 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1369 -- The default name is _finalizer
1373 Make_Defining_Identifier
(Loc
,
1374 Chars
=> New_External_Name
(Name_uFinalizer
));
1376 -- The visibility semantics of AT_END handlers force a strange
1377 -- separation of spec and body for stack-related finalizers:
1379 -- declare : Enclosing_Scope
1380 -- procedure _finalizer;
1382 -- <controlled objects>
1383 -- procedure _finalizer is
1389 -- Both spec and body are within the same construct and scope, but
1390 -- the body is part of the handled sequence of statements. This
1391 -- placement confuses the elaboration mechanism on targets where
1392 -- AT_END handlers are expanded into "when all others" handlers:
1395 -- when all others =>
1396 -- _finalizer; -- appears to require elab checks
1401 -- Since the compiler guarantees that the body of a _finalizer is
1402 -- always inserted in the same construct where the AT_END handler
1403 -- resides, there is no need for elaboration checks.
1405 Set_Kill_Elaboration_Checks
(Fin_Id
);
1408 -- Step 2: Creation of the finalizer specification
1411 -- procedure Fin_Id;
1414 Make_Subprogram_Declaration
(Loc
,
1416 Make_Procedure_Specification
(Loc
,
1417 Defining_Unit_Name
=> Fin_Id
));
1419 -- Step 3: Creation of the finalizer body
1421 if Has_Ctrl_Objs
then
1423 -- Add L0, the default destination to the jump block
1425 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1426 Set_Entity
(Label_Id
,
1427 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1428 Label
:= Make_Label
(Loc
, Label_Id
);
1433 Prepend_To
(Finalizer_Decls
,
1434 Make_Implicit_Label_Declaration
(Loc
,
1435 Defining_Identifier
=> Entity
(Label_Id
),
1436 Label_Construct
=> Label
));
1442 Append_To
(Jump_Alts
,
1443 Make_Case_Statement_Alternative
(Loc
,
1444 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1445 Statements
=> New_List
(
1446 Make_Goto_Statement
(Loc
,
1447 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
1452 Append_To
(Finalizer_Stmts
, Label
);
1454 -- The local exception does not need to be reraised for library-
1455 -- level finalizers. Generate:
1457 -- if Raised and then not Abort then
1458 -- Raise_From_Controlled_Operation (E);
1462 and then Exceptions_OK
1464 Append_To
(Finalizer_Stmts
,
1465 Build_Raise_Statement
(Finalizer_Data
));
1468 -- Create the jump block which controls the finalization flow
1469 -- depending on the value of the state counter.
1472 Make_Case_Statement
(Loc
,
1473 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1474 Alternatives
=> Jump_Alts
);
1477 and then Present
(Jump_Block_Insert_Nod
)
1479 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1481 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1485 -- Add the library-level tagged type unregistration machinery before
1486 -- the jump block circuitry. This ensures that external tags will be
1487 -- removed even if a finalization exception occurs at some point.
1489 if Has_Tagged_Types
then
1490 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1493 -- Add a call to the previous At_End handler if it exists. The call
1494 -- must always precede the jump block.
1496 if Present
(Prev_At_End
) then
1497 Prepend_To
(Finalizer_Stmts
,
1498 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1500 -- Clear the At_End handler since we have already generated the
1501 -- proper replacement call for it.
1503 Set_At_End_Proc
(HSS
, Empty
);
1506 -- Release the secondary stack mark
1508 if Present
(Mark_Id
) then
1509 Append_To
(Finalizer_Stmts
,
1510 Make_Procedure_Call_Statement
(Loc
,
1512 New_Reference_To
(RTE
(RE_SS_Release
), Loc
),
1513 Parameter_Associations
=> New_List
(
1514 New_Reference_To
(Mark_Id
, Loc
))));
1517 -- Protect the statements with abort defer/undefer. This is only when
1518 -- aborts are allowed and the clean up statements require deferral or
1519 -- there are controlled objects to be finalized.
1523 (Defer_Abort
or else Has_Ctrl_Objs
)
1525 Prepend_To
(Finalizer_Stmts
,
1526 Make_Procedure_Call_Statement
(Loc
,
1527 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
)));
1529 Append_To
(Finalizer_Stmts
,
1530 Make_Procedure_Call_Statement
(Loc
,
1531 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
1535 -- procedure Fin_Id is
1536 -- Abort : constant Boolean := Triggered_By_Abort;
1538 -- Abort : constant Boolean := False; -- no abort
1540 -- E : Exception_Occurrence; -- All added if flag
1541 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1547 -- Abort_Defer; -- Added if abort is allowed
1548 -- <call to Prev_At_End> -- Added if exists
1549 -- <cleanup statements> -- Added if Acts_As_Clean
1550 -- <jump block> -- Added if Has_Ctrl_Objs
1551 -- <finalization statements> -- Added if Has_Ctrl_Objs
1552 -- <stack release> -- Added if Mark_Id exists
1553 -- Abort_Undefer; -- Added if abort is allowed
1556 -- Create the body of the finalizer
1558 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1561 Set_Has_Qualified_Name
(Body_Id
);
1562 Set_Has_Fully_Qualified_Name
(Body_Id
);
1566 Make_Subprogram_Body
(Loc
,
1568 Make_Procedure_Specification
(Loc
,
1569 Defining_Unit_Name
=> Body_Id
),
1570 Declarations
=> Finalizer_Decls
,
1571 Handled_Statement_Sequence
=>
1572 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1574 -- Step 4: Spec and body insertion, analysis
1578 -- If the package spec has private declarations, the finalizer
1579 -- body must be added to the end of the list in order to have
1580 -- visibility of all private controlled objects.
1582 if For_Package_Spec
then
1583 if Present
(Priv_Decls
) then
1584 Append_To
(Priv_Decls
, Fin_Spec
);
1585 Append_To
(Priv_Decls
, Fin_Body
);
1587 Append_To
(Decls
, Fin_Spec
);
1588 Append_To
(Decls
, Fin_Body
);
1591 -- For package bodies, both the finalizer spec and body are
1592 -- inserted at the end of the package declarations.
1595 Append_To
(Decls
, Fin_Spec
);
1596 Append_To
(Decls
, Fin_Body
);
1599 -- Push the name of the package
1601 Push_Scope
(Spec_Id
);
1609 -- Create the spec for the finalizer. The At_End handler must be
1610 -- able to call the body which resides in a nested structure.
1614 -- procedure Fin_Id; -- Spec
1616 -- <objects and possibly statements>
1617 -- procedure Fin_Id is ... -- Body
1620 -- Fin_Id; -- At_End handler
1623 pragma Assert
(Present
(Spec_Decls
));
1625 Append_To
(Spec_Decls
, Fin_Spec
);
1628 -- When the finalizer acts solely as a clean up routine, the body
1629 -- is inserted right after the spec.
1632 and then not Has_Ctrl_Objs
1634 Insert_After
(Fin_Spec
, Fin_Body
);
1636 -- In all other cases the body is inserted after either:
1638 -- 1) The counter update statement of the last controlled object
1639 -- 2) The last top level nested controlled package
1640 -- 3) The last top level controlled instantiation
1643 -- Manually freeze the spec. This is somewhat of a hack because
1644 -- a subprogram is frozen when its body is seen and the freeze
1645 -- node appears right before the body. However, in this case,
1646 -- the spec must be frozen earlier since the At_End handler
1647 -- must be able to call it.
1650 -- procedure Fin_Id; -- Spec
1651 -- [Fin_Id] -- Freeze node
1655 -- Fin_Id; -- At_End handler
1658 Ensure_Freeze_Node
(Fin_Id
);
1659 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1660 Set_Is_Frozen
(Fin_Id
);
1662 -- In the case where the last construct to contain a controlled
1663 -- object is either a nested package, an instantiation or a
1664 -- freeze node, the body must be inserted directly after the
1667 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1669 N_Package_Declaration
,
1672 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1675 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1680 end Create_Finalizer
;
1682 --------------------------
1683 -- Process_Declarations --
1684 --------------------------
1686 procedure Process_Declarations
1688 Preprocess
: Boolean := False;
1689 Top_Level
: Boolean := False)
1694 Obj_Typ
: Entity_Id
;
1695 Pack_Id
: Entity_Id
;
1699 Old_Counter_Val
: Int
;
1700 -- This variable is used to determine whether a nested package or
1701 -- instance contains at least one controlled object.
1703 procedure Processing_Actions
1704 (Has_No_Init
: Boolean := False;
1705 Is_Protected
: Boolean := False);
1706 -- Depending on the mode of operation of Process_Declarations, either
1707 -- increment the controlled object counter, set the controlled object
1708 -- flag and store the last top level construct or process the current
1709 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1710 -- the current declaration may not have initialization proc(s). Flag
1711 -- Is_Protected should be set when the current declaration denotes a
1712 -- simple protected object.
1714 ------------------------
1715 -- Processing_Actions --
1716 ------------------------
1718 procedure Processing_Actions
1719 (Has_No_Init
: Boolean := False;
1720 Is_Protected
: Boolean := False)
1723 -- Library-level tagged type
1725 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1727 Has_Tagged_Types
:= True;
1730 and then No
(Last_Top_Level_Ctrl_Construct
)
1732 Last_Top_Level_Ctrl_Construct
:= Decl
;
1736 Process_Tagged_Type_Declaration
(Decl
);
1739 -- Controlled object declaration
1743 Counter_Val
:= Counter_Val
+ 1;
1744 Has_Ctrl_Objs
:= True;
1747 and then No
(Last_Top_Level_Ctrl_Construct
)
1749 Last_Top_Level_Ctrl_Construct
:= Decl
;
1753 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1756 end Processing_Actions
;
1758 -- Start of processing for Process_Declarations
1761 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1765 -- Process all declarations in reverse order
1767 Decl
:= Last_Non_Pragma
(Decls
);
1768 while Present
(Decl
) loop
1770 -- Library-level tagged types
1772 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1773 Typ
:= Defining_Identifier
(Decl
);
1775 if Is_Tagged_Type
(Typ
)
1776 and then Is_Library_Level_Entity
(Typ
)
1777 and then Convention
(Typ
) = Convention_Ada
1778 and then Present
(Access_Disp_Table
(Typ
))
1779 and then RTE_Available
(RE_Register_Tag
)
1780 and then not No_Run_Time_Mode
1781 and then not Is_Abstract_Type
(Typ
)
1786 -- Regular object declarations
1788 elsif Nkind
(Decl
) = N_Object_Declaration
then
1789 Obj_Id
:= Defining_Identifier
(Decl
);
1790 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1791 Expr
:= Expression
(Decl
);
1793 -- Bypass any form of processing for objects which have their
1794 -- finalization disabled. This applies only to objects at the
1798 and then Finalize_Storage_Only
(Obj_Typ
)
1802 -- Transient variables are treated separately in order to
1803 -- minimize the size of the generated code. For details, see
1804 -- Process_Transient_Objects.
1806 elsif Is_Processed_Transient
(Obj_Id
) then
1809 -- The object is of the form:
1810 -- Obj : Typ [:= Expr];
1812 -- Do not process the incomplete view of a deferred constant.
1813 -- Do not consider tag-to-class-wide conversions.
1815 elsif not Is_Imported
(Obj_Id
)
1816 and then Needs_Finalization
(Obj_Typ
)
1817 and then not (Ekind
(Obj_Id
) = E_Constant
1818 and then not Has_Completion
(Obj_Id
))
1819 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1823 -- The object is of the form:
1824 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1826 -- Obj : Access_Typ :=
1827 -- BIP_Function_Call
1828 -- (..., BIPaccess => null, ...)'reference;
1830 elsif Is_Access_Type
(Obj_Typ
)
1831 and then Needs_Finalization
1832 (Available_View
(Designated_Type
(Obj_Typ
)))
1833 and then Present
(Expr
)
1835 (Is_Null_Access_BIP_Func_Call
(Expr
)
1837 (Is_Non_BIP_Func_Call
(Expr
)
1838 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1840 Processing_Actions
(Has_No_Init
=> True);
1842 -- Processing for "hook" objects generated for controlled
1843 -- transients declared inside an Expression_With_Actions.
1845 elsif Is_Access_Type
(Obj_Typ
)
1846 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
1847 and then Nkind
(Return_Flag_Or_Transient_Decl
(Obj_Id
)) =
1848 N_Object_Declaration
1849 and then Is_Finalizable_Transient
1850 (Return_Flag_Or_Transient_Decl
(Obj_Id
), Decl
)
1852 Processing_Actions
(Has_No_Init
=> True);
1854 -- Simple protected objects which use type System.Tasking.
1855 -- Protected_Objects.Protection to manage their locks should
1856 -- be treated as controlled since they require manual cleanup.
1857 -- The only exception is illustrated in the following example:
1860 -- type Ctrl is new Controlled ...
1861 -- procedure Finalize (Obj : in out Ctrl);
1865 -- package body Pkg is
1866 -- protected Prot is
1867 -- procedure Do_Something (Obj : in out Ctrl);
1870 -- protected body Prot is
1871 -- procedure Do_Something (Obj : in out Ctrl) is ...
1874 -- procedure Finalize (Obj : in out Ctrl) is
1876 -- Prot.Do_Something (Obj);
1880 -- Since for the most part entities in package bodies depend on
1881 -- those in package specs, Prot's lock should be cleaned up
1882 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1883 -- This act however attempts to invoke Do_Something and fails
1884 -- because the lock has disappeared.
1886 elsif Ekind
(Obj_Id
) = E_Variable
1887 and then not In_Library_Level_Package_Body
(Obj_Id
)
1889 (Is_Simple_Protected_Type
(Obj_Typ
)
1890 or else Has_Simple_Protected_Object
(Obj_Typ
))
1892 Processing_Actions
(Is_Protected
=> True);
1895 -- Specific cases of object renamings
1897 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1898 Obj_Id
:= Defining_Identifier
(Decl
);
1899 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1901 -- Bypass any form of processing for objects which have their
1902 -- finalization disabled. This applies only to objects at the
1906 and then Finalize_Storage_Only
(Obj_Typ
)
1910 -- Return object of a build-in-place function. This case is
1911 -- recognized and marked by the expansion of an extended return
1912 -- statement (see Expand_N_Extended_Return_Statement).
1914 elsif Needs_Finalization
(Obj_Typ
)
1915 and then Is_Return_Object
(Obj_Id
)
1916 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
1918 Processing_Actions
(Has_No_Init
=> True);
1920 -- Detect a case where a source object has been initialized by
1921 -- a controlled function call which was later rewritten as a
1922 -- class-wide conversion of Ada.Tags.Displace.
1924 -- Obj : Class_Wide_Type := Function_Call (...);
1926 -- Temp : ... := Function_Call (...)'reference;
1927 -- Obj : Class_Wide_Type renames
1928 -- (... Ada.Tags.Displace (Temp));
1930 elsif Is_Displacement_Of_Ctrl_Function_Result
(Obj_Id
) then
1931 Processing_Actions
(Has_No_Init
=> True);
1934 -- Inspect the freeze node of an access-to-controlled type and
1935 -- look for a delayed finalization master. This case arises when
1936 -- the freeze actions are inserted at a later time than the
1937 -- expansion of the context. Since Build_Finalizer is never called
1938 -- on a single construct twice, the master will be ultimately
1939 -- left out and never finalized. This is also needed for freeze
1940 -- actions of designated types themselves, since in some cases the
1941 -- finalization master is associated with a designated type's
1942 -- freeze node rather than that of the access type (see handling
1943 -- for freeze actions in Build_Finalization_Master).
1945 elsif Nkind
(Decl
) = N_Freeze_Entity
1946 and then Present
(Actions
(Decl
))
1948 Typ
:= Entity
(Decl
);
1950 if (Is_Access_Type
(Typ
)
1951 and then not Is_Access_Subprogram_Type
(Typ
)
1952 and then Needs_Finalization
1953 (Available_View
(Designated_Type
(Typ
))))
1954 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
1956 Old_Counter_Val
:= Counter_Val
;
1958 -- Freeze nodes are considered to be identical to packages
1959 -- and blocks in terms of nesting. The difference is that
1960 -- a finalization master created inside the freeze node is
1961 -- at the same nesting level as the node itself.
1963 Process_Declarations
(Actions
(Decl
), Preprocess
);
1965 -- The freeze node contains a finalization master
1969 and then No
(Last_Top_Level_Ctrl_Construct
)
1970 and then Counter_Val
> Old_Counter_Val
1972 Last_Top_Level_Ctrl_Construct
:= Decl
;
1976 -- Nested package declarations, avoid generics
1978 elsif Nkind
(Decl
) = N_Package_Declaration
then
1979 Spec
:= Specification
(Decl
);
1980 Pack_Id
:= Defining_Unit_Name
(Spec
);
1982 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
1983 Pack_Id
:= Defining_Identifier
(Pack_Id
);
1986 if Ekind
(Pack_Id
) /= E_Generic_Package
then
1987 Old_Counter_Val
:= Counter_Val
;
1988 Process_Declarations
1989 (Private_Declarations
(Spec
), Preprocess
);
1990 Process_Declarations
1991 (Visible_Declarations
(Spec
), Preprocess
);
1993 -- Either the visible or the private declarations contain a
1994 -- controlled object. The nested package declaration is the
1995 -- last such construct.
1999 and then No
(Last_Top_Level_Ctrl_Construct
)
2000 and then Counter_Val
> Old_Counter_Val
2002 Last_Top_Level_Ctrl_Construct
:= Decl
;
2006 -- Nested package bodies, avoid generics
2008 elsif Nkind
(Decl
) = N_Package_Body
then
2009 Spec
:= Corresponding_Spec
(Decl
);
2011 if Ekind
(Spec
) /= E_Generic_Package
then
2012 Old_Counter_Val
:= Counter_Val
;
2013 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2015 -- The nested package body is the last construct to contain
2016 -- a controlled object.
2020 and then No
(Last_Top_Level_Ctrl_Construct
)
2021 and then Counter_Val
> Old_Counter_Val
2023 Last_Top_Level_Ctrl_Construct
:= Decl
;
2027 -- Handle a rare case caused by a controlled transient variable
2028 -- created as part of a record init proc. The variable is wrapped
2029 -- in a block, but the block is not associated with a transient
2032 elsif Nkind
(Decl
) = N_Block_Statement
2033 and then Inside_Init_Proc
2035 Old_Counter_Val
:= Counter_Val
;
2037 if Present
(Handled_Statement_Sequence
(Decl
)) then
2038 Process_Declarations
2039 (Statements
(Handled_Statement_Sequence
(Decl
)),
2043 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2045 -- Either the declaration or statement list of the block has a
2046 -- controlled object.
2050 and then No
(Last_Top_Level_Ctrl_Construct
)
2051 and then Counter_Val
> Old_Counter_Val
2053 Last_Top_Level_Ctrl_Construct
:= Decl
;
2057 Prev_Non_Pragma
(Decl
);
2059 end Process_Declarations
;
2061 --------------------------------
2062 -- Process_Object_Declaration --
2063 --------------------------------
2065 procedure Process_Object_Declaration
2067 Has_No_Init
: Boolean := False;
2068 Is_Protected
: Boolean := False)
2070 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2071 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2073 Count_Ins
: Node_Id
;
2075 Fin_Stmts
: List_Id
;
2078 Label_Id
: Entity_Id
;
2080 Obj_Typ
: Entity_Id
;
2082 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2083 -- Once it has been established that the current object is in fact a
2084 -- return object of build-in-place function Func_Id, generate the
2085 -- following cleanup code:
2087 -- if BIPallocfrom > Secondary_Stack'Pos
2088 -- and then BIPfinalizationmaster /= null
2091 -- type Ptr_Typ is access Obj_Typ;
2092 -- for Ptr_Typ'Storage_Pool
2093 -- use Base_Pool (BIPfinalizationmaster);
2095 -- Free (Ptr_Typ (Temp));
2099 -- Obj_Typ is the type of the current object, Temp is the original
2100 -- allocation which Obj_Id renames.
2102 procedure Find_Last_Init
2105 Last_Init
: out Node_Id
;
2106 Body_Insert
: out Node_Id
);
2107 -- An object declaration has at least one and at most two init calls:
2108 -- that of the type and the user-defined initialize. Given an object
2109 -- declaration, Last_Init denotes the last initialization call which
2110 -- follows the declaration. Body_Insert denotes the place where the
2111 -- finalizer body could be potentially inserted.
2113 -----------------------------
2114 -- Build_BIP_Cleanup_Stmts --
2115 -----------------------------
2117 function Build_BIP_Cleanup_Stmts
2118 (Func_Id
: Entity_Id
) return Node_Id
2120 Decls
: constant List_Id
:= New_List
;
2121 Fin_Mas_Id
: constant Entity_Id
:=
2122 Build_In_Place_Formal
2123 (Func_Id
, BIP_Finalization_Master
);
2124 Obj_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2125 Temp_Id
: constant Entity_Id
:=
2126 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2130 Free_Stmt
: Node_Id
;
2131 Pool_Id
: Entity_Id
;
2132 Ptr_Typ
: Entity_Id
;
2136 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2138 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2141 Make_Object_Renaming_Declaration
(Loc
,
2142 Defining_Identifier
=> Pool_Id
,
2144 New_Reference_To
(RTE
(RE_Root_Storage_Pool
), Loc
),
2146 Make_Explicit_Dereference
(Loc
,
2148 Make_Function_Call
(Loc
,
2150 New_Reference_To
(RTE
(RE_Base_Pool
), Loc
),
2151 Parameter_Associations
=> New_List
(
2152 Make_Explicit_Dereference
(Loc
,
2153 Prefix
=> New_Reference_To
(Fin_Mas_Id
, Loc
)))))));
2155 -- Create an access type which uses the storage pool of the
2156 -- caller's finalization master.
2159 -- type Ptr_Typ is access Obj_Typ;
2161 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2164 Make_Full_Type_Declaration
(Loc
,
2165 Defining_Identifier
=> Ptr_Typ
,
2167 Make_Access_To_Object_Definition
(Loc
,
2168 Subtype_Indication
=> New_Reference_To
(Obj_Typ
, Loc
))));
2170 -- Perform minor decoration in order to set the master and the
2171 -- storage pool attributes.
2173 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2174 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2175 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2177 -- Create an explicit free statement. Note that the free uses the
2178 -- caller's pool expressed as a renaming.
2181 Make_Free_Statement
(Loc
,
2183 Unchecked_Convert_To
(Ptr_Typ
,
2184 New_Reference_To
(Temp_Id
, Loc
)));
2186 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2188 -- Create a block to house the dummy type and the instantiation as
2189 -- well as to perform the cleanup the temporary.
2195 -- Free (Ptr_Typ (Temp_Id));
2199 Make_Block_Statement
(Loc
,
2200 Declarations
=> Decls
,
2201 Handled_Statement_Sequence
=>
2202 Make_Handled_Sequence_Of_Statements
(Loc
,
2203 Statements
=> New_List
(Free_Stmt
)));
2206 -- if BIPfinalizationmaster /= null then
2210 Left_Opnd
=> New_Reference_To
(Fin_Mas_Id
, Loc
),
2211 Right_Opnd
=> Make_Null
(Loc
));
2213 -- For constrained or tagged results escalate the condition to
2214 -- include the allocation format. Generate:
2216 -- if BIPallocform > Secondary_Stack'Pos
2217 -- and then BIPfinalizationmaster /= null
2220 if not Is_Constrained
(Obj_Typ
)
2221 or else Is_Tagged_Type
(Obj_Typ
)
2224 Alloc
: constant Entity_Id
:=
2225 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2231 Left_Opnd
=> New_Reference_To
(Alloc
, Loc
),
2233 Make_Integer_Literal
(Loc
,
2235 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2237 Right_Opnd
=> Cond
);
2247 Make_If_Statement
(Loc
,
2249 Then_Statements
=> New_List
(Free_Blk
));
2250 end Build_BIP_Cleanup_Stmts
;
2252 --------------------
2253 -- Find_Last_Init --
2254 --------------------
2256 procedure Find_Last_Init
2259 Last_Init
: out Node_Id
;
2260 Body_Insert
: out Node_Id
)
2262 Nod_1
: Node_Id
:= Empty
;
2263 Nod_2
: Node_Id
:= Empty
;
2266 function Is_Init_Call
2268 Typ
: Entity_Id
) return Boolean;
2269 -- Given an arbitrary node, determine whether N is a procedure
2270 -- call and if it is, try to match the name of the call with the
2271 -- [Deep_]Initialize proc of Typ.
2273 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2274 -- Given a statement which is part of a list, return the next
2275 -- real statement while skipping over dynamic elab checks.
2281 function Is_Init_Call
2283 Typ
: Entity_Id
) return Boolean
2286 -- A call to [Deep_]Initialize is always direct
2288 if Nkind
(N
) = N_Procedure_Call_Statement
2289 and then Nkind
(Name
(N
)) = N_Identifier
2292 Call_Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2293 Deep_Init
: constant Entity_Id
:=
2294 TSS
(Typ
, TSS_Deep_Initialize
);
2295 Init
: Entity_Id
:= Empty
;
2298 -- A type may have controlled components but not be
2301 if Is_Controlled
(Typ
) then
2302 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2304 if Present
(Init
) then
2305 Init
:= Ultimate_Alias
(Init
);
2310 (Present
(Deep_Init
) and then Call_Ent
= Deep_Init
)
2312 (Present
(Init
) and then Call_Ent
= Init
);
2319 -----------------------------
2320 -- Next_Suitable_Statement --
2321 -----------------------------
2323 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2324 Result
: Node_Id
:= Next
(Stmt
);
2327 -- Skip over access-before-elaboration checks
2329 if Dynamic_Elaboration_Checks
2330 and then Nkind
(Result
) = N_Raise_Program_Error
2332 Result
:= Next
(Result
);
2336 end Next_Suitable_Statement
;
2338 -- Start of processing for Find_Last_Init
2342 Body_Insert
:= Empty
;
2344 -- Object renamings and objects associated with controlled
2345 -- function results do not have initialization calls.
2351 if Is_Concurrent_Type
(Typ
) then
2352 Utyp
:= Corresponding_Record_Type
(Typ
);
2357 if Is_Private_Type
(Utyp
)
2358 and then Present
(Full_View
(Utyp
))
2360 Utyp
:= Full_View
(Utyp
);
2363 -- The init procedures are arranged as follows:
2365 -- Object : Controlled_Type;
2366 -- Controlled_TypeIP (Object);
2367 -- [[Deep_]Initialize (Object);]
2369 -- where the user-defined initialize may be optional or may appear
2370 -- inside a block when abort deferral is needed.
2372 Nod_1
:= Next_Suitable_Statement
(Decl
);
2373 if Present
(Nod_1
) then
2374 Nod_2
:= Next_Suitable_Statement
(Nod_1
);
2376 -- The statement following an object declaration is always a
2377 -- call to the type init proc.
2382 -- Optional user-defined init or deep init processing
2384 if Present
(Nod_2
) then
2386 -- The statement following the type init proc may be a block
2387 -- statement in cases where abort deferral is required.
2389 if Nkind
(Nod_2
) = N_Block_Statement
then
2391 HSS
: constant Node_Id
:=
2392 Handled_Statement_Sequence
(Nod_2
);
2397 and then Present
(Statements
(HSS
))
2399 Stmt
:= First
(Statements
(HSS
));
2401 -- Examine individual block statements and locate the
2402 -- call to [Deep_]Initialze.
2404 while Present
(Stmt
) loop
2405 if Is_Init_Call
(Stmt
, Utyp
) then
2407 Body_Insert
:= Nod_2
;
2417 elsif Is_Init_Call
(Nod_2
, Utyp
) then
2423 -- Start of processing for Process_Object_Declaration
2426 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
2427 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2429 -- Handle access types
2431 if Is_Access_Type
(Obj_Typ
) then
2432 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2433 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2436 Set_Etype
(Obj_Ref
, Obj_Typ
);
2438 -- Set a new value for the state counter and insert the statement
2439 -- after the object declaration. Generate:
2441 -- Counter := <value>;
2444 Make_Assignment_Statement
(Loc
,
2445 Name
=> New_Reference_To
(Counter_Id
, Loc
),
2446 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2448 -- Insert the counter after all initialization has been done. The
2449 -- place of insertion depends on the context. When dealing with a
2450 -- controlled function, the counter is inserted directly after the
2451 -- declaration because such objects lack init calls.
2453 Find_Last_Init
(Decl
, Obj_Typ
, Count_Ins
, Body_Ins
);
2455 Insert_After
(Count_Ins
, Inc_Decl
);
2458 -- If the current declaration is the last in the list, the finalizer
2459 -- body needs to be inserted after the set counter statement for the
2460 -- current object declaration. This is complicated by the fact that
2461 -- the set counter statement may appear in abort deferred block. In
2462 -- that case, the proper insertion place is after the block.
2464 if No
(Finalizer_Insert_Nod
) then
2466 -- Insertion after an abort deffered block
2468 if Present
(Body_Ins
) then
2469 Finalizer_Insert_Nod
:= Body_Ins
;
2471 Finalizer_Insert_Nod
:= Inc_Decl
;
2475 -- Create the associated label with this object, generate:
2477 -- L<counter> : label;
2480 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2482 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2483 Label
:= Make_Label
(Loc
, Label_Id
);
2485 Prepend_To
(Finalizer_Decls
,
2486 Make_Implicit_Label_Declaration
(Loc
,
2487 Defining_Identifier
=> Entity
(Label_Id
),
2488 Label_Construct
=> Label
));
2490 -- Create the associated jump with this object, generate:
2492 -- when <counter> =>
2495 Prepend_To
(Jump_Alts
,
2496 Make_Case_Statement_Alternative
(Loc
,
2497 Discrete_Choices
=> New_List
(
2498 Make_Integer_Literal
(Loc
, Counter_Val
)),
2499 Statements
=> New_List
(
2500 Make_Goto_Statement
(Loc
,
2501 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
2503 -- Insert the jump destination, generate:
2507 Append_To
(Finalizer_Stmts
, Label
);
2509 -- Processing for simple protected objects. Such objects require
2510 -- manual finalization of their lock managers.
2512 if Is_Protected
then
2513 Fin_Stmts
:= No_List
;
2515 if Is_Simple_Protected_Type
(Obj_Typ
) then
2516 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2518 if Present
(Fin_Call
) then
2519 Fin_Stmts
:= New_List
(Fin_Call
);
2522 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2523 if Is_Record_Type
(Obj_Typ
) then
2524 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2525 elsif Is_Array_Type
(Obj_Typ
) then
2526 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2532 -- System.Tasking.Protected_Objects.Finalize_Protection
2540 if Present
(Fin_Stmts
) then
2541 Append_To
(Finalizer_Stmts
,
2542 Make_Block_Statement
(Loc
,
2543 Handled_Statement_Sequence
=>
2544 Make_Handled_Sequence_Of_Statements
(Loc
,
2545 Statements
=> Fin_Stmts
,
2547 Exception_Handlers
=> New_List
(
2548 Make_Exception_Handler
(Loc
,
2549 Exception_Choices
=> New_List
(
2550 Make_Others_Choice
(Loc
)),
2552 Statements
=> New_List
(
2553 Make_Null_Statement
(Loc
)))))));
2556 -- Processing for regular controlled objects
2560 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2562 -- begin -- Exception handlers allowed
2563 -- [Deep_]Finalize (Obj);
2566 -- when Id : others =>
2567 -- if not Raised then
2569 -- Save_Occurrence (E, Id);
2578 if Exceptions_OK
then
2579 Fin_Stmts
:= New_List
(
2580 Make_Block_Statement
(Loc
,
2581 Handled_Statement_Sequence
=>
2582 Make_Handled_Sequence_Of_Statements
(Loc
,
2583 Statements
=> New_List
(Fin_Call
),
2585 Exception_Handlers
=> New_List
(
2586 Build_Exception_Handler
2587 (Finalizer_Data
, For_Package
)))));
2589 -- When exception handlers are prohibited, the finalization call
2590 -- appears unprotected. Any exception raised during finalization
2591 -- will bypass the circuitry which ensures the cleanup of all
2592 -- remaining objects.
2595 Fin_Stmts
:= New_List
(Fin_Call
);
2598 -- If we are dealing with a return object of a build-in-place
2599 -- function, generate the following cleanup statements:
2601 -- if BIPallocfrom > Secondary_Stack'Pos
2602 -- and then BIPfinalizationmaster /= null
2605 -- type Ptr_Typ is access Obj_Typ;
2606 -- for Ptr_Typ'Storage_Pool use
2607 -- Base_Pool (BIPfinalizationmaster.all).all;
2609 -- Free (Ptr_Typ (Temp));
2613 -- The generated code effectively detaches the temporary from the
2614 -- caller finalization master and deallocates the object. This is
2615 -- disabled on .NET/JVM because pools are not supported.
2617 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2619 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2621 if Is_Build_In_Place_Function
(Func_Id
)
2622 and then Needs_BIP_Finalization_Master
(Func_Id
)
2624 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2629 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2630 and then Present
(Return_Flag_Or_Transient_Decl
(Obj_Id
))
2632 -- Return objects use a flag to aid their potential
2633 -- finalization when the enclosing function fails to return
2634 -- properly. Generate:
2637 -- <object finalization statements>
2640 if Is_Return_Object
(Obj_Id
) then
2641 Fin_Stmts
:= New_List
(
2642 Make_If_Statement
(Loc
,
2647 (Return_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2649 Then_Statements
=> Fin_Stmts
));
2651 -- Temporaries created for the purpose of "exporting" a
2652 -- controlled transient out of an Expression_With_Actions (EWA)
2653 -- need guards. The following illustrates the usage of such
2656 -- Access_Typ : access [all] Obj_Typ;
2657 -- Temp : Access_Typ := null;
2658 -- <Counter> := ...;
2661 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2662 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2664 -- Temp := Ctrl_Trans'Unchecked_Access;
2667 -- The finalization machinery does not process EWA nodes as
2668 -- this may lead to premature finalization of expressions. Note
2669 -- that Temp is marked as being properly initialized regardless
2670 -- of whether the initialization of Ctrl_Trans succeeded. Since
2671 -- a failed initialization may leave Temp with a value of null,
2672 -- add a guard to handle this case:
2674 -- if Obj /= null then
2675 -- <object finalization statements>
2680 (Nkind
(Return_Flag_Or_Transient_Decl
(Obj_Id
)) =
2681 N_Object_Declaration
);
2683 Fin_Stmts
:= New_List
(
2684 Make_If_Statement
(Loc
,
2687 Left_Opnd
=> New_Reference_To
(Obj_Id
, Loc
),
2688 Right_Opnd
=> Make_Null
(Loc
)),
2690 Then_Statements
=> Fin_Stmts
));
2695 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2697 -- Since the declarations are examined in reverse, the state counter
2698 -- must be decremented in order to keep with the true position of
2701 Counter_Val
:= Counter_Val
- 1;
2702 end Process_Object_Declaration
;
2704 -------------------------------------
2705 -- Process_Tagged_Type_Declaration --
2706 -------------------------------------
2708 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2709 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2710 DT_Ptr
: constant Entity_Id
:=
2711 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2714 -- Ada.Tags.Unregister_Tag (<Typ>P);
2716 Append_To
(Tagged_Type_Stmts
,
2717 Make_Procedure_Call_Statement
(Loc
,
2719 New_Reference_To
(RTE
(RE_Unregister_Tag
), Loc
),
2720 Parameter_Associations
=> New_List
(
2721 New_Reference_To
(DT_Ptr
, Loc
))));
2722 end Process_Tagged_Type_Declaration
;
2724 -- Start of processing for Build_Finalizer
2729 -- Do not perform this expansion in Alfa mode because it is not
2736 -- Step 1: Extract all lists which may contain controlled objects or
2737 -- library-level tagged types.
2739 if For_Package_Spec
then
2740 Decls
:= Visible_Declarations
(Specification
(N
));
2741 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2743 -- Retrieve the package spec id
2745 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2747 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2748 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2751 -- Accept statement, block, entry body, package body, protected body,
2752 -- subprogram body or task body.
2755 Decls
:= Declarations
(N
);
2756 HSS
:= Handled_Statement_Sequence
(N
);
2758 if Present
(HSS
) then
2759 if Present
(Statements
(HSS
)) then
2760 Stmts
:= Statements
(HSS
);
2763 if Present
(At_End_Proc
(HSS
)) then
2764 Prev_At_End
:= At_End_Proc
(HSS
);
2768 -- Retrieve the package spec id for package bodies
2770 if For_Package_Body
then
2771 Spec_Id
:= Corresponding_Spec
(N
);
2775 -- Do not process nested packages since those are handled by the
2776 -- enclosing scope's finalizer. Do not process non-expanded package
2777 -- instantiations since those will be re-analyzed and re-expanded.
2781 (not Is_Library_Level_Entity
(Spec_Id
)
2783 -- Nested packages are considered to be library level entities,
2784 -- but do not need to be processed separately. True library level
2785 -- packages have a scope value of 1.
2787 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2788 or else (Is_Generic_Instance
(Spec_Id
)
2789 and then Package_Instantiation
(Spec_Id
) /= N
))
2794 -- Step 2: Object [pre]processing
2798 -- Preprocess the visible declarations now in order to obtain the
2799 -- correct number of controlled object by the time the private
2800 -- declarations are processed.
2802 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2804 -- From all the possible contexts, only package specifications may
2805 -- have private declarations.
2807 if For_Package_Spec
then
2808 Process_Declarations
2809 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2812 -- The current context may lack controlled objects, but require some
2813 -- other form of completion (task termination for instance). In such
2814 -- cases, the finalizer must be created and carry the additional
2817 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2821 -- The preprocessing has determined that the context has controlled
2822 -- objects or library-level tagged types.
2824 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2826 -- Private declarations are processed first in order to preserve
2827 -- possible dependencies between public and private objects.
2829 if For_Package_Spec
then
2830 Process_Declarations
(Priv_Decls
);
2833 Process_Declarations
(Decls
);
2839 -- Preprocess both declarations and statements
2841 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2842 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
2844 -- At this point it is known that N has controlled objects. Ensure
2845 -- that N has a declarative list since the finalizer spec will be
2848 if Has_Ctrl_Objs
and then No
(Decls
) then
2849 Set_Declarations
(N
, New_List
);
2850 Decls
:= Declarations
(N
);
2851 Spec_Decls
:= Decls
;
2854 -- The current context may lack controlled objects, but require some
2855 -- other form of completion (task termination for instance). In such
2856 -- cases, the finalizer must be created and carry the additional
2859 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2863 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2864 Process_Declarations
(Stmts
);
2865 Process_Declarations
(Decls
);
2869 -- Step 3: Finalizer creation
2871 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2874 end Build_Finalizer
;
2876 --------------------------
2877 -- Build_Finalizer_Call --
2878 --------------------------
2880 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
2881 Is_Prot_Body
: constant Boolean :=
2882 Nkind
(N
) = N_Subprogram_Body
2883 and then Is_Protected_Subprogram_Body
(N
);
2884 -- Determine whether N denotes the protected version of a subprogram
2885 -- which belongs to a protected type.
2887 Loc
: constant Source_Ptr
:= Sloc
(N
);
2891 -- Do not perform this expansion in Alfa mode because we do not create
2892 -- finalizers in the first place.
2898 -- The At_End handler should have been assimilated by the finalizer
2900 HSS
:= Handled_Statement_Sequence
(N
);
2901 pragma Assert
(No
(At_End_Proc
(HSS
)));
2903 -- If the construct to be cleaned up is a protected subprogram body, the
2904 -- finalizer call needs to be associated with the block which wraps the
2905 -- unprotected version of the subprogram. The following illustrates this
2908 -- procedure Prot_SubpP is
2909 -- procedure finalizer is
2911 -- Service_Entries (Prot_Obj);
2918 -- Prot_SubpN (Prot_Obj);
2924 if Is_Prot_Body
then
2925 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
2927 -- An At_End handler and regular exception handlers cannot coexist in
2928 -- the same statement sequence. Wrap the original statements in a block.
2930 elsif Present
(Exception_Handlers
(HSS
)) then
2932 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
2937 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
2939 Set_Handled_Statement_Sequence
(N
,
2940 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
2942 HSS
:= Handled_Statement_Sequence
(N
);
2943 Set_End_Label
(HSS
, End_Lab
);
2947 Set_At_End_Proc
(HSS
, New_Reference_To
(Fin_Id
, Loc
));
2949 Analyze
(At_End_Proc
(HSS
));
2950 Expand_At_End_Handler
(HSS
, Empty
);
2951 end Build_Finalizer_Call
;
2953 ---------------------
2954 -- Build_Late_Proc --
2955 ---------------------
2957 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
2959 for Final_Prim
in Name_Of
'Range loop
2960 if Name_Of
(Final_Prim
) = Nam
then
2963 (Prim
=> Final_Prim
,
2965 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
2968 end Build_Late_Proc
;
2970 -------------------------------
2971 -- Build_Object_Declarations --
2972 -------------------------------
2974 procedure Build_Object_Declarations
2975 (Data
: out Finalization_Exception_Data
;
2978 For_Package
: Boolean := False)
2984 pragma Assert
(Decls
/= No_List
);
2986 -- Always set the proper location as it may be needed even when
2987 -- exception propagation is forbidden.
2991 if Restriction_Active
(No_Exception_Propagation
) then
2992 Data
.Abort_Id
:= Empty
;
2994 Data
.Raised_Id
:= Empty
;
2998 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
2999 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3000 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3002 -- In certain scenarios, finalization can be triggered by an abort. If
3003 -- the finalization itself fails and raises an exception, the resulting
3004 -- Program_Error must be supressed and replaced by an abort signal. In
3005 -- order to detect this scenario, save the state of entry into the
3006 -- finalization code.
3008 -- No need to do this for VM case, since VM version of Ada.Exceptions
3009 -- does not include routine Raise_From_Controlled_Operation which is the
3010 -- the sole user of flag Abort.
3012 -- This is not needed for library-level finalizers as they are called
3013 -- by the environment task and cannot be aborted.
3016 and then VM_Target
= No_VM
3017 and then not For_Package
3019 A_Expr
:= New_Reference_To
(RTE
(RE_Triggered_By_Abort
), Loc
);
3021 -- No abort, .NET/JVM or library-level finalizers
3024 A_Expr
:= New_Reference_To
(Standard_False
, Loc
);
3028 -- Abort_Id : constant Boolean := <A_Expr>;
3031 Make_Object_Declaration
(Loc
,
3032 Defining_Identifier
=> Data
.Abort_Id
,
3033 Constant_Present
=> True,
3034 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3035 Expression
=> A_Expr
));
3038 -- E_Id : Exception_Occurrence;
3041 Make_Object_Declaration
(Loc
,
3042 Defining_Identifier
=> Data
.E_Id
,
3043 Object_Definition
=>
3044 New_Reference_To
(RTE
(RE_Exception_Occurrence
), Loc
));
3045 Set_No_Initialization
(E_Decl
);
3047 Append_To
(Decls
, E_Decl
);
3050 -- Raised_Id : Boolean := False;
3053 Make_Object_Declaration
(Loc
,
3054 Defining_Identifier
=> Data
.Raised_Id
,
3055 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
3056 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
3057 end Build_Object_Declarations
;
3059 ---------------------------
3060 -- Build_Raise_Statement --
3061 ---------------------------
3063 function Build_Raise_Statement
3064 (Data
: Finalization_Exception_Data
) return Node_Id
3069 -- Standard run-time and .NET/JVM targets use the specialized routine
3070 -- Raise_From_Controlled_Operation.
3072 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
3074 Make_Procedure_Call_Statement
(Data
.Loc
,
3077 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3078 Parameter_Associations
=>
3079 New_List
(New_Reference_To
(Data
.E_Id
, Data
.Loc
)));
3081 -- Restricted run-time: exception messages are not supported and hence
3082 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3087 Make_Raise_Program_Error
(Data
.Loc
,
3088 Reason
=> PE_Finalize_Raised_Exception
);
3092 -- if Raised_Id and then not Abort_Id then
3093 -- Raise_From_Controlled_Operation (E_Id);
3095 -- raise Program_Error; -- restricted runtime
3099 Make_If_Statement
(Data
.Loc
,
3101 Make_And_Then
(Data
.Loc
,
3102 Left_Opnd
=> New_Reference_To
(Data
.Raised_Id
, Data
.Loc
),
3104 Make_Op_Not
(Data
.Loc
,
3105 Right_Opnd
=> New_Reference_To
(Data
.Abort_Id
, Data
.Loc
))),
3107 Then_Statements
=> New_List
(Stmt
));
3108 end Build_Raise_Statement
;
3110 -----------------------------
3111 -- Build_Record_Deep_Procs --
3112 -----------------------------
3114 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3118 (Prim
=> Initialize_Case
,
3120 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3122 if not Is_Immutably_Limited_Type
(Typ
) then
3125 (Prim
=> Adjust_Case
,
3127 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3130 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3131 -- suppressed since these routine will not be used.
3133 if not Restriction_Active
(No_Finalization
) then
3136 (Prim
=> Finalize_Case
,
3138 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3140 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3141 -- .NET do not support address arithmetic and unchecked conversions.
3143 if VM_Target
= No_VM
then
3146 (Prim
=> Address_Case
,
3148 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3151 end Build_Record_Deep_Procs
;
3157 function Cleanup_Array
3160 Typ
: Entity_Id
) return List_Id
3162 Loc
: constant Source_Ptr
:= Sloc
(N
);
3163 Index_List
: constant List_Id
:= New_List
;
3165 function Free_Component
return List_Id
;
3166 -- Generate the code to finalize the task or protected subcomponents
3167 -- of a single component of the array.
3169 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3170 -- Generate a loop over one dimension of the array
3172 --------------------
3173 -- Free_Component --
3174 --------------------
3176 function Free_Component
return List_Id
is
3177 Stmts
: List_Id
:= New_List
;
3179 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3182 -- Component type is known to contain tasks or protected objects
3185 Make_Indexed_Component
(Loc
,
3186 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3187 Expressions
=> Index_List
);
3189 Set_Etype
(Tsk
, C_Typ
);
3191 if Is_Task_Type
(C_Typ
) then
3192 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3194 elsif Is_Simple_Protected_Type
(C_Typ
) then
3195 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3197 elsif Is_Record_Type
(C_Typ
) then
3198 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3200 elsif Is_Array_Type
(C_Typ
) then
3201 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3207 ------------------------
3208 -- Free_One_Dimension --
3209 ------------------------
3211 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3215 if Dim
> Number_Dimensions
(Typ
) then
3216 return Free_Component
;
3218 -- Here we generate the required loop
3221 Index
:= Make_Temporary
(Loc
, 'J');
3222 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
3225 Make_Implicit_Loop_Statement
(N
,
3226 Identifier
=> Empty
,
3228 Make_Iteration_Scheme
(Loc
,
3229 Loop_Parameter_Specification
=>
3230 Make_Loop_Parameter_Specification
(Loc
,
3231 Defining_Identifier
=> Index
,
3232 Discrete_Subtype_Definition
=>
3233 Make_Attribute_Reference
(Loc
,
3234 Prefix
=> Duplicate_Subexpr
(Obj
),
3235 Attribute_Name
=> Name_Range
,
3236 Expressions
=> New_List
(
3237 Make_Integer_Literal
(Loc
, Dim
))))),
3238 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3240 end Free_One_Dimension
;
3242 -- Start of processing for Cleanup_Array
3245 return Free_One_Dimension
(1);
3248 --------------------
3249 -- Cleanup_Record --
3250 --------------------
3252 function Cleanup_Record
3255 Typ
: Entity_Id
) return List_Id
3257 Loc
: constant Source_Ptr
:= Sloc
(N
);
3260 Stmts
: constant List_Id
:= New_List
;
3261 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3264 if Has_Discriminants
(U_Typ
)
3265 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3267 Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3270 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3272 -- For now, do not attempt to free a component that may appear in a
3273 -- variant, and instead issue a warning. Doing this "properly" would
3274 -- require building a case statement and would be quite a mess. Note
3275 -- that the RM only requires that free "work" for the case of a task
3276 -- access value, so already we go way beyond this in that we deal
3277 -- with the array case and non-discriminated record cases.
3280 ("task/protected object in variant record will not be freed?", N
);
3281 return New_List
(Make_Null_Statement
(Loc
));
3284 Comp
:= First_Component
(Typ
);
3285 while Present
(Comp
) loop
3286 if Has_Task
(Etype
(Comp
))
3287 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3290 Make_Selected_Component
(Loc
,
3291 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3292 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3293 Set_Etype
(Tsk
, Etype
(Comp
));
3295 if Is_Task_Type
(Etype
(Comp
)) then
3296 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3298 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3299 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3301 elsif Is_Record_Type
(Etype
(Comp
)) then
3303 -- Recurse, by generating the prefix of the argument to
3304 -- the eventual cleanup call.
3306 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3308 elsif Is_Array_Type
(Etype
(Comp
)) then
3309 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3313 Next_Component
(Comp
);
3319 ------------------------------
3320 -- Cleanup_Protected_Object --
3321 ------------------------------
3323 function Cleanup_Protected_Object
3325 Ref
: Node_Id
) return Node_Id
3327 Loc
: constant Source_Ptr
:= Sloc
(N
);
3330 -- For restricted run-time libraries (Ravenscar), tasks are
3331 -- non-terminating, and protected objects can only appear at library
3332 -- level, so we do not want finalization of protected objects.
3334 if Restricted_Profile
then
3339 Make_Procedure_Call_Statement
(Loc
,
3341 New_Reference_To
(RTE
(RE_Finalize_Protection
), Loc
),
3342 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3344 end Cleanup_Protected_Object
;
3350 function Cleanup_Task
3352 Ref
: Node_Id
) return Node_Id
3354 Loc
: constant Source_Ptr
:= Sloc
(N
);
3357 -- For restricted run-time libraries (Ravenscar), tasks are
3358 -- non-terminating and they can only appear at library level, so we do
3359 -- not want finalization of task objects.
3361 if Restricted_Profile
then
3366 Make_Procedure_Call_Statement
(Loc
,
3368 New_Reference_To
(RTE
(RE_Free_Task
), Loc
),
3369 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3373 ------------------------------
3374 -- Check_Visibly_Controlled --
3375 ------------------------------
3377 procedure Check_Visibly_Controlled
3378 (Prim
: Final_Primitives
;
3380 E
: in out Entity_Id
;
3381 Cref
: in out Node_Id
)
3383 Parent_Type
: Entity_Id
;
3387 if Is_Derived_Type
(Typ
)
3388 and then Comes_From_Source
(E
)
3389 and then not Present
(Overridden_Operation
(E
))
3391 -- We know that the explicit operation on the type does not override
3392 -- the inherited operation of the parent, and that the derivation
3393 -- is from a private type that is not visibly controlled.
3395 Parent_Type
:= Etype
(Typ
);
3396 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3398 if Present
(Op
) then
3401 -- Wrap the object to be initialized into the proper
3402 -- unchecked conversion, to be compatible with the operation
3405 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3406 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3408 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3412 end Check_Visibly_Controlled
;
3414 -------------------------------
3415 -- CW_Or_Has_Controlled_Part --
3416 -------------------------------
3418 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3420 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3421 end CW_Or_Has_Controlled_Part
;
3427 function Convert_View
3430 Ind
: Pos
:= 1) return Node_Id
3432 Fent
: Entity_Id
:= First_Entity
(Proc
);
3437 for J
in 2 .. Ind
loop
3441 Ftyp
:= Etype
(Fent
);
3443 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3444 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3446 Atyp
:= Etype
(Arg
);
3449 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3450 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3453 and then Present
(Atyp
)
3454 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3455 and then Base_Type
(Underlying_Type
(Atyp
)) =
3456 Base_Type
(Underlying_Type
(Ftyp
))
3458 return Unchecked_Convert_To
(Ftyp
, Arg
);
3460 -- If the argument is already a conversion, as generated by
3461 -- Make_Init_Call, set the target type to the type of the formal
3462 -- directly, to avoid spurious typing problems.
3464 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3465 and then not Is_Class_Wide_Type
(Atyp
)
3467 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3468 Set_Etype
(Arg
, Ftyp
);
3476 ------------------------
3477 -- Enclosing_Function --
3478 ------------------------
3480 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3481 Func_Id
: Entity_Id
;
3485 while Present
(Func_Id
)
3486 and then Func_Id
/= Standard_Standard
3488 if Ekind
(Func_Id
) = E_Function
then
3492 Func_Id
:= Scope
(Func_Id
);
3496 end Enclosing_Function
;
3498 -------------------------------
3499 -- Establish_Transient_Scope --
3500 -------------------------------
3502 -- This procedure is called each time a transient block has to be inserted
3503 -- that is to say for each call to a function with unconstrained or tagged
3504 -- result. It creates a new scope on the stack scope in order to enclose
3505 -- all transient variables generated
3507 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3508 Loc
: constant Source_Ptr
:= Sloc
(N
);
3509 Wrap_Node
: Node_Id
;
3512 -- Do not create a transient scope if we are already inside one
3514 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3515 if Scope_Stack
.Table
(S
).Is_Transient
then
3517 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3522 -- If we have encountered Standard there are no enclosing
3523 -- transient scopes.
3525 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3530 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3532 -- Case of no wrap node, false alert, no transient scope needed
3534 if No
(Wrap_Node
) then
3537 -- If the node to wrap is an iteration_scheme, the expression is
3538 -- one of the bounds, and the expansion will make an explicit
3539 -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3540 -- so do not apply any transformations here.
3542 elsif Nkind
(Wrap_Node
) = N_Iteration_Scheme
then
3545 -- In formal verification mode, if the node to wrap is a pragma check,
3546 -- this node and enclosed expression are not expanded, so do not apply
3547 -- any transformations here.
3550 and then Nkind
(Wrap_Node
) = N_Pragma
3551 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3556 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3557 Set_Scope_Is_Transient
;
3560 Set_Uses_Sec_Stack
(Current_Scope
);
3561 Check_Restriction
(No_Secondary_Stack
, N
);
3564 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3565 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3567 if Debug_Flag_W
then
3568 Write_Str
(" <Transient>");
3572 end Establish_Transient_Scope
;
3574 ----------------------------
3575 -- Expand_Cleanup_Actions --
3576 ----------------------------
3578 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3579 Scop
: constant Entity_Id
:= Current_Scope
;
3581 Is_Asynchronous_Call
: constant Boolean :=
3582 Nkind
(N
) = N_Block_Statement
3583 and then Is_Asynchronous_Call_Block
(N
);
3584 Is_Master
: constant Boolean :=
3585 Nkind
(N
) /= N_Entry_Body
3586 and then Is_Task_Master
(N
);
3587 Is_Protected_Body
: constant Boolean :=
3588 Nkind
(N
) = N_Subprogram_Body
3589 and then Is_Protected_Subprogram_Body
(N
);
3590 Is_Task_Allocation
: constant Boolean :=
3591 Nkind
(N
) = N_Block_Statement
3592 and then Is_Task_Allocation_Block
(N
);
3593 Is_Task_Body
: constant Boolean :=
3594 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3595 Needs_Sec_Stack_Mark
: constant Boolean :=
3596 Uses_Sec_Stack
(Scop
)
3598 not Sec_Stack_Needed_For_Return
(Scop
)
3599 and then VM_Target
= No_VM
;
3601 Actions_Required
: constant Boolean :=
3602 Requires_Cleanup_Actions
(N
)
3603 or else Is_Asynchronous_Call
3605 or else Is_Protected_Body
3606 or else Is_Task_Allocation
3607 or else Is_Task_Body
3608 or else Needs_Sec_Stack_Mark
;
3610 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3613 procedure Wrap_HSS_In_Block
;
3614 -- Move HSS inside a new block along with the original exception
3615 -- handlers. Make the newly generated block the sole statement of HSS.
3617 -----------------------
3618 -- Wrap_HSS_In_Block --
3619 -----------------------
3621 procedure Wrap_HSS_In_Block
is
3626 -- Preserve end label to provide proper cross-reference information
3628 End_Lab
:= End_Label
(HSS
);
3630 Make_Block_Statement
(Loc
,
3631 Handled_Statement_Sequence
=> HSS
);
3633 Set_Handled_Statement_Sequence
(N
,
3634 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3635 HSS
:= Handled_Statement_Sequence
(N
);
3637 Set_First_Real_Statement
(HSS
, Block
);
3638 Set_End_Label
(HSS
, End_Lab
);
3640 -- Comment needed here, see RH for 1.306 ???
3642 if Nkind
(N
) = N_Subprogram_Body
then
3643 Set_Has_Nested_Block_With_Handler
(Scop
);
3645 end Wrap_HSS_In_Block
;
3647 -- Start of processing for Expand_Cleanup_Actions
3650 -- The current construct does not need any form of servicing
3652 if not Actions_Required
then
3655 -- If the current node is a rewritten task body and the descriptors have
3656 -- not been delayed (due to some nested instantiations), do not generate
3657 -- redundant cleanup actions.
3660 and then Nkind
(N
) = N_Subprogram_Body
3661 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3667 Decls
: List_Id
:= Declarations
(N
);
3669 Mark
: Entity_Id
:= Empty
;
3670 New_Decls
: List_Id
;
3674 -- If we are generating expanded code for debugging purposes, use the
3675 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3676 -- be updated subsequently to reference the proper line in .dg files.
3677 -- If we are not debugging generated code, use No_Location instead,
3678 -- so that no debug information is generated for the cleanup code.
3679 -- This makes the behavior of the NEXT command in GDB monotonic, and
3680 -- makes the placement of breakpoints more accurate.
3682 if Debug_Generated_Code
then
3688 -- Set polling off. The finalization and cleanup code is executed
3689 -- with aborts deferred.
3691 Old_Poll
:= Polling_Required
;
3692 Polling_Required
:= False;
3694 -- A task activation call has already been built for a task
3695 -- allocation block.
3697 if not Is_Task_Allocation
then
3698 Build_Task_Activation_Call
(N
);
3702 Establish_Task_Master
(N
);
3705 New_Decls
:= New_List
;
3707 -- If secondary stack is in use, generate:
3709 -- Mnn : constant Mark_Id := SS_Mark;
3711 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3712 -- secondary stack is never used on a VM.
3714 if Needs_Sec_Stack_Mark
then
3715 Mark
:= Make_Temporary
(Loc
, 'M');
3717 Append_To
(New_Decls
,
3718 Make_Object_Declaration
(Loc
,
3719 Defining_Identifier
=> Mark
,
3720 Object_Definition
=>
3721 New_Reference_To
(RTE
(RE_Mark_Id
), Loc
),
3723 Make_Function_Call
(Loc
,
3724 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
))));
3726 Set_Uses_Sec_Stack
(Scop
, False);
3729 -- If exception handlers are present, wrap the sequence of statements
3730 -- in a block since it is not possible to have exception handlers and
3731 -- an At_End handler in the same construct.
3733 if Present
(Exception_Handlers
(HSS
)) then
3736 -- Ensure that the First_Real_Statement field is set
3738 elsif No
(First_Real_Statement
(HSS
)) then
3739 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3742 -- Do not move the Activation_Chain declaration in the context of
3743 -- task allocation blocks. Task allocation blocks use _chain in their
3744 -- cleanup handlers and gigi complains if it is declared in the
3745 -- sequence of statements of the scope that declares the handler.
3747 if Is_Task_Allocation
then
3749 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3753 Decl
:= First
(Decls
);
3754 while Nkind
(Decl
) /= N_Object_Declaration
3755 or else Defining_Identifier
(Decl
) /= Chain
3759 -- A task allocation block should always include a _chain
3762 pragma Assert
(Present
(Decl
));
3766 Prepend_To
(New_Decls
, Decl
);
3770 -- Ensure the presence of a declaration list in order to successfully
3771 -- append all original statements to it.
3774 Set_Declarations
(N
, New_List
);
3775 Decls
:= Declarations
(N
);
3778 -- Move the declarations into the sequence of statements in order to
3779 -- have them protected by the At_End handler. It may seem weird to
3780 -- put declarations in the sequence of statement but in fact nothing
3781 -- forbids that at the tree level.
3783 Append_List_To
(Decls
, Statements
(HSS
));
3784 Set_Statements
(HSS
, Decls
);
3786 -- Reset the Sloc of the handled statement sequence to properly
3787 -- reflect the new initial "statement" in the sequence.
3789 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
3791 -- The declarations of finalizer spec and auxiliary variables replace
3792 -- the old declarations that have been moved inward.
3794 Set_Declarations
(N
, New_Decls
);
3795 Analyze_Declarations
(New_Decls
);
3797 -- Generate finalization calls for all controlled objects appearing
3798 -- in the statements of N. Add context specific cleanup for various
3803 Clean_Stmts
=> Build_Cleanup_Statements
(N
),
3805 Top_Decls
=> New_Decls
,
3806 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
3810 if Present
(Fin_Id
) then
3811 Build_Finalizer_Call
(N
, Fin_Id
);
3814 -- Restore saved polling mode
3816 Polling_Required
:= Old_Poll
;
3818 end Expand_Cleanup_Actions
;
3820 ---------------------------
3821 -- Expand_N_Package_Body --
3822 ---------------------------
3824 -- Add call to Activate_Tasks if body is an activator (actual processing
3825 -- is in chapter 9).
3827 -- Generate subprogram descriptor for elaboration routine
3829 -- Encode entity names in package body
3831 procedure Expand_N_Package_Body
(N
: Node_Id
) is
3832 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
3836 -- This is done only for non-generic packages
3838 if Ekind
(Spec_Ent
) = E_Package
then
3839 Push_Scope
(Corresponding_Spec
(N
));
3841 -- Build dispatch tables of library level tagged types
3843 if Tagged_Type_Expansion
3844 and then Is_Library_Level_Entity
(Spec_Ent
)
3846 Build_Static_Dispatch_Tables
(N
);
3849 Build_Task_Activation_Call
(N
);
3853 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
3854 Set_In_Package_Body
(Spec_Ent
, False);
3856 -- Set to encode entity names in package body before gigi is called
3858 Qualify_Entity_Names
(N
);
3860 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
3863 Clean_Stmts
=> No_List
,
3865 Top_Decls
=> No_List
,
3866 Defer_Abort
=> False,
3869 if Present
(Fin_Id
) then
3871 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
3874 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
3875 Body_Ent
:= Defining_Identifier
(Body_Ent
);
3878 Set_Finalizer
(Body_Ent
, Fin_Id
);
3882 end Expand_N_Package_Body
;
3884 ----------------------------------
3885 -- Expand_N_Package_Declaration --
3886 ----------------------------------
3888 -- Add call to Activate_Tasks if there are tasks declared and the package
3889 -- has no body. Note that in Ada 83 this may result in premature activation
3890 -- of some tasks, given that we cannot tell whether a body will eventually
3893 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
3894 Id
: constant Entity_Id
:= Defining_Entity
(N
);
3895 Spec
: constant Node_Id
:= Specification
(N
);
3899 No_Body
: Boolean := False;
3900 -- True in the case of a package declaration that is a compilation
3901 -- unit and for which no associated body will be compiled in this
3905 -- Case of a package declaration other than a compilation unit
3907 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3910 -- Case of a compilation unit that does not require a body
3912 elsif not Body_Required
(Parent
(N
))
3913 and then not Unit_Requires_Body
(Id
)
3917 -- Special case of generating calling stubs for a remote call interface
3918 -- package: even though the package declaration requires one, the body
3919 -- won't be processed in this compilation (so any stubs for RACWs
3920 -- declared in the package must be generated here, along with the spec).
3922 elsif Parent
(N
) = Cunit
(Main_Unit
)
3923 and then Is_Remote_Call_Interface
(Id
)
3924 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
3929 -- For a nested instance, delay processing until freeze point
3931 if Has_Delayed_Freeze
(Id
)
3932 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3937 -- For a package declaration that implies no associated body, generate
3938 -- task activation call and RACW supporting bodies now (since we won't
3939 -- have a specific separate compilation unit for that).
3944 if Has_RACW
(Id
) then
3946 -- Generate RACW subprogram bodies
3948 Decls
:= Private_Declarations
(Spec
);
3951 Decls
:= Visible_Declarations
(Spec
);
3956 Set_Visible_Declarations
(Spec
, Decls
);
3959 Append_RACW_Bodies
(Decls
, Id
);
3960 Analyze_List
(Decls
);
3963 if Present
(Activation_Chain_Entity
(N
)) then
3965 -- Generate task activation call as last step of elaboration
3967 Build_Task_Activation_Call
(N
);
3973 -- Build dispatch tables of library level tagged types
3975 if Tagged_Type_Expansion
3976 and then (Is_Compilation_Unit
(Id
)
3977 or else (Is_Generic_Instance
(Id
)
3978 and then Is_Library_Level_Entity
(Id
)))
3980 Build_Static_Dispatch_Tables
(N
);
3983 -- Note: it is not necessary to worry about generating a subprogram
3984 -- descriptor, since the only way to get exception handlers into a
3985 -- package spec is to include instantiations, and that would cause
3986 -- generation of subprogram descriptors to be delayed in any case.
3988 -- Set to encode entity names in package spec before gigi is called
3990 Qualify_Entity_Names
(N
);
3992 if Ekind
(Id
) /= E_Generic_Package
then
3995 Clean_Stmts
=> No_List
,
3997 Top_Decls
=> No_List
,
3998 Defer_Abort
=> False,
4001 Set_Finalizer
(Id
, Fin_Id
);
4003 end Expand_N_Package_Declaration
;
4005 -----------------------------
4006 -- Find_Node_To_Be_Wrapped --
4007 -----------------------------
4009 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4011 The_Parent
: Node_Id
;
4017 pragma Assert
(P
/= Empty
);
4018 The_Parent
:= Parent
(P
);
4020 case Nkind
(The_Parent
) is
4022 -- Simple statement can be wrapped
4027 -- Usually assignments are good candidate for wrapping except
4028 -- when they have been generated as part of a controlled aggregate
4029 -- where the wrapping should take place more globally.
4031 when N_Assignment_Statement
=>
4032 if No_Ctrl_Actions
(The_Parent
) then
4038 -- An entry call statement is a special case if it occurs in the
4039 -- context of a Timed_Entry_Call. In this case we wrap the entire
4040 -- timed entry call.
4042 when N_Entry_Call_Statement |
4043 N_Procedure_Call_Statement
=>
4044 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4045 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4047 N_Conditional_Entry_Call
)
4049 return Parent
(Parent
(The_Parent
));
4054 -- Object declarations are also a boundary for the transient scope
4055 -- even if they are not really wrapped. For further details, see
4056 -- Wrap_Transient_Declaration.
4058 when N_Object_Declaration |
4059 N_Object_Renaming_Declaration |
4060 N_Subtype_Declaration
=>
4063 -- The expression itself is to be wrapped if its parent is a
4064 -- compound statement or any other statement where the expression
4065 -- is known to be scalar
4067 when N_Accept_Alternative |
4068 N_Attribute_Definition_Clause |
4071 N_Delay_Alternative |
4072 N_Delay_Until_Statement |
4073 N_Delay_Relative_Statement |
4074 N_Discriminant_Association |
4076 N_Entry_Body_Formal_Part |
4079 N_Iteration_Scheme |
4080 N_Terminate_Alternative
=>
4083 when N_Attribute_Reference
=>
4085 if Is_Procedure_Attribute_Name
4086 (Attribute_Name
(The_Parent
))
4091 -- A raise statement can be wrapped. This will arise when the
4092 -- expression in a raise_with_expression uses the secondary
4093 -- stack, for example.
4095 when N_Raise_Statement
=>
4098 -- If the expression is within the iteration scheme of a loop,
4099 -- we must create a declaration for it, followed by an assignment
4100 -- in order to have a usable statement to wrap.
4102 when N_Loop_Parameter_Specification
=>
4103 return Parent
(The_Parent
);
4105 -- The following nodes contains "dummy calls" which don't need to
4108 when N_Parameter_Specification |
4109 N_Discriminant_Specification |
4110 N_Component_Declaration
=>
4113 -- The return statement is not to be wrapped when the function
4114 -- itself needs wrapping at the outer-level
4116 when N_Simple_Return_Statement
=>
4118 Applies_To
: constant Entity_Id
:=
4120 (Return_Statement_Entity
(The_Parent
));
4121 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4123 if Requires_Transient_Scope
(Return_Type
) then
4130 -- If we leave a scope without having been able to find a node to
4131 -- wrap, something is going wrong but this can happen in error
4132 -- situation that are not detected yet (such as a dynamic string
4133 -- in a pragma export)
4135 when N_Subprogram_Body |
4136 N_Package_Declaration |
4138 N_Block_Statement
=>
4141 -- Otherwise continue the search
4147 end Find_Node_To_Be_Wrapped
;
4149 -------------------------------------
4150 -- Get_Global_Pool_For_Access_Type --
4151 -------------------------------------
4153 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4155 -- Access types whose size is smaller than System.Address size can exist
4156 -- only on VMS. We can't use the usual global pool which returns an
4157 -- object of type Address as truncation will make it invalid. To handle
4158 -- this case, VMS has a dedicated global pool that returns addresses
4159 -- that fit into 32 bit accesses.
4161 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4162 return RTE
(RE_Global_Pool_32_Object
);
4164 return RTE
(RE_Global_Pool_Object
);
4166 end Get_Global_Pool_For_Access_Type
;
4168 ----------------------------------
4169 -- Has_New_Controlled_Component --
4170 ----------------------------------
4172 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4176 if not Is_Tagged_Type
(E
) then
4177 return Has_Controlled_Component
(E
);
4178 elsif not Is_Derived_Type
(E
) then
4179 return Has_Controlled_Component
(E
);
4182 Comp
:= First_Component
(E
);
4183 while Present
(Comp
) loop
4184 if Chars
(Comp
) = Name_uParent
then
4187 elsif Scope
(Original_Record_Component
(Comp
)) = E
4188 and then Needs_Finalization
(Etype
(Comp
))
4193 Next_Component
(Comp
);
4197 end Has_New_Controlled_Component
;
4199 ---------------------------------
4200 -- Has_Simple_Protected_Object --
4201 ---------------------------------
4203 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4205 if Has_Task
(T
) then
4208 elsif Is_Simple_Protected_Type
(T
) then
4211 elsif Is_Array_Type
(T
) then
4212 return Has_Simple_Protected_Object
(Component_Type
(T
));
4214 elsif Is_Record_Type
(T
) then
4219 Comp
:= First_Component
(T
);
4220 while Present
(Comp
) loop
4221 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4225 Next_Component
(Comp
);
4234 end Has_Simple_Protected_Object
;
4236 ------------------------------------
4237 -- Insert_Actions_In_Scope_Around --
4238 ------------------------------------
4240 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
) is
4241 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
4242 After
: List_Id
renames SE
.Actions_To_Be_Wrapped_After
;
4243 Before
: List_Id
renames SE
.Actions_To_Be_Wrapped_Before
;
4245 procedure Process_Transient_Objects
4246 (First_Object
: Node_Id
;
4247 Last_Object
: Node_Id
;
4248 Related_Node
: Node_Id
);
4249 -- First_Object and Last_Object define a list which contains potential
4250 -- controlled transient objects. Finalization flags are inserted before
4251 -- First_Object and finalization calls are inserted after Last_Object.
4252 -- Related_Node is the node for which transient objects have been
4255 -------------------------------
4256 -- Process_Transient_Objects --
4257 -------------------------------
4259 procedure Process_Transient_Objects
4260 (First_Object
: Node_Id
;
4261 Last_Object
: Node_Id
;
4262 Related_Node
: Node_Id
)
4264 Requires_Hooking
: constant Boolean :=
4265 Nkind_In
(N
, N_Function_Call
,
4266 N_Procedure_Call_Statement
);
4268 Built
: Boolean := False;
4269 Desig_Typ
: Entity_Id
;
4270 Fin_Block
: Node_Id
;
4271 Fin_Data
: Finalization_Exception_Data
;
4272 Fin_Decls
: List_Id
;
4273 Last_Fin
: Node_Id
:= Empty
;
4277 Obj_Typ
: Entity_Id
;
4280 Temp_Id
: Entity_Id
;
4283 -- Examine all objects in the list First_Object .. Last_Object
4285 Stmt
:= First_Object
;
4286 while Present
(Stmt
) loop
4287 if Nkind
(Stmt
) = N_Object_Declaration
4288 and then Analyzed
(Stmt
)
4289 and then Is_Finalizable_Transient
(Stmt
, N
)
4291 -- Do not process the node to be wrapped since it will be
4292 -- handled by the enclosing finalizer.
4294 and then Stmt
/= Related_Node
4297 Obj_Id
:= Defining_Identifier
(Stmt
);
4298 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4299 Desig_Typ
:= Obj_Typ
;
4301 Set_Is_Processed_Transient
(Obj_Id
);
4303 -- Handle access types
4305 if Is_Access_Type
(Desig_Typ
) then
4306 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4309 -- Create the necessary entities and declarations the first
4313 Fin_Decls
:= New_List
;
4315 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4316 Insert_List_Before_And_Analyze
(First_Object
, Fin_Decls
);
4321 -- Transient variables associated with subprogram calls need
4322 -- extra processing. These variables are usually created right
4323 -- before the call and finalized immediately after the call.
4324 -- If an exception occurs during the call, the clean up code
4325 -- is skipped due to the sudden change in control and the
4326 -- transient is never finalized.
4328 -- To handle this case, such variables are "exported" to the
4329 -- enclosing sequence of statements where their corresponding
4330 -- "hooks" are picked up by the finalization machinery.
4332 if Requires_Hooking
then
4338 -- Step 1: Create an access type which provides a
4339 -- reference to the transient object. Generate:
4341 -- Ann : access [all] <Desig_Typ>;
4343 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4345 Insert_Action
(Stmt
,
4346 Make_Full_Type_Declaration
(Loc
,
4347 Defining_Identifier
=> Ptr_Id
,
4349 Make_Access_To_Object_Definition
(Loc
,
4351 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4352 Subtype_Indication
=>
4353 New_Reference_To
(Desig_Typ
, Loc
))));
4355 -- Step 2: Create a temporary which acts as a hook to
4356 -- the transient object. Generate:
4358 -- Temp : Ptr_Id := null;
4360 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4362 Insert_Action
(Stmt
,
4363 Make_Object_Declaration
(Loc
,
4364 Defining_Identifier
=> Temp_Id
,
4365 Object_Definition
=>
4366 New_Reference_To
(Ptr_Id
, Loc
)));
4368 -- Mark the temporary as a transient hook. This signals
4369 -- the machinery in Build_Finalizer to recognize this
4372 Set_Return_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4374 -- Step 3: Hook the transient object to the temporary
4376 if Is_Access_Type
(Obj_Typ
) then
4378 Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
4381 Make_Attribute_Reference
(Loc
,
4382 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
4383 Attribute_Name
=> Name_Unrestricted_Access
);
4387 -- Temp := Ptr_Id (Obj_Id);
4389 -- Temp := Obj_Id'Unrestricted_Access;
4391 Insert_After_And_Analyze
(Stmt
,
4392 Make_Assignment_Statement
(Loc
,
4393 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4394 Expression
=> Expr
));
4400 -- The transient object is about to be finalized by the clean
4401 -- up code following the subprogram call. In order to avoid
4402 -- double finalization, clear the hook.
4407 if Requires_Hooking
then
4409 Make_Assignment_Statement
(Loc
,
4410 Name
=> New_Reference_To
(Temp_Id
, Loc
),
4411 Expression
=> Make_Null
(Loc
)));
4415 -- [Deep_]Finalize (Obj_Ref);
4417 Obj_Ref
:= New_Reference_To
(Obj_Id
, Loc
);
4419 if Is_Access_Type
(Obj_Typ
) then
4420 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4424 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4429 -- [Deep_]Finalize (Obj_Ref);
4433 -- if not Raised then
4436 -- (Enn, Get_Current_Excep.all.all);
4441 Make_Block_Statement
(Loc
,
4442 Handled_Statement_Sequence
=>
4443 Make_Handled_Sequence_Of_Statements
(Loc
,
4444 Statements
=> Stmts
,
4445 Exception_Handlers
=> New_List
(
4446 Build_Exception_Handler
(Fin_Data
))));
4448 Insert_After_And_Analyze
(Last_Object
, Fin_Block
);
4450 -- The raise statement must be inserted after all the
4451 -- finalization blocks.
4453 if No
(Last_Fin
) then
4454 Last_Fin
:= Fin_Block
;
4457 -- When the associated node is an array object, the expander may
4458 -- sometimes generate a loop and create transient objects inside
4461 elsif Nkind
(Related_Node
) = N_Object_Declaration
4462 and then Is_Array_Type
4464 (Etype
(Defining_Identifier
(Related_Node
))))
4465 and then Nkind
(Stmt
) = N_Loop_Statement
4468 Block_HSS
: Node_Id
:= First
(Statements
(Stmt
));
4471 -- The loop statements may have been wrapped in a block by
4472 -- Process_Statements_For_Controlled_Objects, inspect the
4473 -- handled sequence of statements.
4475 if Nkind
(Block_HSS
) = N_Block_Statement
4476 and then No
(Next
(Block_HSS
))
4478 Block_HSS
:= Handled_Statement_Sequence
(Block_HSS
);
4480 Process_Transient_Objects
4481 (First_Object
=> First
(Statements
(Block_HSS
)),
4482 Last_Object
=> Last
(Statements
(Block_HSS
)),
4483 Related_Node
=> Related_Node
);
4485 -- Inspect the statements of the loop
4488 Process_Transient_Objects
4489 (First_Object
=> First
(Statements
(Stmt
)),
4490 Last_Object
=> Last
(Statements
(Stmt
)),
4491 Related_Node
=> Related_Node
);
4495 -- Terminate the scan after the last object has been processed
4497 elsif Stmt
= Last_Object
then
4505 -- if Raised and then not Abort then
4506 -- Raise_From_Controlled_Operation (E);
4510 and then Present
(Last_Fin
)
4512 Insert_After_And_Analyze
(Last_Fin
,
4513 Build_Raise_Statement
(Fin_Data
));
4515 end Process_Transient_Objects
;
4517 -- Start of processing for Insert_Actions_In_Scope_Around
4520 if No
(Before
) and then No
(After
) then
4525 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4526 First_Obj
: Node_Id
;
4531 -- If the node to be wrapped is the trigger of an asynchronous
4532 -- select, it is not part of a statement list. The actions must be
4533 -- inserted before the select itself, which is part of some list of
4534 -- statements. Note that the triggering alternative includes the
4535 -- triggering statement and an optional statement list. If the node
4536 -- to be wrapped is part of that list, the normal insertion applies.
4538 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4539 and then not Is_List_Member
(Node_To_Wrap
)
4541 Target
:= Parent
(Parent
(Node_To_Wrap
));
4546 First_Obj
:= Target
;
4549 -- Add all actions associated with a transient scope into the main
4550 -- tree. There are several scenarios here:
4552 -- +--- Before ----+ +----- After ---+
4553 -- 1) First_Obj ....... Target ........ Last_Obj
4555 -- 2) First_Obj ....... Target
4557 -- 3) Target ........ Last_Obj
4559 if Present
(Before
) then
4561 -- Flag declarations are inserted before the first object
4563 First_Obj
:= First
(Before
);
4565 Insert_List_Before
(Target
, Before
);
4568 if Present
(After
) then
4570 -- Finalization calls are inserted after the last object
4572 Last_Obj
:= Last
(After
);
4574 Insert_List_After
(Target
, After
);
4577 -- Check for transient controlled objects associated with Target and
4578 -- generate the appropriate finalization actions for them.
4580 Process_Transient_Objects
4581 (First_Object
=> First_Obj
,
4582 Last_Object
=> Last_Obj
,
4583 Related_Node
=> Target
);
4585 -- Reset the action lists
4587 if Present
(Before
) then
4591 if Present
(After
) then
4595 end Insert_Actions_In_Scope_Around
;
4597 ------------------------------
4598 -- Is_Simple_Protected_Type --
4599 ------------------------------
4601 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4604 Is_Protected_Type
(T
)
4605 and then not Has_Entries
(T
)
4606 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4607 end Is_Simple_Protected_Type
;
4609 -----------------------
4610 -- Make_Adjust_Call --
4611 -----------------------
4613 function Make_Adjust_Call
4616 For_Parent
: Boolean := False) return Node_Id
4618 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4619 Adj_Id
: Entity_Id
:= Empty
;
4620 Ref
: Node_Id
:= Obj_Ref
;
4624 -- Recover the proper type which contains Deep_Adjust
4626 if Is_Class_Wide_Type
(Typ
) then
4627 Utyp
:= Root_Type
(Typ
);
4632 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4633 Set_Assignment_OK
(Ref
);
4635 -- Deal with non-tagged derivation of private views
4637 if Is_Untagged_Derivation
(Typ
) then
4638 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4639 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4640 Set_Assignment_OK
(Ref
);
4643 -- When dealing with the completion of a private type, use the base
4646 if Utyp
/= Base_Type
(Utyp
) then
4647 pragma Assert
(Is_Private_Type
(Typ
));
4649 Utyp
:= Base_Type
(Utyp
);
4650 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4653 -- Select the appropriate version of adjust
4656 if Has_Controlled_Component
(Utyp
) then
4657 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4660 -- Class-wide types, interfaces and types with controlled components
4662 elsif Is_Class_Wide_Type
(Typ
)
4663 or else Is_Interface
(Typ
)
4664 or else Has_Controlled_Component
(Utyp
)
4666 if Is_Tagged_Type
(Utyp
) then
4667 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4669 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
4672 -- Derivations from [Limited_]Controlled
4674 elsif Is_Controlled
(Utyp
) then
4675 if Has_Controlled_Component
(Utyp
) then
4676 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4678 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
4683 elsif Is_Tagged_Type
(Utyp
) then
4684 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4687 raise Program_Error
;
4690 if Present
(Adj_Id
) then
4692 -- If the object is unanalyzed, set its expected type for use in
4693 -- Convert_View in case an additional conversion is needed.
4696 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
4698 Set_Etype
(Ref
, Typ
);
4701 -- The object reference may need another conversion depending on the
4702 -- type of the formal and that of the actual.
4704 if not Is_Class_Wide_Type
(Typ
) then
4705 Ref
:= Convert_View
(Adj_Id
, Ref
);
4708 return Make_Call
(Loc
, Adj_Id
, New_Copy_Tree
(Ref
), For_Parent
);
4712 end Make_Adjust_Call
;
4714 ----------------------
4715 -- Make_Attach_Call --
4716 ----------------------
4718 function Make_Attach_Call
4720 Ptr_Typ
: Entity_Id
) return Node_Id
4722 pragma Assert
(VM_Target
/= No_VM
);
4724 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4727 Make_Procedure_Call_Statement
(Loc
,
4729 New_Reference_To
(RTE
(RE_Attach
), Loc
),
4730 Parameter_Associations
=> New_List
(
4731 New_Reference_To
(Finalization_Master
(Ptr_Typ
), Loc
),
4732 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4733 end Make_Attach_Call
;
4735 ----------------------
4736 -- Make_Detach_Call --
4737 ----------------------
4739 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
4740 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4744 Make_Procedure_Call_Statement
(Loc
,
4746 New_Reference_To
(RTE
(RE_Detach
), Loc
),
4747 Parameter_Associations
=> New_List
(
4748 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
4749 end Make_Detach_Call
;
4757 Proc_Id
: Entity_Id
;
4759 For_Parent
: Boolean := False) return Node_Id
4761 Params
: constant List_Id
:= New_List
(Param
);
4764 -- When creating a call to Deep_Finalize for a _parent field of a
4765 -- derived type, disable the invocation of the nested Finalize by giving
4766 -- the corresponding flag a False value.
4769 Append_To
(Params
, New_Reference_To
(Standard_False
, Loc
));
4773 Make_Procedure_Call_Statement
(Loc
,
4774 Name
=> New_Reference_To
(Proc_Id
, Loc
),
4775 Parameter_Associations
=> Params
);
4778 --------------------------
4779 -- Make_Deep_Array_Body --
4780 --------------------------
4782 function Make_Deep_Array_Body
4783 (Prim
: Final_Primitives
;
4784 Typ
: Entity_Id
) return List_Id
4786 function Build_Adjust_Or_Finalize_Statements
4787 (Typ
: Entity_Id
) return List_Id
;
4788 -- Create the statements necessary to adjust or finalize an array of
4789 -- controlled elements. Generate:
4792 -- Abort : constant Boolean := Triggered_By_Abort;
4794 -- Abort : constant Boolean := False; -- no abort
4796 -- E : Exception_Occurrence;
4797 -- Raised : Boolean := False;
4800 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4801 -- ^-- in the finalization case
4803 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4805 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4809 -- if not Raised then
4811 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4818 -- if Raised and then not Abort then
4819 -- Raise_From_Controlled_Operation (E);
4823 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
4824 -- Create the statements necessary to initialize an array of controlled
4825 -- elements. Include a mechanism to carry out partial finalization if an
4826 -- exception occurs. Generate:
4829 -- Counter : Integer := 0;
4832 -- for J1 in V'Range (1) loop
4834 -- for JN in V'Range (N) loop
4836 -- [Deep_]Initialize (V (J1, ..., JN));
4838 -- Counter := Counter + 1;
4843 -- Abort : constant Boolean := Triggered_By_Abort;
4845 -- Abort : constant Boolean := False; -- no abort
4846 -- E : Exception_Occurence;
4847 -- Raised : Boolean := False;
4854 -- V'Length (N) - Counter;
4856 -- for F1 in reverse V'Range (1) loop
4858 -- for FN in reverse V'Range (N) loop
4859 -- if Counter > 0 then
4860 -- Counter := Counter - 1;
4863 -- [Deep_]Finalize (V (F1, ..., FN));
4867 -- if not Raised then
4869 -- Save_Occurrence (E,
4870 -- Get_Current_Excep.all.all);
4879 -- if Raised and then not Abort then
4880 -- Raise_From_Controlled_Operation (E);
4889 function New_References_To
4891 Loc
: Source_Ptr
) return List_Id
;
4892 -- Given a list of defining identifiers, return a list of references to
4893 -- the original identifiers, in the same order as they appear.
4895 -----------------------------------------
4896 -- Build_Adjust_Or_Finalize_Statements --
4897 -----------------------------------------
4899 function Build_Adjust_Or_Finalize_Statements
4900 (Typ
: Entity_Id
) return List_Id
4902 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4903 Index_List
: constant List_Id
:= New_List
;
4904 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4905 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
4906 Finalizer_Decls
: List_Id
:= No_List
;
4907 Finalizer_Data
: Finalization_Exception_Data
;
4910 Core_Loop
: Node_Id
;
4913 Loop_Id
: Entity_Id
;
4916 Exceptions_OK
: constant Boolean :=
4917 not Restriction_Active
(No_Exception_Propagation
);
4919 procedure Build_Indices
;
4920 -- Generate the indices used in the dimension loops
4926 procedure Build_Indices
is
4928 -- Generate the following identifiers:
4929 -- Jnn - for initialization
4931 for Dim
in 1 .. Num_Dims
loop
4932 Append_To
(Index_List
,
4933 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
4937 -- Start of processing for Build_Adjust_Or_Finalize_Statements
4940 Finalizer_Decls
:= New_List
;
4943 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
4946 Make_Indexed_Component
(Loc
,
4947 Prefix
=> Make_Identifier
(Loc
, Name_V
),
4948 Expressions
=> New_References_To
(Index_List
, Loc
));
4949 Set_Etype
(Comp_Ref
, Comp_Typ
);
4952 -- [Deep_]Adjust (V (J1, ..., JN))
4954 if Prim
= Adjust_Case
then
4955 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
4958 -- [Deep_]Finalize (V (J1, ..., JN))
4960 else pragma Assert
(Prim
= Finalize_Case
);
4961 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
4964 -- Generate the block which houses the adjust or finalize call:
4966 -- <adjust or finalize call>; -- No_Exception_Propagation
4968 -- begin -- Exception handlers allowed
4969 -- <adjust or finalize call>
4973 -- if not Raised then
4975 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4979 if Exceptions_OK
then
4981 Make_Block_Statement
(Loc
,
4982 Handled_Statement_Sequence
=>
4983 Make_Handled_Sequence_Of_Statements
(Loc
,
4984 Statements
=> New_List
(Call
),
4985 Exception_Handlers
=> New_List
(
4986 Build_Exception_Handler
(Finalizer_Data
))));
4991 -- Generate the dimension loops starting from the innermost one
4993 -- for Jnn in [reverse] V'Range (Dim) loop
4997 J
:= Last
(Index_List
);
4999 while Present
(J
) and then Dim
> 0 loop
5005 Make_Loop_Statement
(Loc
,
5007 Make_Iteration_Scheme
(Loc
,
5008 Loop_Parameter_Specification
=>
5009 Make_Loop_Parameter_Specification
(Loc
,
5010 Defining_Identifier
=> Loop_Id
,
5011 Discrete_Subtype_Definition
=>
5012 Make_Attribute_Reference
(Loc
,
5013 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5014 Attribute_Name
=> Name_Range
,
5015 Expressions
=> New_List
(
5016 Make_Integer_Literal
(Loc
, Dim
))),
5018 Reverse_Present
=> Prim
= Finalize_Case
)),
5020 Statements
=> New_List
(Core_Loop
),
5021 End_Label
=> Empty
);
5026 -- Generate the block which contains the core loop, the declarations
5027 -- of the abort flag, the exception occurrence, the raised flag and
5028 -- the conditional raise:
5031 -- Abort : constant Boolean := Triggered_By_Abort;
5033 -- Abort : constant Boolean := False; -- no abort
5035 -- E : Exception_Occurrence;
5036 -- Raised : Boolean := False;
5041 -- if Raised and then not Abort then -- Expection handlers OK
5042 -- Raise_From_Controlled_Operation (E);
5046 Stmts
:= New_List
(Core_Loop
);
5048 if Exceptions_OK
then
5050 Build_Raise_Statement
(Finalizer_Data
));
5055 Make_Block_Statement
(Loc
,
5058 Handled_Statement_Sequence
=>
5059 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5060 end Build_Adjust_Or_Finalize_Statements
;
5062 ---------------------------------
5063 -- Build_Initialize_Statements --
5064 ---------------------------------
5066 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5067 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5068 Final_List
: constant List_Id
:= New_List
;
5069 Index_List
: constant List_Id
:= New_List
;
5070 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5071 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5072 Counter_Id
: Entity_Id
;
5076 Final_Block
: Node_Id
;
5077 Final_Loop
: Node_Id
;
5078 Finalizer_Data
: Finalization_Exception_Data
;
5079 Finalizer_Decls
: List_Id
:= No_List
;
5080 Init_Loop
: Node_Id
;
5085 Exceptions_OK
: constant Boolean :=
5086 not Restriction_Active
(No_Exception_Propagation
);
5088 function Build_Counter_Assignment
return Node_Id
;
5089 -- Generate the following assignment:
5090 -- Counter := V'Length (1) *
5092 -- V'Length (N) - Counter;
5094 function Build_Finalization_Call
return Node_Id
;
5095 -- Generate a deep finalization call for an array element
5097 procedure Build_Indices
;
5098 -- Generate the initialization and finalization indices used in the
5101 function Build_Initialization_Call
return Node_Id
;
5102 -- Generate a deep initialization call for an array element
5104 ------------------------------
5105 -- Build_Counter_Assignment --
5106 ------------------------------
5108 function Build_Counter_Assignment
return Node_Id
is
5113 -- Start from the first dimension and generate:
5118 Make_Attribute_Reference
(Loc
,
5119 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5120 Attribute_Name
=> Name_Length
,
5121 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5123 -- Process the rest of the dimensions, generate:
5124 -- Expr * V'Length (N)
5127 while Dim
<= Num_Dims
loop
5129 Make_Op_Multiply
(Loc
,
5132 Make_Attribute_Reference
(Loc
,
5133 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5134 Attribute_Name
=> Name_Length
,
5135 Expressions
=> New_List
(
5136 Make_Integer_Literal
(Loc
, Dim
))));
5142 -- Counter := Expr - Counter;
5145 Make_Assignment_Statement
(Loc
,
5146 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5148 Make_Op_Subtract
(Loc
,
5150 Right_Opnd
=> New_Reference_To
(Counter_Id
, Loc
)));
5151 end Build_Counter_Assignment
;
5153 -----------------------------
5154 -- Build_Finalization_Call --
5155 -----------------------------
5157 function Build_Finalization_Call
return Node_Id
is
5158 Comp_Ref
: constant Node_Id
:=
5159 Make_Indexed_Component
(Loc
,
5160 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5161 Expressions
=> New_References_To
(Final_List
, Loc
));
5164 Set_Etype
(Comp_Ref
, Comp_Typ
);
5167 -- [Deep_]Finalize (V);
5169 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5170 end Build_Finalization_Call
;
5176 procedure Build_Indices
is
5178 -- Generate the following identifiers:
5179 -- Jnn - for initialization
5180 -- Fnn - for finalization
5182 for Dim
in 1 .. Num_Dims
loop
5183 Append_To
(Index_List
,
5184 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5186 Append_To
(Final_List
,
5187 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5191 -------------------------------
5192 -- Build_Initialization_Call --
5193 -------------------------------
5195 function Build_Initialization_Call
return Node_Id
is
5196 Comp_Ref
: constant Node_Id
:=
5197 Make_Indexed_Component
(Loc
,
5198 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5199 Expressions
=> New_References_To
(Index_List
, Loc
));
5202 Set_Etype
(Comp_Ref
, Comp_Typ
);
5205 -- [Deep_]Initialize (V (J1, ..., JN));
5207 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5208 end Build_Initialization_Call
;
5210 -- Start of processing for Build_Initialize_Statements
5213 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5214 Finalizer_Decls
:= New_List
;
5217 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5219 -- Generate the block which houses the finalization call, the index
5220 -- guard and the handler which triggers Program_Error later on.
5222 -- if Counter > 0 then
5223 -- Counter := Counter - 1;
5225 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5227 -- begin -- Exceptions allowed
5228 -- [Deep_]Finalize (V (F1, ..., FN));
5231 -- if not Raised then
5233 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5238 if Exceptions_OK
then
5240 Make_Block_Statement
(Loc
,
5241 Handled_Statement_Sequence
=>
5242 Make_Handled_Sequence_Of_Statements
(Loc
,
5243 Statements
=> New_List
(Build_Finalization_Call
),
5244 Exception_Handlers
=> New_List
(
5245 Build_Exception_Handler
(Finalizer_Data
))));
5247 Fin_Stmt
:= Build_Finalization_Call
;
5250 -- This is the core of the loop, the dimension iterators are added
5251 -- one by one in reverse.
5254 Make_If_Statement
(Loc
,
5257 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5258 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5260 Then_Statements
=> New_List
(
5261 Make_Assignment_Statement
(Loc
,
5262 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5264 Make_Op_Subtract
(Loc
,
5265 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5266 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5268 Else_Statements
=> New_List
(Fin_Stmt
));
5270 -- Generate all finalization loops starting from the innermost
5273 -- for Fnn in reverse V'Range (Dim) loop
5277 F
:= Last
(Final_List
);
5279 while Present
(F
) and then Dim
> 0 loop
5285 Make_Loop_Statement
(Loc
,
5287 Make_Iteration_Scheme
(Loc
,
5288 Loop_Parameter_Specification
=>
5289 Make_Loop_Parameter_Specification
(Loc
,
5290 Defining_Identifier
=> Loop_Id
,
5291 Discrete_Subtype_Definition
=>
5292 Make_Attribute_Reference
(Loc
,
5293 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5294 Attribute_Name
=> Name_Range
,
5295 Expressions
=> New_List
(
5296 Make_Integer_Literal
(Loc
, Dim
))),
5298 Reverse_Present
=> True)),
5300 Statements
=> New_List
(Final_Loop
),
5301 End_Label
=> Empty
);
5306 -- Generate the block which contains the finalization loops, the
5307 -- declarations of the abort flag, the exception occurrence, the
5308 -- raised flag and the conditional raise.
5311 -- Abort : constant Boolean := Triggered_By_Abort;
5313 -- Abort : constant Boolean := False; -- no abort
5315 -- E : Exception_Occurrence;
5316 -- Raised : Boolean := False;
5322 -- V'Length (N) - Counter;
5326 -- if Raised and then not Abort then -- Exception handlers OK
5327 -- Raise_From_Controlled_Operation (E);
5330 -- raise; -- Exception handlers OK
5333 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5335 if Exceptions_OK
then
5337 Build_Raise_Statement
(Finalizer_Data
));
5338 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5342 Make_Block_Statement
(Loc
,
5345 Handled_Statement_Sequence
=>
5346 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5348 -- Generate the block which contains the initialization call and
5349 -- the partial finalization code.
5352 -- [Deep_]Initialize (V (J1, ..., JN));
5354 -- Counter := Counter + 1;
5358 -- <finalization code>
5362 Make_Block_Statement
(Loc
,
5363 Handled_Statement_Sequence
=>
5364 Make_Handled_Sequence_Of_Statements
(Loc
,
5365 Statements
=> New_List
(Build_Initialization_Call
),
5366 Exception_Handlers
=> New_List
(
5367 Make_Exception_Handler
(Loc
,
5368 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5369 Statements
=> New_List
(Final_Block
)))));
5371 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5372 Make_Assignment_Statement
(Loc
,
5373 Name
=> New_Reference_To
(Counter_Id
, Loc
),
5376 Left_Opnd
=> New_Reference_To
(Counter_Id
, Loc
),
5377 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5379 -- Generate all initialization loops starting from the innermost
5382 -- for Jnn in V'Range (Dim) loop
5386 J
:= Last
(Index_List
);
5388 while Present
(J
) and then Dim
> 0 loop
5394 Make_Loop_Statement
(Loc
,
5396 Make_Iteration_Scheme
(Loc
,
5397 Loop_Parameter_Specification
=>
5398 Make_Loop_Parameter_Specification
(Loc
,
5399 Defining_Identifier
=> Loop_Id
,
5400 Discrete_Subtype_Definition
=>
5401 Make_Attribute_Reference
(Loc
,
5402 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5403 Attribute_Name
=> Name_Range
,
5404 Expressions
=> New_List
(
5405 Make_Integer_Literal
(Loc
, Dim
))))),
5407 Statements
=> New_List
(Init_Loop
),
5408 End_Label
=> Empty
);
5413 -- Generate the block which contains the counter variable and the
5414 -- initialization loops.
5417 -- Counter : Integer := 0;
5424 Make_Block_Statement
(Loc
,
5425 Declarations
=> New_List
(
5426 Make_Object_Declaration
(Loc
,
5427 Defining_Identifier
=> Counter_Id
,
5428 Object_Definition
=>
5429 New_Reference_To
(Standard_Integer
, Loc
),
5430 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5432 Handled_Statement_Sequence
=>
5433 Make_Handled_Sequence_Of_Statements
(Loc
,
5434 Statements
=> New_List
(Init_Loop
))));
5435 end Build_Initialize_Statements
;
5437 -----------------------
5438 -- New_References_To --
5439 -----------------------
5441 function New_References_To
5443 Loc
: Source_Ptr
) return List_Id
5445 Refs
: constant List_Id
:= New_List
;
5450 while Present
(Id
) loop
5451 Append_To
(Refs
, New_Reference_To
(Id
, Loc
));
5456 end New_References_To
;
5458 -- Start of processing for Make_Deep_Array_Body
5462 when Address_Case
=>
5463 return Make_Finalize_Address_Stmts
(Typ
);
5467 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5469 when Initialize_Case
=>
5470 return Build_Initialize_Statements
(Typ
);
5472 end Make_Deep_Array_Body
;
5474 --------------------
5475 -- Make_Deep_Proc --
5476 --------------------
5478 function Make_Deep_Proc
5479 (Prim
: Final_Primitives
;
5481 Stmts
: List_Id
) return Entity_Id
5483 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5485 Proc_Id
: Entity_Id
;
5488 -- Create the object formal, generate:
5489 -- V : System.Address
5491 if Prim
= Address_Case
then
5492 Formals
:= New_List
(
5493 Make_Parameter_Specification
(Loc
,
5494 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5495 Parameter_Type
=> New_Reference_To
(RTE
(RE_Address
), Loc
)));
5502 Formals
:= New_List
(
5503 Make_Parameter_Specification
(Loc
,
5504 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5506 Out_Present
=> True,
5507 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5509 -- F : Boolean := True
5511 if Prim
= Adjust_Case
5512 or else Prim
= Finalize_Case
5515 Make_Parameter_Specification
(Loc
,
5516 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5518 New_Reference_To
(Standard_Boolean
, Loc
),
5520 New_Reference_To
(Standard_True
, Loc
)));
5525 Make_Defining_Identifier
(Loc
,
5526 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5529 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5532 -- exception -- Finalize and Adjust cases only
5533 -- raise Program_Error;
5534 -- end Deep_Initialize / Adjust / Finalize;
5538 -- procedure Finalize_Address (V : System.Address) is
5541 -- end Finalize_Address;
5544 Make_Subprogram_Body
(Loc
,
5546 Make_Procedure_Specification
(Loc
,
5547 Defining_Unit_Name
=> Proc_Id
,
5548 Parameter_Specifications
=> Formals
),
5550 Declarations
=> Empty_List
,
5552 Handled_Statement_Sequence
=>
5553 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5558 ---------------------------
5559 -- Make_Deep_Record_Body --
5560 ---------------------------
5562 function Make_Deep_Record_Body
5563 (Prim
: Final_Primitives
;
5565 Is_Local
: Boolean := False) return List_Id
5567 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5568 -- Build the statements necessary to adjust a record type. The type may
5569 -- have discriminants and contain variant parts. Generate:
5573 -- [Deep_]Adjust (V.Comp_1);
5575 -- when Id : others =>
5576 -- if not Raised then
5578 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5583 -- [Deep_]Adjust (V.Comp_N);
5585 -- when Id : others =>
5586 -- if not Raised then
5588 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5593 -- Deep_Adjust (V._parent, False); -- If applicable
5595 -- when Id : others =>
5596 -- if not Raised then
5598 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5604 -- Adjust (V); -- If applicable
5607 -- if not Raised then
5609 -- Save_Occurence (E, Get_Current_Excep.all.all);
5614 -- if Raised and then not Abort then
5615 -- Raise_From_Controlled_Operation (E);
5619 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5620 -- Build the statements necessary to finalize a record type. The type
5621 -- may have discriminants and contain variant parts. Generate:
5624 -- Abort : constant Boolean := Triggered_By_Abort;
5626 -- Abort : constant Boolean := False; -- no abort
5627 -- E : Exception_Occurence;
5628 -- Raised : Boolean := False;
5633 -- Finalize (V); -- If applicable
5636 -- if not Raised then
5638 -- Save_Occurence (E, Get_Current_Excep.all.all);
5643 -- case Variant_1 is
5645 -- case State_Counter_N => -- If Is_Local is enabled
5655 -- <<LN>> -- If Is_Local is enabled
5657 -- [Deep_]Finalize (V.Comp_N);
5660 -- if not Raised then
5662 -- Save_Occurence (E, Get_Current_Excep.all.all);
5668 -- [Deep_]Finalize (V.Comp_1);
5671 -- if not Raised then
5673 -- Save_Occurence (E, Get_Current_Excep.all.all);
5679 -- case State_Counter_1 => -- If Is_Local is enabled
5685 -- Deep_Finalize (V._parent, False); -- If applicable
5687 -- when Id : others =>
5688 -- if not Raised then
5690 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5694 -- if Raised and then not Abort then
5695 -- Raise_From_Controlled_Operation (E);
5699 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
5700 -- Given a derived tagged type Typ, traverse all components, find field
5701 -- _parent and return its type.
5703 procedure Preprocess_Components
5705 Num_Comps
: out Int
;
5706 Has_POC
: out Boolean);
5707 -- Examine all components in component list Comps, count all controlled
5708 -- components and determine whether at least one of them is per-object
5709 -- constrained. Component _parent is always skipped.
5711 -----------------------------
5712 -- Build_Adjust_Statements --
5713 -----------------------------
5715 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
5716 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5717 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
5718 Bod_Stmts
: List_Id
;
5719 Finalizer_Data
: Finalization_Exception_Data
;
5720 Finalizer_Decls
: List_Id
:= No_List
;
5724 Exceptions_OK
: constant Boolean :=
5725 not Restriction_Active
(No_Exception_Propagation
);
5727 function Process_Component_List_For_Adjust
5728 (Comps
: Node_Id
) return List_Id
;
5729 -- Build all necessary adjust statements for a single component list
5731 ---------------------------------------
5732 -- Process_Component_List_For_Adjust --
5733 ---------------------------------------
5735 function Process_Component_List_For_Adjust
5736 (Comps
: Node_Id
) return List_Id
5738 Stmts
: constant List_Id
:= New_List
;
5740 Decl_Id
: Entity_Id
;
5741 Decl_Typ
: Entity_Id
;
5745 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
5746 -- Process the declaration of a single controlled component
5748 ----------------------------------
5749 -- Process_Component_For_Adjust --
5750 ----------------------------------
5752 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
5753 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
5754 Typ
: constant Entity_Id
:= Etype
(Id
);
5759 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
5761 -- begin -- Exception handlers allowed
5762 -- [Deep_]Adjust (V.Id);
5765 -- if not Raised then
5767 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5774 Make_Selected_Component
(Loc
,
5775 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5776 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
5779 if Exceptions_OK
then
5781 Make_Block_Statement
(Loc
,
5782 Handled_Statement_Sequence
=>
5783 Make_Handled_Sequence_Of_Statements
(Loc
,
5784 Statements
=> New_List
(Adj_Stmt
),
5785 Exception_Handlers
=> New_List
(
5786 Build_Exception_Handler
(Finalizer_Data
))));
5789 Append_To
(Stmts
, Adj_Stmt
);
5790 end Process_Component_For_Adjust
;
5792 -- Start of processing for Process_Component_List_For_Adjust
5795 -- Perform an initial check, determine the number of controlled
5796 -- components in the current list and whether at least one of them
5797 -- is per-object constrained.
5799 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
5801 -- The processing in this routine is done in the following order:
5802 -- 1) Regular components
5803 -- 2) Per-object constrained components
5806 if Num_Comps
> 0 then
5808 -- Process all regular components in order of declarations
5810 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5811 while Present
(Decl
) loop
5812 Decl_Id
:= Defining_Identifier
(Decl
);
5813 Decl_Typ
:= Etype
(Decl_Id
);
5815 -- Skip _parent as well as per-object constrained components
5817 if Chars
(Decl_Id
) /= Name_uParent
5818 and then Needs_Finalization
(Decl_Typ
)
5820 if Has_Access_Constraint
(Decl_Id
)
5821 and then No
(Expression
(Decl
))
5825 Process_Component_For_Adjust
(Decl
);
5829 Next_Non_Pragma
(Decl
);
5832 -- Process all per-object constrained components in order of
5836 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
5837 while Present
(Decl
) loop
5838 Decl_Id
:= Defining_Identifier
(Decl
);
5839 Decl_Typ
:= Etype
(Decl_Id
);
5843 if Chars
(Decl_Id
) /= Name_uParent
5844 and then Needs_Finalization
(Decl_Typ
)
5845 and then Has_Access_Constraint
(Decl_Id
)
5846 and then No
(Expression
(Decl
))
5848 Process_Component_For_Adjust
(Decl
);
5851 Next_Non_Pragma
(Decl
);
5856 -- Process all variants, if any
5859 if Present
(Variant_Part
(Comps
)) then
5861 Var_Alts
: constant List_Id
:= New_List
;
5865 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
5866 while Present
(Var
) loop
5869 -- when <discrete choices> =>
5870 -- <adjust statements>
5872 Append_To
(Var_Alts
,
5873 Make_Case_Statement_Alternative
(Loc
,
5875 New_Copy_List
(Discrete_Choices
(Var
)),
5877 Process_Component_List_For_Adjust
(
5878 Component_List
(Var
))));
5880 Next_Non_Pragma
(Var
);
5884 -- case V.<discriminant> is
5885 -- when <discrete choices 1> =>
5886 -- <adjust statements 1>
5888 -- when <discrete choices N> =>
5889 -- <adjust statements N>
5893 Make_Case_Statement
(Loc
,
5895 Make_Selected_Component
(Loc
,
5896 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5898 Make_Identifier
(Loc
,
5899 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
5900 Alternatives
=> Var_Alts
);
5904 -- Add the variant case statement to the list of statements
5906 if Present
(Var_Case
) then
5907 Append_To
(Stmts
, Var_Case
);
5910 -- If the component list did not have any controlled components
5911 -- nor variants, return null.
5913 if Is_Empty_List
(Stmts
) then
5914 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
5918 end Process_Component_List_For_Adjust
;
5920 -- Start of processing for Build_Adjust_Statements
5923 Finalizer_Decls
:= New_List
;
5924 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5926 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
5927 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
5932 -- Create an adjust sequence for all record components
5934 if Present
(Component_List
(Rec_Def
)) then
5936 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
5939 -- A derived record type must adjust all inherited components. This
5940 -- action poses the following problem:
5942 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
5947 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
5949 -- Deep_Adjust (Obj._parent);
5954 -- Adjusting the derived type will invoke Adjust of the parent and
5955 -- then that of the derived type. This is undesirable because both
5956 -- routines may modify shared components. Only the Adjust of the
5957 -- derived type should be invoked.
5959 -- To prevent this double adjustment of shared components,
5960 -- Deep_Adjust uses a flag to control the invocation of Adjust:
5962 -- procedure Deep_Adjust
5963 -- (Obj : in out Some_Type;
5964 -- Flag : Boolean := True)
5972 -- When Deep_Adjust is invokes for field _parent, a value of False is
5973 -- provided for the flag:
5975 -- Deep_Adjust (Obj._parent, False);
5977 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
5979 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
5984 if Needs_Finalization
(Par_Typ
) then
5988 Make_Selected_Component
(Loc
,
5989 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5991 Make_Identifier
(Loc
, Name_uParent
)),
5993 For_Parent
=> True);
5996 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
5998 -- begin -- Exceptions OK
5999 -- Deep_Adjust (V._parent, False);
6001 -- when Id : others =>
6002 -- if not Raised then
6004 -- Save_Occurrence (E,
6005 -- Get_Current_Excep.all.all);
6009 if Present
(Call
) then
6012 if Exceptions_OK
then
6014 Make_Block_Statement
(Loc
,
6015 Handled_Statement_Sequence
=>
6016 Make_Handled_Sequence_Of_Statements
(Loc
,
6017 Statements
=> New_List
(Adj_Stmt
),
6018 Exception_Handlers
=> New_List
(
6019 Build_Exception_Handler
(Finalizer_Data
))));
6022 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6028 -- Adjust the object. This action must be performed last after all
6029 -- components have been adjusted.
6031 if Is_Controlled
(Typ
) then
6037 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6041 -- Adjust (V); -- No_Exception_Propagation
6043 -- begin -- Exception handlers allowed
6047 -- if not Raised then
6049 -- Save_Occurrence (E,
6050 -- Get_Current_Excep.all.all);
6055 if Present
(Proc
) then
6057 Make_Procedure_Call_Statement
(Loc
,
6058 Name
=> New_Reference_To
(Proc
, Loc
),
6059 Parameter_Associations
=> New_List
(
6060 Make_Identifier
(Loc
, Name_V
)));
6062 if Exceptions_OK
then
6064 Make_Block_Statement
(Loc
,
6065 Handled_Statement_Sequence
=>
6066 Make_Handled_Sequence_Of_Statements
(Loc
,
6067 Statements
=> New_List
(Adj_Stmt
),
6068 Exception_Handlers
=> New_List
(
6069 Build_Exception_Handler
6070 (Finalizer_Data
))));
6073 Append_To
(Bod_Stmts
,
6074 Make_If_Statement
(Loc
,
6075 Condition
=> Make_Identifier
(Loc
, Name_F
),
6076 Then_Statements
=> New_List
(Adj_Stmt
)));
6081 -- At this point either all adjustment statements have been generated
6082 -- or the type is not controlled.
6084 if Is_Empty_List
(Bod_Stmts
) then
6085 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6091 -- Abort : constant Boolean := Triggered_By_Abort;
6093 -- Abort : constant Boolean := False; -- no abort
6095 -- E : Exception_Occurence;
6096 -- Raised : Boolean := False;
6099 -- <adjust statements>
6101 -- if Raised and then not Abort then
6102 -- Raise_From_Controlled_Operation (E);
6107 if Exceptions_OK
then
6108 Append_To
(Bod_Stmts
,
6109 Build_Raise_Statement
(Finalizer_Data
));
6114 Make_Block_Statement
(Loc
,
6117 Handled_Statement_Sequence
=>
6118 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6120 end Build_Adjust_Statements
;
6122 -------------------------------
6123 -- Build_Finalize_Statements --
6124 -------------------------------
6126 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6127 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6128 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6129 Bod_Stmts
: List_Id
;
6131 Finalizer_Data
: Finalization_Exception_Data
;
6132 Finalizer_Decls
: List_Id
:= No_List
;
6136 Exceptions_OK
: constant Boolean :=
6137 not Restriction_Active
(No_Exception_Propagation
);
6139 function Process_Component_List_For_Finalize
6140 (Comps
: Node_Id
) return List_Id
;
6141 -- Build all necessary finalization statements for a single component
6142 -- list. The statements may include a jump circuitry if flag Is_Local
6145 -----------------------------------------
6146 -- Process_Component_List_For_Finalize --
6147 -----------------------------------------
6149 function Process_Component_List_For_Finalize
6150 (Comps
: Node_Id
) return List_Id
6153 Counter_Id
: Entity_Id
;
6155 Decl_Id
: Entity_Id
;
6156 Decl_Typ
: Entity_Id
;
6159 Jump_Block
: Node_Id
;
6161 Label_Id
: Entity_Id
;
6165 procedure Process_Component_For_Finalize
6170 -- Process the declaration of a single controlled component. If
6171 -- flag Is_Local is enabled, create the corresponding label and
6172 -- jump circuitry. Alts is the list of case alternatives, Decls
6173 -- is the top level declaration list where labels are declared
6174 -- and Stmts is the list of finalization actions.
6176 ------------------------------------
6177 -- Process_Component_For_Finalize --
6178 ------------------------------------
6180 procedure Process_Component_For_Finalize
6186 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6187 Typ
: constant Entity_Id
:= Etype
(Id
);
6194 Label_Id
: Entity_Id
;
6201 Make_Identifier
(Loc
,
6202 Chars
=> New_External_Name
('L', Num_Comps
));
6203 Set_Entity
(Label_Id
,
6204 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6205 Label
:= Make_Label
(Loc
, Label_Id
);
6208 Make_Implicit_Label_Declaration
(Loc
,
6209 Defining_Identifier
=> Entity
(Label_Id
),
6210 Label_Construct
=> Label
));
6217 Make_Case_Statement_Alternative
(Loc
,
6218 Discrete_Choices
=> New_List
(
6219 Make_Integer_Literal
(Loc
, Num_Comps
)),
6221 Statements
=> New_List
(
6222 Make_Goto_Statement
(Loc
,
6224 New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6229 Append_To
(Stmts
, Label
);
6231 -- Decrease the number of components to be processed.
6232 -- This action yields a new Label_Id in future calls.
6234 Num_Comps
:= Num_Comps
- 1;
6239 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6241 -- begin -- Exception handlers allowed
6242 -- [Deep_]Finalize (V.Id);
6245 -- if not Raised then
6247 -- Save_Occurrence (E,
6248 -- Get_Current_Excep.all.all);
6255 Make_Selected_Component
(Loc
,
6256 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6257 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6260 if not Restriction_Active
(No_Exception_Propagation
) then
6262 Make_Block_Statement
(Loc
,
6263 Handled_Statement_Sequence
=>
6264 Make_Handled_Sequence_Of_Statements
(Loc
,
6265 Statements
=> New_List
(Fin_Stmt
),
6266 Exception_Handlers
=> New_List
(
6267 Build_Exception_Handler
(Finalizer_Data
))));
6270 Append_To
(Stmts
, Fin_Stmt
);
6271 end Process_Component_For_Finalize
;
6273 -- Start of processing for Process_Component_List_For_Finalize
6276 -- Perform an initial check, look for controlled and per-object
6277 -- constrained components.
6279 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6281 -- Create a state counter to service the current component list.
6282 -- This step is performed before the variants are inspected in
6283 -- order to generate the same state counter names as those from
6284 -- Build_Initialize_Statements.
6289 Counter
:= Counter
+ 1;
6292 Make_Defining_Identifier
(Loc
,
6293 Chars
=> New_External_Name
('C', Counter
));
6296 -- Process the component in the following order:
6298 -- 2) Per-object constrained components
6299 -- 3) Regular components
6301 -- Start with the variant parts
6304 if Present
(Variant_Part
(Comps
)) then
6306 Var_Alts
: constant List_Id
:= New_List
;
6310 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6311 while Present
(Var
) loop
6314 -- when <discrete choices> =>
6315 -- <finalize statements>
6317 Append_To
(Var_Alts
,
6318 Make_Case_Statement_Alternative
(Loc
,
6320 New_Copy_List
(Discrete_Choices
(Var
)),
6322 Process_Component_List_For_Finalize
(
6323 Component_List
(Var
))));
6325 Next_Non_Pragma
(Var
);
6329 -- case V.<discriminant> is
6330 -- when <discrete choices 1> =>
6331 -- <finalize statements 1>
6333 -- when <discrete choices N> =>
6334 -- <finalize statements N>
6338 Make_Case_Statement
(Loc
,
6340 Make_Selected_Component
(Loc
,
6341 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6343 Make_Identifier
(Loc
,
6344 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6345 Alternatives
=> Var_Alts
);
6349 -- The current component list does not have a single controlled
6350 -- component, however it may contain variants. Return the case
6351 -- statement for the variants or nothing.
6353 if Num_Comps
= 0 then
6354 if Present
(Var_Case
) then
6355 return New_List
(Var_Case
);
6357 return New_List
(Make_Null_Statement
(Loc
));
6361 -- Prepare all lists
6367 -- Process all per-object constrained components in reverse order
6370 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6371 while Present
(Decl
) loop
6372 Decl_Id
:= Defining_Identifier
(Decl
);
6373 Decl_Typ
:= Etype
(Decl_Id
);
6377 if Chars
(Decl_Id
) /= Name_uParent
6378 and then Needs_Finalization
(Decl_Typ
)
6379 and then Has_Access_Constraint
(Decl_Id
)
6380 and then No
(Expression
(Decl
))
6382 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6385 Prev_Non_Pragma
(Decl
);
6389 -- Process the rest of the components in reverse order
6391 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6392 while Present
(Decl
) loop
6393 Decl_Id
:= Defining_Identifier
(Decl
);
6394 Decl_Typ
:= Etype
(Decl_Id
);
6398 if Chars
(Decl_Id
) /= Name_uParent
6399 and then Needs_Finalization
(Decl_Typ
)
6401 -- Skip per-object constrained components since they were
6402 -- handled in the above step.
6404 if Has_Access_Constraint
(Decl_Id
)
6405 and then No
(Expression
(Decl
))
6409 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6413 Prev_Non_Pragma
(Decl
);
6418 -- LN : label; -- If Is_Local is enabled
6423 -- case CounterX is .
6433 -- <<LN>> -- If Is_Local is enabled
6435 -- [Deep_]Finalize (V.CompY);
6437 -- when Id : others =>
6438 -- if not Raised then
6440 -- Save_Occurrence (E,
6441 -- Get_Current_Excep.all.all);
6445 -- <<L0>> -- If Is_Local is enabled
6450 -- Add the declaration of default jump location L0, its
6451 -- corresponding alternative and its place in the statements.
6453 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6454 Set_Entity
(Label_Id
,
6455 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6456 Label
:= Make_Label
(Loc
, Label_Id
);
6458 Append_To
(Decls
, -- declaration
6459 Make_Implicit_Label_Declaration
(Loc
,
6460 Defining_Identifier
=> Entity
(Label_Id
),
6461 Label_Construct
=> Label
));
6463 Append_To
(Alts
, -- alternative
6464 Make_Case_Statement_Alternative
(Loc
,
6465 Discrete_Choices
=> New_List
(
6466 Make_Others_Choice
(Loc
)),
6468 Statements
=> New_List
(
6469 Make_Goto_Statement
(Loc
,
6470 Name
=> New_Reference_To
(Entity
(Label_Id
), Loc
)))));
6472 Append_To
(Stmts
, Label
); -- statement
6474 -- Create the jump block
6477 Make_Case_Statement
(Loc
,
6478 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6479 Alternatives
=> Alts
));
6483 Make_Block_Statement
(Loc
,
6484 Declarations
=> Decls
,
6485 Handled_Statement_Sequence
=>
6486 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6488 if Present
(Var_Case
) then
6489 return New_List
(Var_Case
, Jump_Block
);
6491 return New_List
(Jump_Block
);
6493 end Process_Component_List_For_Finalize
;
6495 -- Start of processing for Build_Finalize_Statements
6498 Finalizer_Decls
:= New_List
;
6499 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6501 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6502 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6507 -- Create a finalization sequence for all record components
6509 if Present
(Component_List
(Rec_Def
)) then
6511 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6514 -- A derived record type must finalize all inherited components. This
6515 -- action poses the following problem:
6517 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6522 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6524 -- Deep_Finalize (Obj._parent);
6529 -- Finalizing the derived type will invoke Finalize of the parent and
6530 -- then that of the derived type. This is undesirable because both
6531 -- routines may modify shared components. Only the Finalize of the
6532 -- derived type should be invoked.
6534 -- To prevent this double adjustment of shared components,
6535 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6537 -- procedure Deep_Finalize
6538 -- (Obj : in out Some_Type;
6539 -- Flag : Boolean := True)
6547 -- When Deep_Finalize is invokes for field _parent, a value of False
6548 -- is provided for the flag:
6550 -- Deep_Finalize (Obj._parent, False);
6552 if Is_Tagged_Type
(Typ
)
6553 and then Is_Derived_Type
(Typ
)
6556 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6561 if Needs_Finalization
(Par_Typ
) then
6565 Make_Selected_Component
(Loc
,
6566 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6568 Make_Identifier
(Loc
, Name_uParent
)),
6570 For_Parent
=> True);
6573 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6575 -- begin -- Exceptions OK
6576 -- Deep_Finalize (V._parent, False);
6578 -- when Id : others =>
6579 -- if not Raised then
6581 -- Save_Occurrence (E,
6582 -- Get_Current_Excep.all.all);
6586 if Present
(Call
) then
6589 if Exceptions_OK
then
6591 Make_Block_Statement
(Loc
,
6592 Handled_Statement_Sequence
=>
6593 Make_Handled_Sequence_Of_Statements
(Loc
,
6594 Statements
=> New_List
(Fin_Stmt
),
6595 Exception_Handlers
=> New_List
(
6596 Build_Exception_Handler
6597 (Finalizer_Data
))));
6600 Append_To
(Bod_Stmts
, Fin_Stmt
);
6606 -- Finalize the object. This action must be performed first before
6607 -- all components have been finalized.
6609 if Is_Controlled
(Typ
)
6610 and then not Is_Local
6617 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6621 -- Finalize (V); -- No_Exception_Propagation
6627 -- if not Raised then
6629 -- Save_Occurrence (E,
6630 -- Get_Current_Excep.all.all);
6635 if Present
(Proc
) then
6637 Make_Procedure_Call_Statement
(Loc
,
6638 Name
=> New_Reference_To
(Proc
, Loc
),
6639 Parameter_Associations
=> New_List
(
6640 Make_Identifier
(Loc
, Name_V
)));
6642 if Exceptions_OK
then
6644 Make_Block_Statement
(Loc
,
6645 Handled_Statement_Sequence
=>
6646 Make_Handled_Sequence_Of_Statements
(Loc
,
6647 Statements
=> New_List
(Fin_Stmt
),
6648 Exception_Handlers
=> New_List
(
6649 Build_Exception_Handler
6650 (Finalizer_Data
))));
6653 Prepend_To
(Bod_Stmts
,
6654 Make_If_Statement
(Loc
,
6655 Condition
=> Make_Identifier
(Loc
, Name_F
),
6656 Then_Statements
=> New_List
(Fin_Stmt
)));
6661 -- At this point either all finalization statements have been
6662 -- generated or the type is not controlled.
6664 if No
(Bod_Stmts
) then
6665 return New_List
(Make_Null_Statement
(Loc
));
6669 -- Abort : constant Boolean := Triggered_By_Abort;
6671 -- Abort : constant Boolean := False; -- no abort
6673 -- E : Exception_Occurence;
6674 -- Raised : Boolean := False;
6677 -- <finalize statements>
6679 -- if Raised and then not Abort then
6680 -- Raise_From_Controlled_Operation (E);
6685 if Exceptions_OK
then
6686 Append_To
(Bod_Stmts
,
6687 Build_Raise_Statement
(Finalizer_Data
));
6692 Make_Block_Statement
(Loc
,
6695 Handled_Statement_Sequence
=>
6696 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6698 end Build_Finalize_Statements
;
6700 -----------------------
6701 -- Parent_Field_Type --
6702 -----------------------
6704 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
6708 Field
:= First_Entity
(Typ
);
6709 while Present
(Field
) loop
6710 if Chars
(Field
) = Name_uParent
then
6711 return Etype
(Field
);
6714 Next_Entity
(Field
);
6717 -- A derived tagged type should always have a parent field
6719 raise Program_Error
;
6720 end Parent_Field_Type
;
6722 ---------------------------
6723 -- Preprocess_Components --
6724 ---------------------------
6726 procedure Preprocess_Components
6728 Num_Comps
: out Int
;
6729 Has_POC
: out Boolean)
6739 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6740 while Present
(Decl
) loop
6741 Id
:= Defining_Identifier
(Decl
);
6744 -- Skip field _parent
6746 if Chars
(Id
) /= Name_uParent
6747 and then Needs_Finalization
(Typ
)
6749 Num_Comps
:= Num_Comps
+ 1;
6751 if Has_Access_Constraint
(Id
)
6752 and then No
(Expression
(Decl
))
6758 Next_Non_Pragma
(Decl
);
6760 end Preprocess_Components
;
6762 -- Start of processing for Make_Deep_Record_Body
6766 when Address_Case
=>
6767 return Make_Finalize_Address_Stmts
(Typ
);
6770 return Build_Adjust_Statements
(Typ
);
6772 when Finalize_Case
=>
6773 return Build_Finalize_Statements
(Typ
);
6775 when Initialize_Case
=>
6777 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6780 if Is_Controlled
(Typ
) then
6782 Make_Procedure_Call_Statement
(Loc
,
6785 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
6786 Parameter_Associations
=> New_List
(
6787 Make_Identifier
(Loc
, Name_V
))));
6793 end Make_Deep_Record_Body
;
6795 ----------------------
6796 -- Make_Final_Call --
6797 ----------------------
6799 function Make_Final_Call
6802 For_Parent
: Boolean := False) return Node_Id
6804 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6806 Fin_Id
: Entity_Id
:= Empty
;
6811 -- Recover the proper type which contains [Deep_]Finalize
6813 if Is_Class_Wide_Type
(Typ
) then
6814 Utyp
:= Root_Type
(Typ
);
6818 elsif Is_Concurrent_Type
(Typ
) then
6819 Utyp
:= Corresponding_Record_Type
(Typ
);
6821 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
6823 elsif Is_Private_Type
(Typ
)
6824 and then Present
(Full_View
(Typ
))
6825 and then Is_Concurrent_Type
(Full_View
(Typ
))
6827 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
6829 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
6837 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6838 Set_Assignment_OK
(Ref
);
6840 -- Deal with non-tagged derivation of private views. If the parent type
6841 -- is a protected type, Deep_Finalize is found on the corresponding
6842 -- record of the ancestor.
6844 if Is_Untagged_Derivation
(Typ
) then
6845 if Is_Protected_Type
(Typ
) then
6846 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
6848 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6850 if Is_Protected_Type
(Utyp
) then
6851 Utyp
:= Corresponding_Record_Type
(Utyp
);
6855 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6856 Set_Assignment_OK
(Ref
);
6859 -- Deal with derived private types which do not inherit primitives from
6860 -- their parents. In this case, [Deep_]Finalize can be found in the full
6861 -- view of the parent type.
6863 if Is_Tagged_Type
(Utyp
)
6864 and then Is_Derived_Type
(Utyp
)
6865 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
6866 and then Is_Private_Type
(Etype
(Utyp
))
6867 and then Present
(Full_View
(Etype
(Utyp
)))
6869 Utyp
:= Full_View
(Etype
(Utyp
));
6870 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6871 Set_Assignment_OK
(Ref
);
6874 -- When dealing with the completion of a private type, use the base type
6877 if Utyp
/= Base_Type
(Utyp
) then
6878 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
6880 Utyp
:= Base_Type
(Utyp
);
6881 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6882 Set_Assignment_OK
(Ref
);
6885 -- Select the appropriate version of Finalize
6888 if Has_Controlled_Component
(Utyp
) then
6889 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6892 -- Class-wide types, interfaces and types with controlled components
6894 elsif Is_Class_Wide_Type
(Typ
)
6895 or else Is_Interface
(Typ
)
6896 or else Has_Controlled_Component
(Utyp
)
6898 if Is_Tagged_Type
(Utyp
) then
6899 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6901 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
6904 -- Derivations from [Limited_]Controlled
6906 elsif Is_Controlled
(Utyp
) then
6907 if Has_Controlled_Component
(Utyp
) then
6908 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6910 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
6915 elsif Is_Tagged_Type
(Utyp
) then
6916 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
6919 raise Program_Error
;
6922 if Present
(Fin_Id
) then
6924 -- When finalizing a class-wide object, do not convert to the root
6925 -- type in order to produce a dispatching call.
6927 if Is_Class_Wide_Type
(Typ
) then
6930 -- Ensure that a finalization routine is at least decorated in order
6931 -- to inspect the object parameter.
6933 elsif Analyzed
(Fin_Id
)
6934 or else Ekind
(Fin_Id
) = E_Procedure
6936 -- In certain cases, such as the creation of Stream_Read, the
6937 -- visible entity of the type is its full view. Since Stream_Read
6938 -- will have to create an object of type Typ, the local object
6939 -- will be finalzed by the scope finalizer generated later on. The
6940 -- object parameter of Deep_Finalize will always use the private
6941 -- view of the type. To avoid such a clash between a private and a
6942 -- full view, perform an unchecked conversion of the object
6943 -- reference to the private view.
6946 Formal_Typ
: constant Entity_Id
:=
6947 Etype
(First_Formal
(Fin_Id
));
6949 if Is_Private_Type
(Formal_Typ
)
6950 and then Present
(Full_View
(Formal_Typ
))
6951 and then Full_View
(Formal_Typ
) = Utyp
6953 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
6957 Ref
:= Convert_View
(Fin_Id
, Ref
);
6960 return Make_Call
(Loc
, Fin_Id
, New_Copy_Tree
(Ref
), For_Parent
);
6964 end Make_Final_Call
;
6966 --------------------------------
6967 -- Make_Finalize_Address_Body --
6968 --------------------------------
6970 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
6971 Is_Task
: constant Boolean :=
6972 Ekind
(Typ
) = E_Record_Type
6973 and then Is_Concurrent_Record_Type
(Typ
)
6974 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
6976 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6977 Proc_Id
: Entity_Id
;
6981 -- The corresponding records of task types are not controlled by design.
6982 -- For the sake of completeness, create an empty Finalize_Address to be
6983 -- used in task class-wide allocations.
6988 -- Nothing to do if the type is not controlled or it already has a
6989 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
6990 -- come from source. These are usually generated for completeness and
6991 -- do not need the Finalize_Address primitive.
6993 elsif not Needs_Finalization
(Typ
)
6994 or else Is_Abstract_Type
(Typ
)
6995 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
6997 (Is_Class_Wide_Type
(Typ
)
6998 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
6999 and then not Comes_From_Source
(Root_Type
(Typ
)))
7005 Make_Defining_Identifier
(Loc
,
7006 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7010 -- procedure <Typ>FD (V : System.Address) is
7012 -- null; -- for tasks
7014 -- declare -- for all other types
7015 -- type Pnn is access all Typ;
7016 -- for Pnn'Storage_Size use 0;
7018 -- [Deep_]Finalize (Pnn (V).all);
7023 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7025 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7029 Make_Subprogram_Body
(Loc
,
7031 Make_Procedure_Specification
(Loc
,
7032 Defining_Unit_Name
=> Proc_Id
,
7034 Parameter_Specifications
=> New_List
(
7035 Make_Parameter_Specification
(Loc
,
7036 Defining_Identifier
=>
7037 Make_Defining_Identifier
(Loc
, Name_V
),
7039 New_Reference_To
(RTE
(RE_Address
), Loc
)))),
7041 Declarations
=> No_List
,
7043 Handled_Statement_Sequence
=>
7044 Make_Handled_Sequence_Of_Statements
(Loc
,
7045 Statements
=> Stmts
)));
7047 Set_TSS
(Typ
, Proc_Id
);
7048 end Make_Finalize_Address_Body
;
7050 ---------------------------------
7051 -- Make_Finalize_Address_Stmts --
7052 ---------------------------------
7054 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7055 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7056 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7058 Desg_Typ
: Entity_Id
;
7062 if Is_Array_Type
(Typ
) then
7063 if Is_Constrained
(First_Subtype
(Typ
)) then
7064 Desg_Typ
:= First_Subtype
(Typ
);
7066 Desg_Typ
:= Base_Type
(Typ
);
7069 -- Class-wide types of constrained root types
7071 elsif Is_Class_Wide_Type
(Typ
)
7072 and then Has_Discriminants
(Root_Type
(Typ
))
7074 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7077 Parent_Typ
: Entity_Id
;
7080 -- Climb the parent type chain looking for a non-constrained type
7082 Parent_Typ
:= Root_Type
(Typ
);
7083 while Parent_Typ
/= Etype
(Parent_Typ
)
7084 and then Has_Discriminants
(Parent_Typ
)
7086 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7088 Parent_Typ
:= Etype
(Parent_Typ
);
7091 -- Handle views created for tagged types with unknown
7094 if Is_Underlying_Record_View
(Parent_Typ
) then
7095 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7098 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7108 -- type Ptr_Typ is access all Typ;
7109 -- for Ptr_Typ'Storage_Size use 0;
7112 Make_Full_Type_Declaration
(Loc
,
7113 Defining_Identifier
=> Ptr_Typ
,
7115 Make_Access_To_Object_Definition
(Loc
,
7116 All_Present
=> True,
7117 Subtype_Indication
=> New_Reference_To
(Desg_Typ
, Loc
))),
7119 Make_Attribute_Definition_Clause
(Loc
,
7120 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7121 Chars
=> Name_Storage_Size
,
7122 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7124 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7126 -- Unconstrained arrays require special processing in order to retrieve
7127 -- the elements. To achieve this, we have to skip the dope vector which
7128 -- lays in front of the elements and then use a thin pointer to perform
7129 -- the address-to-access conversion.
7131 if Is_Array_Type
(Typ
)
7132 and then not Is_Constrained
(First_Subtype
(Typ
))
7135 Dope_Id
: Entity_Id
;
7138 -- Ensure that Ptr_Typ a thin pointer, generate:
7139 -- for Ptr_Typ'Size use System.Address'Size;
7142 Make_Attribute_Definition_Clause
(Loc
,
7143 Name
=> New_Reference_To
(Ptr_Typ
, Loc
),
7146 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7149 -- Dnn : constant Storage_Offset :=
7150 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7152 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7155 Make_Object_Declaration
(Loc
,
7156 Defining_Identifier
=> Dope_Id
,
7157 Constant_Present
=> True,
7158 Object_Definition
=>
7159 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
7161 Make_Op_Divide
(Loc
,
7163 Make_Attribute_Reference
(Loc
,
7164 Prefix
=> New_Reference_To
(Desg_Typ
, Loc
),
7165 Attribute_Name
=> Name_Descriptor_Size
),
7167 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7169 -- Shift the address from the start of the dope vector to the
7170 -- start of the elements:
7174 -- Note that this is done through a wrapper routine since RTSfind
7175 -- cannot retrieve operations with string names of the form "+".
7178 Make_Function_Call
(Loc
,
7180 New_Reference_To
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7181 Parameter_Associations
=> New_List
(
7183 New_Reference_To
(Dope_Id
, Loc
)));
7187 -- Create the block and the finalization call
7190 Make_Block_Statement
(Loc
,
7191 Declarations
=> Decls
,
7193 Handled_Statement_Sequence
=>
7194 Make_Handled_Sequence_Of_Statements
(Loc
,
7195 Statements
=> New_List
(
7198 Make_Explicit_Dereference
(Loc
,
7199 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7200 Typ
=> Desg_Typ
)))));
7201 end Make_Finalize_Address_Stmts
;
7203 -------------------------------------
7204 -- Make_Handler_For_Ctrl_Operation --
7205 -------------------------------------
7209 -- when E : others =>
7210 -- Raise_From_Controlled_Operation (E);
7215 -- raise Program_Error [finalize raised exception];
7217 -- depending on whether Raise_From_Controlled_Operation is available
7219 function Make_Handler_For_Ctrl_Operation
7220 (Loc
: Source_Ptr
) return Node_Id
7223 -- Choice parameter (for the first case above)
7225 Raise_Node
: Node_Id
;
7226 -- Procedure call or raise statement
7229 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7230 -- it to Raise_From_Controlled_Operation so that the original exception
7231 -- name and message can be recorded in the exception message for
7234 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7235 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7237 Make_Procedure_Call_Statement
(Loc
,
7240 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7241 Parameter_Associations
=> New_List
(
7242 New_Reference_To
(E_Occ
, Loc
)));
7244 -- Restricted run-time: exception messages are not supported
7249 Make_Raise_Program_Error
(Loc
,
7250 Reason
=> PE_Finalize_Raised_Exception
);
7254 Make_Implicit_Exception_Handler
(Loc
,
7255 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7256 Choice_Parameter
=> E_Occ
,
7257 Statements
=> New_List
(Raise_Node
));
7258 end Make_Handler_For_Ctrl_Operation
;
7260 --------------------
7261 -- Make_Init_Call --
7262 --------------------
7264 function Make_Init_Call
7266 Typ
: Entity_Id
) return Node_Id
7268 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7275 -- Deal with the type and object reference. Depending on the context, an
7276 -- object reference may need several conversions.
7278 if Is_Concurrent_Type
(Typ
) then
7280 Utyp
:= Corresponding_Record_Type
(Typ
);
7281 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7283 elsif Is_Private_Type
(Typ
)
7284 and then Present
(Full_View
(Typ
))
7285 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7288 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7289 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7297 Set_Assignment_OK
(Ref
);
7299 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7301 -- Deal with non-tagged derivation of private views
7303 if Is_Untagged_Derivation
(Typ
)
7304 and then not Is_Conc
7306 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7307 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7309 -- The following is to prevent problems with UC see 1.156 RH ???
7311 Set_Assignment_OK
(Ref
);
7314 -- If the underlying_type is a subtype, then we are dealing with the
7315 -- completion of a private type. We need to access the base type and
7316 -- generate a conversion to it.
7318 if Utyp
/= Base_Type
(Utyp
) then
7319 pragma Assert
(Is_Private_Type
(Typ
));
7320 Utyp
:= Base_Type
(Utyp
);
7321 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7324 -- Select the appropriate version of initialize
7326 if Has_Controlled_Component
(Utyp
) then
7327 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7329 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7330 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7333 -- The object reference may need another conversion depending on the
7334 -- type of the formal and that of the actual.
7336 Ref
:= Convert_View
(Proc
, Ref
);
7339 -- [Deep_]Initialize (Ref);
7342 Make_Procedure_Call_Statement
(Loc
,
7344 New_Reference_To
(Proc
, Loc
),
7345 Parameter_Associations
=> New_List
(Ref
));
7348 ------------------------------
7349 -- Make_Local_Deep_Finalize --
7350 ------------------------------
7352 function Make_Local_Deep_Finalize
7354 Nam
: Entity_Id
) return Node_Id
7356 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7360 Formals
:= New_List
(
7364 Make_Parameter_Specification
(Loc
,
7365 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7367 Out_Present
=> True,
7368 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7370 -- F : Boolean := True
7372 Make_Parameter_Specification
(Loc
,
7373 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7374 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
),
7375 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
7377 -- Add the necessary number of counters to represent the initialization
7378 -- state of an object.
7381 Make_Subprogram_Body
(Loc
,
7383 Make_Procedure_Specification
(Loc
,
7384 Defining_Unit_Name
=> Nam
,
7385 Parameter_Specifications
=> Formals
),
7387 Declarations
=> No_List
,
7389 Handled_Statement_Sequence
=>
7390 Make_Handled_Sequence_Of_Statements
(Loc
,
7391 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7392 end Make_Local_Deep_Finalize
;
7394 ------------------------------------
7395 -- Make_Set_Finalize_Address_Call --
7396 ------------------------------------
7398 function Make_Set_Finalize_Address_Call
7401 Ptr_Typ
: Entity_Id
) return Node_Id
7403 Desig_Typ
: constant Entity_Id
:=
7404 Available_View
(Designated_Type
(Ptr_Typ
));
7405 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7406 Fin_Mas_Ref
: Node_Id
;
7410 -- If the context is a class-wide allocator, we use the class-wide type
7411 -- to obtain the proper Finalize_Address routine.
7413 if Is_Class_Wide_Type
(Desig_Typ
) then
7419 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7420 Utyp
:= Full_View
(Utyp
);
7423 if Is_Concurrent_Type
(Utyp
) then
7424 Utyp
:= Corresponding_Record_Type
(Utyp
);
7428 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7430 -- Deal with non-tagged derivation of private views. If the parent is
7431 -- now known to be protected, the finalization routine is the one
7432 -- defined on the corresponding record of the ancestor (corresponding
7433 -- records do not automatically inherit operations, but maybe they
7436 if Is_Untagged_Derivation
(Typ
) then
7437 if Is_Protected_Type
(Typ
) then
7438 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7440 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7442 if Is_Protected_Type
(Utyp
) then
7443 Utyp
:= Corresponding_Record_Type
(Utyp
);
7448 -- If the underlying_type is a subtype, we are dealing with the
7449 -- completion of a private type. We need to access the base type and
7450 -- generate a conversion to it.
7452 if Utyp
/= Base_Type
(Utyp
) then
7453 pragma Assert
(Is_Private_Type
(Typ
));
7455 Utyp
:= Base_Type
(Utyp
);
7458 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7460 -- If the call is from a build-in-place function, the Master parameter
7461 -- is actually a pointer. Dereference it for the call.
7463 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7464 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7468 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7471 Make_Procedure_Call_Statement
(Loc
,
7473 New_Reference_To
(RTE
(RE_Set_Finalize_Address
), Loc
),
7474 Parameter_Associations
=> New_List
(
7476 Make_Attribute_Reference
(Loc
,
7478 New_Reference_To
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7479 Attribute_Name
=> Name_Unrestricted_Access
)));
7480 end Make_Set_Finalize_Address_Call
;
7482 --------------------------
7483 -- Make_Transient_Block --
7484 --------------------------
7486 function Make_Transient_Block
7489 Par
: Node_Id
) return Node_Id
7491 Decls
: constant List_Id
:= New_List
;
7492 Instrs
: constant List_Id
:= New_List
(Action
);
7497 -- Case where only secondary stack use is involved
7499 if VM_Target
= No_VM
7500 and then Uses_Sec_Stack
(Current_Scope
)
7501 and then Nkind
(Action
) /= N_Simple_Return_Statement
7502 and then Nkind
(Par
) /= N_Exception_Handler
7508 S
:= Scope
(Current_Scope
);
7510 -- At the outer level, no need to release the sec stack
7512 if S
= Standard_Standard
then
7513 Set_Uses_Sec_Stack
(Current_Scope
, False);
7516 -- In a function, only release the sec stack if the function
7517 -- does not return on the sec stack otherwise the result may
7518 -- be lost. The caller is responsible for releasing.
7520 elsif Ekind
(S
) = E_Function
then
7521 Set_Uses_Sec_Stack
(Current_Scope
, False);
7523 if not Requires_Transient_Scope
(Etype
(S
)) then
7524 Set_Uses_Sec_Stack
(S
, True);
7525 Check_Restriction
(No_Secondary_Stack
, Action
);
7530 -- In a loop or entry we should install a block encompassing
7531 -- all the construct. For now just release right away.
7533 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7536 -- In a procedure or a block, we release on exit of the
7537 -- procedure or block. ??? memory leak can be created by
7540 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7541 Set_Uses_Sec_Stack
(S
, True);
7542 Check_Restriction
(No_Secondary_Stack
, Action
);
7543 Set_Uses_Sec_Stack
(Current_Scope
, False);
7553 -- Create the transient block. Set the parent now since the block itself
7554 -- is not part of the tree.
7557 Make_Block_Statement
(Loc
,
7558 Identifier
=> New_Reference_To
(Current_Scope
, Loc
),
7559 Declarations
=> Decls
,
7560 Handled_Statement_Sequence
=>
7561 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7562 Has_Created_Identifier
=> True);
7563 Set_Parent
(Block
, Par
);
7565 -- Insert actions stuck in the transient scopes as well as all freezing
7566 -- nodes needed by those actions.
7568 Insert_Actions_In_Scope_Around
(Action
);
7570 Insert
:= Prev
(Action
);
7571 if Present
(Insert
) then
7572 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7575 -- When the transient scope was established, we pushed the entry for the
7576 -- transient scope onto the scope stack, so that the scope was active
7577 -- for the installation of finalizable entities etc. Now we must remove
7578 -- this entry, since we have constructed a proper block.
7583 end Make_Transient_Block
;
7585 ------------------------
7586 -- Node_To_Be_Wrapped --
7587 ------------------------
7589 function Node_To_Be_Wrapped
return Node_Id
is
7591 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7592 end Node_To_Be_Wrapped
;
7594 ----------------------------
7595 -- Set_Node_To_Be_Wrapped --
7596 ----------------------------
7598 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7600 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7601 end Set_Node_To_Be_Wrapped
;
7603 ----------------------------------
7604 -- Store_After_Actions_In_Scope --
7605 ----------------------------------
7607 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
7608 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7611 if Present
(SE
.Actions_To_Be_Wrapped_After
) then
7612 Insert_List_Before_And_Analyze
(
7613 First
(SE
.Actions_To_Be_Wrapped_After
), L
);
7616 SE
.Actions_To_Be_Wrapped_After
:= L
;
7618 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7619 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7621 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7626 end Store_After_Actions_In_Scope
;
7628 -----------------------------------
7629 -- Store_Before_Actions_In_Scope --
7630 -----------------------------------
7632 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
7633 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7636 if Present
(SE
.Actions_To_Be_Wrapped_Before
) then
7637 Insert_List_After_And_Analyze
(
7638 Last
(SE
.Actions_To_Be_Wrapped_Before
), L
);
7641 SE
.Actions_To_Be_Wrapped_Before
:= L
;
7643 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7644 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7646 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7651 end Store_Before_Actions_In_Scope
;
7653 --------------------------------
7654 -- Wrap_Transient_Declaration --
7655 --------------------------------
7657 -- If a transient scope has been established during the processing of the
7658 -- Expression of an Object_Declaration, it is not possible to wrap the
7659 -- declaration into a transient block as usual case, otherwise the object
7660 -- would be itself declared in the wrong scope. Therefore, all entities (if
7661 -- any) defined in the transient block are moved to the proper enclosing
7662 -- scope, furthermore, if they are controlled variables they are finalized
7663 -- right after the declaration. The finalization list of the transient
7664 -- scope is defined as a renaming of the enclosing one so during their
7665 -- initialization they will be attached to the proper finalization list.
7666 -- For instance, the following declaration :
7668 -- X : Typ := F (G (A), G (B));
7670 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7671 -- is expanded into :
7673 -- X : Typ := [ complex Expression-Action ];
7674 -- [Deep_]Finalize (_v1);
7675 -- [Deep_]Finalize (_v2);
7677 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
7684 Encl_S
:= Scope
(S
);
7686 -- Insert Actions kept in the Scope stack
7688 Insert_Actions_In_Scope_Around
(N
);
7690 -- If the declaration is consuming some secondary stack, mark the
7691 -- enclosing scope appropriately.
7693 Uses_SS
:= Uses_Sec_Stack
(S
);
7696 -- Put the local entities back in the enclosing scope, and set the
7697 -- Is_Public flag appropriately.
7699 Transfer_Entities
(S
, Encl_S
);
7701 -- Mark the enclosing dynamic scope so that the sec stack will be
7702 -- released upon its exit unless this is a function that returns on
7703 -- the sec stack in which case this will be done by the caller.
7705 if VM_Target
= No_VM
and then Uses_SS
then
7706 S
:= Enclosing_Dynamic_Scope
(S
);
7708 if Ekind
(S
) = E_Function
7709 and then Requires_Transient_Scope
(Etype
(S
))
7713 Set_Uses_Sec_Stack
(S
);
7714 Check_Restriction
(No_Secondary_Stack
, N
);
7717 end Wrap_Transient_Declaration
;
7719 -------------------------------
7720 -- Wrap_Transient_Expression --
7721 -------------------------------
7723 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
7724 Expr
: constant Node_Id
:= Relocate_Node
(N
);
7725 Loc
: constant Source_Ptr
:= Sloc
(N
);
7726 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
7727 Typ
: constant Entity_Id
:= Etype
(N
);
7734 -- M : constant Mark_Id := SS_Mark;
7735 -- procedure Finalizer is ... (See Build_Finalizer)
7744 Insert_Actions
(N
, New_List
(
7745 Make_Object_Declaration
(Loc
,
7746 Defining_Identifier
=> Temp
,
7747 Object_Definition
=> New_Reference_To
(Typ
, Loc
)),
7749 Make_Transient_Block
(Loc
,
7751 Make_Assignment_Statement
(Loc
,
7752 Name
=> New_Reference_To
(Temp
, Loc
),
7753 Expression
=> Expr
),
7754 Par
=> Parent
(N
))));
7756 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
7757 Analyze_And_Resolve
(N
, Typ
);
7758 end Wrap_Transient_Expression
;
7760 ------------------------------
7761 -- Wrap_Transient_Statement --
7762 ------------------------------
7764 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
7765 Loc
: constant Source_Ptr
:= Sloc
(N
);
7766 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
7771 -- M : constant Mark_Id := SS_Mark;
7772 -- procedure Finalizer is ... (See Build_Finalizer)
7782 Make_Transient_Block
(Loc
,
7784 Par
=> Parent
(N
)));
7786 -- With the scope stack back to normal, we can call analyze on the
7787 -- resulting block. At this point, the transient scope is being
7788 -- treated like a perfectly normal scope, so there is nothing
7789 -- special about it.
7791 -- Note: Wrap_Transient_Statement is called with the node already
7792 -- analyzed (i.e. Analyzed (N) is True). This is important, since
7793 -- otherwise we would get a recursive processing of the node when
7794 -- we do this Analyze call.
7797 end Wrap_Transient_Statement
;