1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Nlists
; use Nlists
;
46 with Nmake
; use Nmake
;
48 with Output
; use Output
;
49 with Restrict
; use Restrict
;
50 with Rident
; use Rident
;
51 with Rtsfind
; use Rtsfind
;
52 with Sinfo
; use Sinfo
;
54 with Sem_Aux
; use Sem_Aux
;
55 with Sem_Ch3
; use Sem_Ch3
;
56 with Sem_Ch7
; use Sem_Ch7
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Util
; use Sem_Util
;
60 with Snames
; use Snames
;
61 with Stand
; use Stand
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Uintp
; use Uintp
;
67 package body Exp_Ch7
is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
129 -- N is a node which may generate a transient scope. Loop over the parent
130 -- pointers of N until it find the appropriate node to wrap. If it returns
131 -- Empty, it means that no transient scope is needed in this context.
133 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
);
134 -- Insert the before-actions kept in the scope stack before N, and the
135 -- after-actions after N, which must be a member of a list.
137 function Make_Transient_Block
140 Par
: Node_Id
) return Node_Id
;
141 -- Action is a single statement or object declaration. Par is the proper
142 -- parent of the generated block. Create a transient block whose name is
143 -- the current scope and the only handled statement is Action. If Action
144 -- involves controlled objects or secondary stack usage, the corresponding
145 -- cleanup actions are performed at the end of the block.
147 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
148 -- Set the field Node_To_Be_Wrapped of the current scope
150 -- ??? The entire comment needs to be rewritten
151 -- ??? which entire comment?
153 -----------------------------
154 -- Finalization Management --
155 -----------------------------
157 -- This part describe how Initialization/Adjustment/Finalization procedures
158 -- are generated and called. Two cases must be considered, types that are
159 -- Controlled (Is_Controlled flag set) and composite types that contain
160 -- controlled components (Has_Controlled_Component flag set). In the first
161 -- case the procedures to call are the user-defined primitive operations
162 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
163 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
164 -- of calling the former procedures on the controlled components.
166 -- For records with Has_Controlled_Component set, a hidden "controller"
167 -- component is inserted. This controller component contains its own
168 -- finalization list on which all controlled components are attached
169 -- creating an indirection on the upper-level Finalization list. This
170 -- technique facilitates the management of objects whose number of
171 -- controlled components changes during execution. This controller
172 -- component is itself controlled and is attached to the upper-level
173 -- finalization chain. Its adjust primitive is in charge of calling adjust
174 -- on the components and adjusting the finalization pointer to match their
175 -- new location (see a-finali.adb).
177 -- It is not possible to use a similar technique for arrays that have
178 -- Has_Controlled_Component set. In this case, deep procedures are
179 -- generated that call initialize/adjust/finalize + attachment or
180 -- detachment on the finalization list for all component.
182 -- Initialize calls: they are generated for declarations or dynamic
183 -- allocations of Controlled objects with no initial value. They are always
184 -- followed by an attachment to the current Finalization Chain. For the
185 -- dynamic allocation case this the chain attached to the scope of the
186 -- access type definition otherwise, this is the chain of the current
189 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
190 -- or dynamic allocations of Controlled objects with an initial value.
191 -- (2) after an assignment. In the first case they are followed by an
192 -- attachment to the final chain, in the second case they are not.
194 -- Finalization Calls: They are generated on (1) scope exit, (2)
195 -- assignments, (3) unchecked deallocations. In case (3) they have to
196 -- be detached from the final chain, in case (2) they must not and in
197 -- case (1) this is not important since we are exiting the scope anyway.
201 -- Type extensions will have a new record controller at each derivation
202 -- level containing controlled components. The record controller for
203 -- the parent/ancestor is attached to the finalization list of the
204 -- extension's record controller (i.e. the parent is like a component
205 -- of the extension).
207 -- For types that are both Is_Controlled and Has_Controlled_Components,
208 -- the record controller and the object itself are handled separately.
209 -- It could seem simpler to attach the object at the end of its record
210 -- controller but this would not tackle view conversions properly.
212 -- A classwide type can always potentially have controlled components
213 -- but the record controller of the corresponding actual type may not
214 -- be known at compile time so the dispatch table contains a special
215 -- field that allows to compute the offset of the record controller
216 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
218 -- Here is a simple example of the expansion of a controlled block :
222 -- Y : Controlled := Init;
228 -- Z : R := (C => X);
238 -- _L : System.FI.Finalizable_Ptr;
240 -- procedure _Clean is
243 -- System.FI.Finalize_List (_L);
251 -- Attach_To_Final_List (_L, Finalizable (X), 1);
252 -- at end: Abort_Undefer;
253 -- Y : Controlled := Init;
255 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
263 -- Deep_Initialize (W, _L, 1);
264 -- at end: Abort_Under;
265 -- Z : R := (C => X);
266 -- Deep_Adjust (Z, _L, 1);
270 -- Deep_Finalize (W, False);
271 -- <save W's final pointers>
273 -- <restore W's final pointers>
274 -- Deep_Adjust (W, _L, 0);
279 type Final_Primitives
is
280 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
281 -- This enumeration type is defined in order to ease sharing code for
282 -- building finalization procedures for composite types.
284 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
285 (Initialize_Case
=> Name_Initialize
,
286 Adjust_Case
=> Name_Adjust
,
287 Finalize_Case
=> Name_Finalize
,
288 Address_Case
=> Name_Finalize_Address
);
289 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
290 (Initialize_Case
=> TSS_Deep_Initialize
,
291 Adjust_Case
=> TSS_Deep_Adjust
,
292 Finalize_Case
=> TSS_Deep_Finalize
,
293 Address_Case
=> TSS_Finalize_Address
);
295 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
296 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
297 -- Has_Controlled_Component set and store them using the TSS mechanism.
299 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
;
300 -- Create the clean up calls for an asynchronous call block, task master,
301 -- protected subprogram body, task allocation block or task body. If the
302 -- context does not contain the above constructs, the routine returns an
305 procedure Build_Finalizer
307 Clean_Stmts
: List_Id
;
310 Defer_Abort
: Boolean;
311 Fin_Id
: out Entity_Id
);
312 -- N may denote an accept statement, block, entry body, package body,
313 -- package spec, protected body, subprogram body, or a task body. Create
314 -- a procedure which contains finalization calls for all controlled objects
315 -- declared in the declarative or statement region of N. The calls are
316 -- built in reverse order relative to the original declarations. In the
317 -- case of a task body, the routine delays the creation of the finalizer
318 -- until all statements have been moved to the task body procedure.
319 -- Clean_Stmts may contain additional context-dependent code used to abort
320 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
321 -- Mark_Id is the secondary stack used in the current context or Empty if
322 -- missing. Top_Decls is the list on which the declaration of the finalizer
323 -- is attached in the non-package case. Defer_Abort indicates that the
324 -- statements passed in perform actions that require abort to be deferred,
325 -- such as for task termination. Fin_Id is the finalizer declaration
328 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
329 -- N is a construct which contains a handled sequence of statements, Fin_Id
330 -- is the entity of a finalizer. Create an At_End handler which covers the
331 -- statements of N and calls Fin_Id. If the handled statement sequence has
332 -- an exception handler, the statements will be wrapped in a block to avoid
333 -- unwanted interaction with the new At_End handler.
335 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
336 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
337 -- Has_Component_Component set and store them using the TSS mechanism.
339 procedure Check_Visibly_Controlled
340 (Prim
: Final_Primitives
;
342 E
: in out Entity_Id
;
343 Cref
: in out Node_Id
);
344 -- The controlled operation declared for a derived type may not be
345 -- overriding, if the controlled operations of the parent type are hidden,
346 -- for example when the parent is a private type whose full view is
347 -- controlled. For other primitive operations we modify the name of the
348 -- operation to indicate that it is not overriding, but this is not
349 -- possible for Initialize, etc. because they have to be retrievable by
350 -- name. Before generating the proper call to one of these operations we
351 -- check whether Typ is known to be controlled at the point of definition.
352 -- If it is not then we must retrieve the hidden operation of the parent
353 -- and use it instead. This is one case that might be solved more cleanly
354 -- once Overriding pragmas or declarations are in place.
356 function Convert_View
359 Ind
: Pos
:= 1) return Node_Id
;
360 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
361 -- argument being passed to it. Ind indicates which formal of procedure
362 -- Proc we are trying to match. This function will, if necessary, generate
363 -- a conversion between the partial and full view of Arg to match the type
364 -- of the formal of Proc, or force a conversion to the class-wide type in
365 -- the case where the operation is abstract.
367 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
368 -- Given an arbitrary entity, traverse the scope chain looking for the
369 -- first enclosing function. Return Empty if no function was found.
371 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
);
372 -- Subsidiary to the expansion of package specs and bodies. Generate a
373 -- runtime check needed to verify the assumption introduced by pragma
374 -- Initial_Condition. N denotes the package spec or body.
380 For_Parent
: Boolean := False) return Node_Id
;
381 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
382 -- routine [Deep_]Adjust / Finalize and an object parameter, create an
383 -- adjust / finalization call. Flag For_Parent should be set when field
384 -- _parent is being processed.
386 function Make_Deep_Proc
387 (Prim
: Final_Primitives
;
389 Stmts
: List_Id
) return Node_Id
;
390 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
391 -- Deep_Finalize procedures according to the first parameter, these
392 -- procedures operate on the type Typ. The Stmts parameter gives the body
395 function Make_Deep_Array_Body
396 (Prim
: Final_Primitives
;
397 Typ
: Entity_Id
) return List_Id
;
398 -- This function generates the list of statements for implementing
399 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
400 -- the first parameter, these procedures operate on the array type Typ.
402 function Make_Deep_Record_Body
403 (Prim
: Final_Primitives
;
405 Is_Local
: Boolean := False) return List_Id
;
406 -- This function generates the list of statements for implementing
407 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
408 -- the first parameter, these procedures operate on the record type Typ.
409 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
410 -- whether the inner logic should be dictated by state counters.
412 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
413 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
414 -- Make_Deep_Record_Body. Generate the following statements:
417 -- type Acc_Typ is access all Typ;
418 -- for Acc_Typ'Storage_Size use 0;
420 -- [Deep_]Finalize (Acc_Typ (V).all);
423 ----------------------------
424 -- Build_Array_Deep_Procs --
425 ----------------------------
427 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
431 (Prim
=> Initialize_Case
,
433 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
435 if not Is_Limited_View
(Typ
) then
438 (Prim
=> Adjust_Case
,
440 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
443 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
444 -- suppressed since these routine will not be used.
446 if not Restriction_Active
(No_Finalization
) then
449 (Prim
=> Finalize_Case
,
451 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
453 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
454 -- .NET do not support address arithmetic and unchecked conversions.
456 if VM_Target
= No_VM
then
459 (Prim
=> Address_Case
,
461 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
464 end Build_Array_Deep_Procs
;
466 ------------------------------
467 -- Build_Cleanup_Statements --
468 ------------------------------
470 function Build_Cleanup_Statements
(N
: Node_Id
) return List_Id
is
471 Is_Asynchronous_Call
: constant Boolean :=
472 Nkind
(N
) = N_Block_Statement
473 and then Is_Asynchronous_Call_Block
(N
);
474 Is_Master
: constant Boolean :=
475 Nkind
(N
) /= N_Entry_Body
476 and then Is_Task_Master
(N
);
477 Is_Protected_Body
: constant Boolean :=
478 Nkind
(N
) = N_Subprogram_Body
479 and then Is_Protected_Subprogram_Body
(N
);
480 Is_Task_Allocation
: constant Boolean :=
481 Nkind
(N
) = N_Block_Statement
482 and then Is_Task_Allocation_Block
(N
);
483 Is_Task_Body
: constant Boolean :=
484 Nkind
(Original_Node
(N
)) = N_Task_Body
;
486 Loc
: constant Source_Ptr
:= Sloc
(N
);
487 Stmts
: constant List_Id
:= New_List
;
491 if Restricted_Profile
then
493 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
495 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
499 if Restriction_Active
(No_Task_Hierarchy
) = False then
500 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
503 -- Add statements to unlock the protected object parameter and to
504 -- undefer abort. If the context is a protected procedure and the object
505 -- has entries, call the entry service routine.
507 -- NOTE: The generated code references _object, a parameter to the
510 elsif Is_Protected_Body
then
512 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
513 Conc_Typ
: Entity_Id
;
515 Param_Typ
: Entity_Id
;
518 -- Find the _object parameter representing the protected object
520 Param
:= First
(Parameter_Specifications
(Spec
));
522 Param_Typ
:= Etype
(Parameter_Type
(Param
));
524 if Ekind
(Param_Typ
) = E_Record_Type
then
525 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
528 exit when No
(Param
) or else Present
(Conc_Typ
);
532 pragma Assert
(Present
(Param
));
534 -- Historical note: In earlier versions of GNAT, there was code
535 -- at this point to generate stuff to service entry queues. It is
536 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
538 Build_Protected_Subprogram_Call_Cleanup
539 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
542 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
543 -- tasks. Other unactivated tasks are completed by Complete_Task or
546 -- NOTE: The generated code references _chain, a local object
548 elsif Is_Task_Allocation
then
551 -- Expunge_Unactivated_Tasks (_chain);
553 -- where _chain is the list of tasks created by the allocator but not
554 -- yet activated. This list will be empty unless the block completes
558 Make_Procedure_Call_Statement
(Loc
,
561 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
562 Parameter_Associations
=> New_List
(
563 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
565 -- Attempt to cancel an asynchronous entry call whenever the block which
566 -- contains the abortable part is exited.
568 -- NOTE: The generated code references Cnn, a local object
570 elsif Is_Asynchronous_Call
then
572 Cancel_Param
: constant Entity_Id
:=
573 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
576 -- If it is of type Communication_Block, this must be a protected
577 -- entry call. Generate:
579 -- if Enqueued (Cancel_Param) then
580 -- Cancel_Protected_Entry_Call (Cancel_Param);
583 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
585 Make_If_Statement
(Loc
,
587 Make_Function_Call
(Loc
,
589 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
590 Parameter_Associations
=> New_List
(
591 New_Occurrence_Of
(Cancel_Param
, Loc
))),
593 Then_Statements
=> New_List
(
594 Make_Procedure_Call_Statement
(Loc
,
597 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
598 Parameter_Associations
=> New_List
(
599 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
601 -- Asynchronous delay, generate:
602 -- Cancel_Async_Delay (Cancel_Param);
604 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
606 Make_Procedure_Call_Statement
(Loc
,
608 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
609 Parameter_Associations
=> New_List
(
610 Make_Attribute_Reference
(Loc
,
612 New_Occurrence_Of
(Cancel_Param
, Loc
),
613 Attribute_Name
=> Name_Unchecked_Access
))));
615 -- Task entry call, generate:
616 -- Cancel_Task_Entry_Call (Cancel_Param);
620 Make_Procedure_Call_Statement
(Loc
,
622 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
623 Parameter_Associations
=> New_List
(
624 New_Occurrence_Of
(Cancel_Param
, Loc
))));
630 end Build_Cleanup_Statements
;
632 -----------------------------
633 -- Build_Controlling_Procs --
634 -----------------------------
636 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
638 if Is_Array_Type
(Typ
) then
639 Build_Array_Deep_Procs
(Typ
);
640 else pragma Assert
(Is_Record_Type
(Typ
));
641 Build_Record_Deep_Procs
(Typ
);
643 end Build_Controlling_Procs
;
645 -----------------------------
646 -- Build_Exception_Handler --
647 -----------------------------
649 function Build_Exception_Handler
650 (Data
: Finalization_Exception_Data
;
651 For_Library
: Boolean := False) return Node_Id
654 Proc_To_Call
: Entity_Id
;
659 pragma Assert
(Present
(Data
.Raised_Id
));
661 if Exception_Extra_Info
662 or else (For_Library
and not Restricted_Profile
)
664 if Exception_Extra_Info
then
668 -- Get_Current_Excep.all
671 Make_Function_Call
(Data
.Loc
,
673 Make_Explicit_Dereference
(Data
.Loc
,
676 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
683 Except
:= Make_Null
(Data
.Loc
);
686 if For_Library
and then not Restricted_Profile
then
687 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
688 Actuals
:= New_List
(Except
);
691 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
693 -- The dereference occurs only when Exception_Extra_Info is true,
694 -- and therefore Except is not null.
698 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
699 Make_Explicit_Dereference
(Data
.Loc
, Except
));
705 -- if not Raised_Id then
706 -- Raised_Id := True;
708 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
710 -- Save_Library_Occurrence (Get_Current_Excep.all);
715 Make_If_Statement
(Data
.Loc
,
717 Make_Op_Not
(Data
.Loc
,
718 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
720 Then_Statements
=> New_List
(
721 Make_Assignment_Statement
(Data
.Loc
,
722 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
723 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
725 Make_Procedure_Call_Statement
(Data
.Loc
,
727 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
728 Parameter_Associations
=> Actuals
))));
733 -- Raised_Id := True;
736 Make_Assignment_Statement
(Data
.Loc
,
737 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
738 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
746 Make_Exception_Handler
(Data
.Loc
,
747 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
748 Statements
=> Stmts
);
749 end Build_Exception_Handler
;
751 -------------------------------
752 -- Build_Finalization_Master --
753 -------------------------------
755 procedure Build_Finalization_Master
757 Ins_Node
: Node_Id
:= Empty
;
758 Encl_Scope
: Entity_Id
:= Empty
)
760 Desig_Typ
: constant Entity_Id
:= Directly_Designated_Type
(Typ
);
761 Ptr_Typ
: Entity_Id
:= Root_Type
(Base_Type
(Typ
));
763 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
764 -- Determine whether entity E is inside a wrapper package created for
765 -- an instance of Ada.Unchecked_Deallocation.
767 ------------------------------
768 -- In_Deallocation_Instance --
769 ------------------------------
771 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
772 Pkg
: constant Entity_Id
:= Scope
(E
);
773 Par
: Node_Id
:= Empty
;
776 if Ekind
(Pkg
) = E_Package
777 and then Present
(Related_Instance
(Pkg
))
778 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
780 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
784 and then Chars
(Par
) = Name_Unchecked_Deallocation
785 and then Chars
(Scope
(Par
)) = Name_Ada
786 and then Scope
(Scope
(Par
)) = Standard_Standard
;
790 end In_Deallocation_Instance
;
792 -- Start of processing for Build_Finalization_Master
795 if Is_Private_Type
(Ptr_Typ
)
796 and then Present
(Full_View
(Ptr_Typ
))
798 Ptr_Typ
:= Full_View
(Ptr_Typ
);
801 -- Certain run-time configurations and targets do not provide support
802 -- for controlled types.
804 if Restriction_Active
(No_Finalization
) then
807 -- Do not process C, C++, CIL and Java types since it is assumend that
808 -- the non-Ada side will handle their clean up.
810 elsif Convention
(Desig_Typ
) = Convention_C
811 or else Convention
(Desig_Typ
) = Convention_CIL
812 or else Convention
(Desig_Typ
) = Convention_CPP
813 or else Convention
(Desig_Typ
) = Convention_Java
817 -- Various machinery such as freezing may have already created a
818 -- finalization master.
820 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
823 -- Do not process types that return on the secondary stack
825 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
826 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
830 -- Do not process types which may never allocate an object
832 elsif No_Pool_Assigned
(Ptr_Typ
) then
835 -- Do not process access types coming from Ada.Unchecked_Deallocation
836 -- instances. Even though the designated type may be controlled, the
837 -- access type will never participate in allocation.
839 elsif In_Deallocation_Instance
(Ptr_Typ
) then
842 -- Ignore the general use of anonymous access types unless the context
843 -- requires a finalization master.
845 elsif Ekind
(Ptr_Typ
) = E_Anonymous_Access_Type
846 and then No
(Ins_Node
)
850 -- Do not process non-library access types when restriction No_Nested_
851 -- Finalization is in effect since masters are controlled objects.
853 elsif Restriction_Active
(No_Nested_Finalization
)
854 and then not Is_Library_Level_Entity
(Ptr_Typ
)
858 -- For .NET/JVM targets, allow the processing of access-to-controlled
859 -- types where the designated type is explicitly derived from [Limited_]
862 elsif VM_Target
/= No_VM
863 and then not Is_Controlled
(Desig_Typ
)
867 -- Do not create finalization masters in SPARK mode because they result
868 -- in unwanted expansion.
870 -- More detail would be useful here ???
872 elsif GNATprove_Mode
then
877 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
878 Actions
: constant List_Id
:= New_List
;
879 Fin_Mas_Id
: Entity_Id
;
884 -- Fnn : aliased Finalization_Master;
886 -- Source access types use fixed master names since the master is
887 -- inserted in the same source unit only once. The only exception to
888 -- this are instances using the same access type as generic actual.
890 if Comes_From_Source
(Ptr_Typ
)
891 and then not Inside_A_Generic
894 Make_Defining_Identifier
(Loc
,
895 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
897 -- Internally generated access types use temporaries as their names
898 -- due to possible collision with identical names coming from other
902 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
906 Make_Object_Declaration
(Loc
,
907 Defining_Identifier
=> Fin_Mas_Id
,
908 Aliased_Present
=> True,
910 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
912 -- Storage pool selection and attribute decoration of the generated
913 -- master. Since .NET/JVM compilers do not support pools, this step
916 if VM_Target
= No_VM
then
918 -- If the access type has a user-defined pool, use it as the base
919 -- storage medium for the finalization pool.
921 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
922 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
924 -- The default choice is the global pool
927 Pool_Id
:= Get_Global_Pool_For_Access_Type
(Ptr_Typ
);
928 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
932 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
935 Make_Procedure_Call_Statement
(Loc
,
937 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
938 Parameter_Associations
=> New_List
(
939 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
940 Make_Attribute_Reference
(Loc
,
941 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
942 Attribute_Name
=> Name_Unrestricted_Access
))));
945 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
947 -- A finalization master created for an anonymous access type must be
948 -- inserted before a context-dependent node.
950 if Present
(Ins_Node
) then
951 Push_Scope
(Encl_Scope
);
953 -- Treat use clauses as declarations and insert directly in front
956 if Nkind_In
(Ins_Node
, N_Use_Package_Clause
,
959 Insert_List_Before_And_Analyze
(Ins_Node
, Actions
);
961 Insert_Actions
(Ins_Node
, Actions
);
966 elsif Ekind
(Desig_Typ
) = E_Incomplete_Type
967 and then Has_Completion_In_Body
(Desig_Typ
)
969 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
971 -- If the designated type is not yet frozen, then append the actions
972 -- to that type's freeze actions. The actions need to be appended to
973 -- whichever type is frozen later, similarly to what Freeze_Type does
974 -- for appending the storage pool declaration for an access type.
975 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
976 -- pool object before it's declared. However, it's not clear that
977 -- this is exactly the right test to accomplish that here. ???
979 elsif Present
(Freeze_Node
(Desig_Typ
))
980 and then not Analyzed
(Freeze_Node
(Desig_Typ
))
982 Append_Freeze_Actions
(Desig_Typ
, Actions
);
984 elsif Present
(Freeze_Node
(Ptr_Typ
))
985 and then not Analyzed
(Freeze_Node
(Ptr_Typ
))
987 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
989 -- If there's a pool created locally for the access type, then we
990 -- need to ensure that the master gets created after the pool object,
991 -- because otherwise we can have a forward reference, so we force the
992 -- master actions to be inserted and analyzed after the pool entity.
993 -- Note that both the access type and its designated type may have
994 -- already been frozen and had their freezing actions analyzed at
995 -- this point. (This seems a little unclean.???)
997 elsif VM_Target
= No_VM
998 and then Scope
(Pool_Id
) = Scope
(Ptr_Typ
)
1000 Insert_List_After_And_Analyze
(Parent
(Pool_Id
), Actions
);
1003 Insert_Actions
(Parent
(Ptr_Typ
), Actions
);
1006 end Build_Finalization_Master
;
1008 ---------------------
1009 -- Build_Finalizer --
1010 ---------------------
1012 procedure Build_Finalizer
1014 Clean_Stmts
: List_Id
;
1015 Mark_Id
: Entity_Id
;
1016 Top_Decls
: List_Id
;
1017 Defer_Abort
: Boolean;
1018 Fin_Id
: out Entity_Id
)
1020 Acts_As_Clean
: constant Boolean :=
1023 (Present
(Clean_Stmts
)
1024 and then Is_Non_Empty_List
(Clean_Stmts
));
1025 Exceptions_OK
: constant Boolean :=
1026 not Restriction_Active
(No_Exception_Propagation
);
1027 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1028 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1029 For_Package
: constant Boolean :=
1030 For_Package_Body
or else For_Package_Spec
;
1031 Loc
: constant Source_Ptr
:= Sloc
(N
);
1033 -- NOTE: Local variable declarations are conservative and do not create
1034 -- structures right from the start. Entities and lists are created once
1035 -- it has been established that N has at least one controlled object.
1037 Components_Built
: Boolean := False;
1038 -- A flag used to avoid double initialization of entities and lists. If
1039 -- the flag is set then the following variables have been initialized:
1045 Counter_Id
: Entity_Id
:= Empty
;
1046 Counter_Val
: Int
:= 0;
1047 -- Name and value of the state counter
1049 Decls
: List_Id
:= No_List
;
1050 -- Declarative region of N (if available). If N is a package declaration
1051 -- Decls denotes the visible declarations.
1053 Finalizer_Data
: Finalization_Exception_Data
;
1054 -- Data for the exception
1056 Finalizer_Decls
: List_Id
:= No_List
;
1057 -- Local variable declarations. This list holds the label declarations
1058 -- of all jump block alternatives as well as the declaration of the
1059 -- local exception occurence and the raised flag:
1060 -- E : Exception_Occurrence;
1061 -- Raised : Boolean := False;
1062 -- L<counter value> : label;
1064 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1065 -- Insertion point for the finalizer body. Depending on the context
1066 -- (Nkind of N) and the individual grouping of controlled objects, this
1067 -- node may denote a package declaration or body, package instantiation,
1068 -- block statement or a counter update statement.
1070 Finalizer_Stmts
: List_Id
:= No_List
;
1071 -- The statement list of the finalizer body. It contains the following:
1073 -- Abort_Defer; -- Added if abort is allowed
1074 -- <call to Prev_At_End> -- Added if exists
1075 -- <cleanup statements> -- Added if Acts_As_Clean
1076 -- <jump block> -- Added if Has_Ctrl_Objs
1077 -- <finalization statements> -- Added if Has_Ctrl_Objs
1078 -- <stack release> -- Added if Mark_Id exists
1079 -- Abort_Undefer; -- Added if abort is allowed
1081 Has_Ctrl_Objs
: Boolean := False;
1082 -- A general flag which denotes whether N has at least one controlled
1085 Has_Tagged_Types
: Boolean := False;
1086 -- A general flag which indicates whether N has at least one library-
1087 -- level tagged type declaration.
1089 HSS
: Node_Id
:= Empty
;
1090 -- The sequence of statements of N (if available)
1092 Jump_Alts
: List_Id
:= No_List
;
1093 -- Jump block alternatives. Depending on the value of the state counter,
1094 -- the control flow jumps to a sequence of finalization statements. This
1095 -- list contains the following:
1097 -- when <counter value> =>
1098 -- goto L<counter value>;
1100 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1101 -- Specific point in the finalizer statements where the jump block is
1104 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1105 -- The last controlled construct encountered when processing the top
1106 -- level lists of N. This can be a nested package, an instantiation or
1107 -- an object declaration.
1109 Prev_At_End
: Entity_Id
:= Empty
;
1110 -- The previous at end procedure of the handled statements block of N
1112 Priv_Decls
: List_Id
:= No_List
;
1113 -- The private declarations of N if N is a package declaration
1115 Spec_Id
: Entity_Id
:= Empty
;
1116 Spec_Decls
: List_Id
:= Top_Decls
;
1117 Stmts
: List_Id
:= No_List
;
1119 Tagged_Type_Stmts
: List_Id
:= No_List
;
1120 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1121 -- tagged types found in N.
1123 -----------------------
1124 -- Local subprograms --
1125 -----------------------
1127 procedure Build_Components
;
1128 -- Create all entites and initialize all lists used in the creation of
1131 procedure Create_Finalizer
;
1132 -- Create the spec and body of the finalizer and insert them in the
1133 -- proper place in the tree depending on the context.
1135 procedure Process_Declarations
1137 Preprocess
: Boolean := False;
1138 Top_Level
: Boolean := False);
1139 -- Inspect a list of declarations or statements which may contain
1140 -- objects that need finalization. When flag Preprocess is set, the
1141 -- routine will simply count the total number of controlled objects in
1142 -- Decls. Flag Top_Level denotes whether the processing is done for
1143 -- objects in nested package declarations or instances.
1145 procedure Process_Object_Declaration
1147 Has_No_Init
: Boolean := False;
1148 Is_Protected
: Boolean := False);
1149 -- Generate all the machinery associated with the finalization of a
1150 -- single object. Flag Has_No_Init is used to denote certain contexts
1151 -- where Decl does not have initialization call(s). Flag Is_Protected
1152 -- is set when Decl denotes a simple protected object.
1154 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1155 -- Generate all the code necessary to unregister the external tag of a
1158 ----------------------
1159 -- Build_Components --
1160 ----------------------
1162 procedure Build_Components
is
1163 Counter_Decl
: Node_Id
;
1164 Counter_Typ
: Entity_Id
;
1165 Counter_Typ_Decl
: Node_Id
;
1168 pragma Assert
(Present
(Decls
));
1170 -- This routine might be invoked several times when dealing with
1171 -- constructs that have two lists (either two declarative regions
1172 -- or declarations and statements). Avoid double initialization.
1174 if Components_Built
then
1178 Components_Built
:= True;
1180 if Has_Ctrl_Objs
then
1182 -- Create entities for the counter, its type, the local exception
1183 -- and the raised flag.
1185 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1186 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1188 Finalizer_Decls
:= New_List
;
1190 Build_Object_Declarations
1191 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1193 -- Since the total number of controlled objects is always known,
1194 -- build a subtype of Natural with precise bounds. This allows
1195 -- the backend to optimize the case statement. Generate:
1197 -- subtype Tnn is Natural range 0 .. Counter_Val;
1200 Make_Subtype_Declaration
(Loc
,
1201 Defining_Identifier
=> Counter_Typ
,
1202 Subtype_Indication
=>
1203 Make_Subtype_Indication
(Loc
,
1204 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1206 Make_Range_Constraint
(Loc
,
1210 Make_Integer_Literal
(Loc
, Uint_0
),
1212 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1214 -- Generate the declaration of the counter itself:
1216 -- Counter : Integer := 0;
1219 Make_Object_Declaration
(Loc
,
1220 Defining_Identifier
=> Counter_Id
,
1221 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1222 Expression
=> Make_Integer_Literal
(Loc
, 0));
1224 -- Set the type of the counter explicitly to prevent errors when
1225 -- examining object declarations later on.
1227 Set_Etype
(Counter_Id
, Counter_Typ
);
1229 -- The counter and its type are inserted before the source
1230 -- declarations of N.
1232 Prepend_To
(Decls
, Counter_Decl
);
1233 Prepend_To
(Decls
, Counter_Typ_Decl
);
1235 -- The counter and its associated type must be manually analized
1236 -- since N has already been analyzed. Use the scope of the spec
1237 -- when inserting in a package.
1240 Push_Scope
(Spec_Id
);
1241 Analyze
(Counter_Typ_Decl
);
1242 Analyze
(Counter_Decl
);
1246 Analyze
(Counter_Typ_Decl
);
1247 Analyze
(Counter_Decl
);
1250 Jump_Alts
:= New_List
;
1253 -- If the context requires additional clean up, the finalization
1254 -- machinery is added after the clean up code.
1256 if Acts_As_Clean
then
1257 Finalizer_Stmts
:= Clean_Stmts
;
1258 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1260 Finalizer_Stmts
:= New_List
;
1263 if Has_Tagged_Types
then
1264 Tagged_Type_Stmts
:= New_List
;
1266 end Build_Components
;
1268 ----------------------
1269 -- Create_Finalizer --
1270 ----------------------
1272 procedure Create_Finalizer
is
1273 Body_Id
: Entity_Id
;
1276 Jump_Block
: Node_Id
;
1278 Label_Id
: Entity_Id
;
1280 function New_Finalizer_Name
return Name_Id
;
1281 -- Create a fully qualified name of a package spec or body finalizer.
1282 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1284 ------------------------
1285 -- New_Finalizer_Name --
1286 ------------------------
1288 function New_Finalizer_Name
return Name_Id
is
1289 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1290 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1291 -- has a non-standard scope, process the scope first.
1293 ------------------------
1294 -- New_Finalizer_Name --
1295 ------------------------
1297 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1299 if Scope
(Id
) = Standard_Standard
then
1300 Get_Name_String
(Chars
(Id
));
1303 New_Finalizer_Name
(Scope
(Id
));
1304 Add_Str_To_Name_Buffer
("__");
1305 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1307 end New_Finalizer_Name
;
1309 -- Start of processing for New_Finalizer_Name
1312 -- Create the fully qualified name of the enclosing scope
1314 New_Finalizer_Name
(Spec_Id
);
1317 -- __finalize_[spec|body]
1319 Add_Str_To_Name_Buffer
("__finalize_");
1321 if For_Package_Spec
then
1322 Add_Str_To_Name_Buffer
("spec");
1324 Add_Str_To_Name_Buffer
("body");
1328 end New_Finalizer_Name
;
1330 -- Start of processing for Create_Finalizer
1333 -- Step 1: Creation of the finalizer name
1335 -- Packages must use a distinct name for their finalizers since the
1336 -- binder will have to generate calls to them by name. The name is
1337 -- of the following form:
1339 -- xx__yy__finalize_[spec|body]
1342 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1343 Set_Has_Qualified_Name
(Fin_Id
);
1344 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1346 -- The default name is _finalizer
1350 Make_Defining_Identifier
(Loc
,
1351 Chars
=> New_External_Name
(Name_uFinalizer
));
1353 -- The visibility semantics of AT_END handlers force a strange
1354 -- separation of spec and body for stack-related finalizers:
1356 -- declare : Enclosing_Scope
1357 -- procedure _finalizer;
1359 -- <controlled objects>
1360 -- procedure _finalizer is
1366 -- Both spec and body are within the same construct and scope, but
1367 -- the body is part of the handled sequence of statements. This
1368 -- placement confuses the elaboration mechanism on targets where
1369 -- AT_END handlers are expanded into "when all others" handlers:
1372 -- when all others =>
1373 -- _finalizer; -- appears to require elab checks
1378 -- Since the compiler guarantees that the body of a _finalizer is
1379 -- always inserted in the same construct where the AT_END handler
1380 -- resides, there is no need for elaboration checks.
1382 Set_Kill_Elaboration_Checks
(Fin_Id
);
1385 -- Step 2: Creation of the finalizer specification
1388 -- procedure Fin_Id;
1391 Make_Subprogram_Declaration
(Loc
,
1393 Make_Procedure_Specification
(Loc
,
1394 Defining_Unit_Name
=> Fin_Id
));
1396 -- Step 3: Creation of the finalizer body
1398 if Has_Ctrl_Objs
then
1400 -- Add L0, the default destination to the jump block
1402 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1403 Set_Entity
(Label_Id
,
1404 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1405 Label
:= Make_Label
(Loc
, Label_Id
);
1410 Prepend_To
(Finalizer_Decls
,
1411 Make_Implicit_Label_Declaration
(Loc
,
1412 Defining_Identifier
=> Entity
(Label_Id
),
1413 Label_Construct
=> Label
));
1419 Append_To
(Jump_Alts
,
1420 Make_Case_Statement_Alternative
(Loc
,
1421 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1422 Statements
=> New_List
(
1423 Make_Goto_Statement
(Loc
,
1424 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1429 Append_To
(Finalizer_Stmts
, Label
);
1431 -- Create the jump block which controls the finalization flow
1432 -- depending on the value of the state counter.
1435 Make_Case_Statement
(Loc
,
1436 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1437 Alternatives
=> Jump_Alts
);
1440 and then Present
(Jump_Block_Insert_Nod
)
1442 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1444 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1448 -- Add the library-level tagged type unregistration machinery before
1449 -- the jump block circuitry. This ensures that external tags will be
1450 -- removed even if a finalization exception occurs at some point.
1452 if Has_Tagged_Types
then
1453 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1456 -- Add a call to the previous At_End handler if it exists. The call
1457 -- must always precede the jump block.
1459 if Present
(Prev_At_End
) then
1460 Prepend_To
(Finalizer_Stmts
,
1461 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1463 -- Clear the At_End handler since we have already generated the
1464 -- proper replacement call for it.
1466 Set_At_End_Proc
(HSS
, Empty
);
1469 -- Release the secondary stack mark
1471 if Present
(Mark_Id
) then
1472 Append_To
(Finalizer_Stmts
,
1473 Make_Procedure_Call_Statement
(Loc
,
1475 New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
1476 Parameter_Associations
=> New_List
(
1477 New_Occurrence_Of
(Mark_Id
, Loc
))));
1480 -- Protect the statements with abort defer/undefer. This is only when
1481 -- aborts are allowed and the clean up statements require deferral or
1482 -- there are controlled objects to be finalized.
1486 (Defer_Abort
or else Has_Ctrl_Objs
)
1488 Prepend_To
(Finalizer_Stmts
,
1489 Make_Procedure_Call_Statement
(Loc
,
1490 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Defer
), Loc
)));
1492 Append_To
(Finalizer_Stmts
,
1493 Make_Procedure_Call_Statement
(Loc
,
1494 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Undefer
), Loc
)));
1497 -- The local exception does not need to be reraised for library-level
1498 -- finalizers. Note that this action must be carried out after object
1499 -- clean up, secondary stack release and abort undeferral. Generate:
1501 -- if Raised and then not Abort then
1502 -- Raise_From_Controlled_Operation (E);
1506 and then Exceptions_OK
1507 and then not For_Package
1509 Append_To
(Finalizer_Stmts
,
1510 Build_Raise_Statement
(Finalizer_Data
));
1514 -- procedure Fin_Id is
1515 -- Abort : constant Boolean := Triggered_By_Abort;
1517 -- Abort : constant Boolean := False; -- no abort
1519 -- E : Exception_Occurrence; -- All added if flag
1520 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1526 -- Abort_Defer; -- Added if abort is allowed
1527 -- <call to Prev_At_End> -- Added if exists
1528 -- <cleanup statements> -- Added if Acts_As_Clean
1529 -- <jump block> -- Added if Has_Ctrl_Objs
1530 -- <finalization statements> -- Added if Has_Ctrl_Objs
1531 -- <stack release> -- Added if Mark_Id exists
1532 -- Abort_Undefer; -- Added if abort is allowed
1533 -- <exception propagation> -- Added if Has_Ctrl_Objs
1536 -- Create the body of the finalizer
1538 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1541 Set_Has_Qualified_Name
(Body_Id
);
1542 Set_Has_Fully_Qualified_Name
(Body_Id
);
1546 Make_Subprogram_Body
(Loc
,
1548 Make_Procedure_Specification
(Loc
,
1549 Defining_Unit_Name
=> Body_Id
),
1550 Declarations
=> Finalizer_Decls
,
1551 Handled_Statement_Sequence
=>
1552 Make_Handled_Sequence_Of_Statements
(Loc
, Finalizer_Stmts
));
1554 -- Step 4: Spec and body insertion, analysis
1558 -- If the package spec has private declarations, the finalizer
1559 -- body must be added to the end of the list in order to have
1560 -- visibility of all private controlled objects.
1562 if For_Package_Spec
then
1563 if Present
(Priv_Decls
) then
1564 Append_To
(Priv_Decls
, Fin_Spec
);
1565 Append_To
(Priv_Decls
, Fin_Body
);
1567 Append_To
(Decls
, Fin_Spec
);
1568 Append_To
(Decls
, Fin_Body
);
1571 -- For package bodies, both the finalizer spec and body are
1572 -- inserted at the end of the package declarations.
1575 Append_To
(Decls
, Fin_Spec
);
1576 Append_To
(Decls
, Fin_Body
);
1579 -- Push the name of the package
1581 Push_Scope
(Spec_Id
);
1589 -- Create the spec for the finalizer. The At_End handler must be
1590 -- able to call the body which resides in a nested structure.
1594 -- procedure Fin_Id; -- Spec
1596 -- <objects and possibly statements>
1597 -- procedure Fin_Id is ... -- Body
1600 -- Fin_Id; -- At_End handler
1603 pragma Assert
(Present
(Spec_Decls
));
1605 Append_To
(Spec_Decls
, Fin_Spec
);
1608 -- When the finalizer acts solely as a clean up routine, the body
1609 -- is inserted right after the spec.
1612 and then not Has_Ctrl_Objs
1614 Insert_After
(Fin_Spec
, Fin_Body
);
1616 -- In all other cases the body is inserted after either:
1618 -- 1) The counter update statement of the last controlled object
1619 -- 2) The last top level nested controlled package
1620 -- 3) The last top level controlled instantiation
1623 -- Manually freeze the spec. This is somewhat of a hack because
1624 -- a subprogram is frozen when its body is seen and the freeze
1625 -- node appears right before the body. However, in this case,
1626 -- the spec must be frozen earlier since the At_End handler
1627 -- must be able to call it.
1630 -- procedure Fin_Id; -- Spec
1631 -- [Fin_Id] -- Freeze node
1635 -- Fin_Id; -- At_End handler
1638 Ensure_Freeze_Node
(Fin_Id
);
1639 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1640 Set_Is_Frozen
(Fin_Id
);
1642 -- In the case where the last construct to contain a controlled
1643 -- object is either a nested package, an instantiation or a
1644 -- freeze node, the body must be inserted directly after the
1647 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1649 N_Package_Declaration
,
1652 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1655 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1660 end Create_Finalizer
;
1662 --------------------------
1663 -- Process_Declarations --
1664 --------------------------
1666 procedure Process_Declarations
1668 Preprocess
: Boolean := False;
1669 Top_Level
: Boolean := False)
1674 Obj_Typ
: Entity_Id
;
1675 Pack_Id
: Entity_Id
;
1679 Old_Counter_Val
: Int
;
1680 -- This variable is used to determine whether a nested package or
1681 -- instance contains at least one controlled object.
1683 procedure Processing_Actions
1684 (Has_No_Init
: Boolean := False;
1685 Is_Protected
: Boolean := False);
1686 -- Depending on the mode of operation of Process_Declarations, either
1687 -- increment the controlled object counter, set the controlled object
1688 -- flag and store the last top level construct or process the current
1689 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1690 -- the current declaration may not have initialization proc(s). Flag
1691 -- Is_Protected should be set when the current declaration denotes a
1692 -- simple protected object.
1694 ------------------------
1695 -- Processing_Actions --
1696 ------------------------
1698 procedure Processing_Actions
1699 (Has_No_Init
: Boolean := False;
1700 Is_Protected
: Boolean := False)
1703 -- Library-level tagged type
1705 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1707 Has_Tagged_Types
:= True;
1710 and then No
(Last_Top_Level_Ctrl_Construct
)
1712 Last_Top_Level_Ctrl_Construct
:= Decl
;
1716 Process_Tagged_Type_Declaration
(Decl
);
1719 -- Controlled object declaration
1723 Counter_Val
:= Counter_Val
+ 1;
1724 Has_Ctrl_Objs
:= True;
1727 and then No
(Last_Top_Level_Ctrl_Construct
)
1729 Last_Top_Level_Ctrl_Construct
:= Decl
;
1733 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
1736 end Processing_Actions
;
1738 -- Start of processing for Process_Declarations
1741 if No
(Decls
) or else Is_Empty_List
(Decls
) then
1745 -- Process all declarations in reverse order
1747 Decl
:= Last_Non_Pragma
(Decls
);
1748 while Present
(Decl
) loop
1750 -- Library-level tagged types
1752 if Nkind
(Decl
) = N_Full_Type_Declaration
then
1753 Typ
:= Defining_Identifier
(Decl
);
1755 if Is_Tagged_Type
(Typ
)
1756 and then Is_Library_Level_Entity
(Typ
)
1757 and then Convention
(Typ
) = Convention_Ada
1758 and then Present
(Access_Disp_Table
(Typ
))
1759 and then RTE_Available
(RE_Register_Tag
)
1760 and then not No_Run_Time_Mode
1761 and then not Is_Abstract_Type
(Typ
)
1766 -- Regular object declarations
1768 elsif Nkind
(Decl
) = N_Object_Declaration
then
1769 Obj_Id
:= Defining_Identifier
(Decl
);
1770 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1771 Expr
:= Expression
(Decl
);
1773 -- Bypass any form of processing for objects which have their
1774 -- finalization disabled. This applies only to objects at the
1778 and then Finalize_Storage_Only
(Obj_Typ
)
1782 -- Transient variables are treated separately in order to
1783 -- minimize the size of the generated code. For details, see
1784 -- Process_Transient_Objects.
1786 elsif Is_Processed_Transient
(Obj_Id
) then
1789 -- The object is of the form:
1790 -- Obj : Typ [:= Expr];
1792 -- Do not process the incomplete view of a deferred constant.
1793 -- Do not consider tag-to-class-wide conversions.
1795 elsif not Is_Imported
(Obj_Id
)
1796 and then Needs_Finalization
(Obj_Typ
)
1797 and then not (Ekind
(Obj_Id
) = E_Constant
1798 and then not Has_Completion
(Obj_Id
))
1799 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
1803 -- The object is of the form:
1804 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1806 -- Obj : Access_Typ :=
1807 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1809 elsif Is_Access_Type
(Obj_Typ
)
1810 and then Needs_Finalization
1811 (Available_View
(Designated_Type
(Obj_Typ
)))
1812 and then Present
(Expr
)
1814 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
1816 (Is_Non_BIP_Func_Call
(Expr
)
1817 and then not Is_Related_To_Func_Return
(Obj_Id
)))
1819 Processing_Actions
(Has_No_Init
=> True);
1821 -- Processing for "hook" objects generated for controlled
1822 -- transients declared inside an Expression_With_Actions.
1824 elsif Is_Access_Type
(Obj_Typ
)
1825 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1826 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1827 N_Object_Declaration
1828 and then Is_Finalizable_Transient
1829 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Decl
)
1831 Processing_Actions
(Has_No_Init
=> True);
1833 -- Process intermediate results of an if expression with one
1834 -- of the alternatives using a controlled function call.
1836 elsif Is_Access_Type
(Obj_Typ
)
1837 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1838 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
1839 N_Defining_Identifier
1840 and then Present
(Expr
)
1841 and then Nkind
(Expr
) = N_Null
1843 Processing_Actions
(Has_No_Init
=> True);
1845 -- Simple protected objects which use type System.Tasking.
1846 -- Protected_Objects.Protection to manage their locks should
1847 -- be treated as controlled since they require manual cleanup.
1848 -- The only exception is illustrated in the following example:
1851 -- type Ctrl is new Controlled ...
1852 -- procedure Finalize (Obj : in out Ctrl);
1856 -- package body Pkg is
1857 -- protected Prot is
1858 -- procedure Do_Something (Obj : in out Ctrl);
1861 -- protected body Prot is
1862 -- procedure Do_Something (Obj : in out Ctrl) is ...
1865 -- procedure Finalize (Obj : in out Ctrl) is
1867 -- Prot.Do_Something (Obj);
1871 -- Since for the most part entities in package bodies depend on
1872 -- those in package specs, Prot's lock should be cleaned up
1873 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1874 -- This act however attempts to invoke Do_Something and fails
1875 -- because the lock has disappeared.
1877 elsif Ekind
(Obj_Id
) = E_Variable
1878 and then not In_Library_Level_Package_Body
(Obj_Id
)
1880 (Is_Simple_Protected_Type
(Obj_Typ
)
1881 or else Has_Simple_Protected_Object
(Obj_Typ
))
1883 Processing_Actions
(Is_Protected
=> True);
1886 -- Specific cases of object renamings
1888 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
1889 Obj_Id
:= Defining_Identifier
(Decl
);
1890 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
1892 -- Bypass any form of processing for objects which have their
1893 -- finalization disabled. This applies only to objects at the
1897 and then Finalize_Storage_Only
(Obj_Typ
)
1901 -- Return object of a build-in-place function. This case is
1902 -- recognized and marked by the expansion of an extended return
1903 -- statement (see Expand_N_Extended_Return_Statement).
1905 elsif Needs_Finalization
(Obj_Typ
)
1906 and then Is_Return_Object
(Obj_Id
)
1907 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
1909 Processing_Actions
(Has_No_Init
=> True);
1911 -- Detect a case where a source object has been initialized by
1912 -- a controlled function call or another object which was later
1913 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1915 -- Obj1 : CW_Type := Src_Obj;
1916 -- Obj2 : CW_Type := Function_Call (...);
1918 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1919 -- Tmp : ... := Function_Call (...)'reference;
1920 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1922 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
1923 Processing_Actions
(Has_No_Init
=> True);
1926 -- Inspect the freeze node of an access-to-controlled type and
1927 -- look for a delayed finalization master. This case arises when
1928 -- the freeze actions are inserted at a later time than the
1929 -- expansion of the context. Since Build_Finalizer is never called
1930 -- on a single construct twice, the master will be ultimately
1931 -- left out and never finalized. This is also needed for freeze
1932 -- actions of designated types themselves, since in some cases the
1933 -- finalization master is associated with a designated type's
1934 -- freeze node rather than that of the access type (see handling
1935 -- for freeze actions in Build_Finalization_Master).
1937 elsif Nkind
(Decl
) = N_Freeze_Entity
1938 and then Present
(Actions
(Decl
))
1940 Typ
:= Entity
(Decl
);
1942 if (Is_Access_Type
(Typ
)
1943 and then not Is_Access_Subprogram_Type
(Typ
)
1944 and then Needs_Finalization
1945 (Available_View
(Designated_Type
(Typ
))))
1946 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
1948 Old_Counter_Val
:= Counter_Val
;
1950 -- Freeze nodes are considered to be identical to packages
1951 -- and blocks in terms of nesting. The difference is that
1952 -- a finalization master created inside the freeze node is
1953 -- at the same nesting level as the node itself.
1955 Process_Declarations
(Actions
(Decl
), Preprocess
);
1957 -- The freeze node contains a finalization master
1961 and then No
(Last_Top_Level_Ctrl_Construct
)
1962 and then Counter_Val
> Old_Counter_Val
1964 Last_Top_Level_Ctrl_Construct
:= Decl
;
1968 -- Nested package declarations, avoid generics
1970 elsif Nkind
(Decl
) = N_Package_Declaration
then
1971 Spec
:= Specification
(Decl
);
1972 Pack_Id
:= Defining_Unit_Name
(Spec
);
1974 if Nkind
(Pack_Id
) = N_Defining_Program_Unit_Name
then
1975 Pack_Id
:= Defining_Identifier
(Pack_Id
);
1978 if Ekind
(Pack_Id
) /= E_Generic_Package
then
1979 Old_Counter_Val
:= Counter_Val
;
1980 Process_Declarations
1981 (Private_Declarations
(Spec
), Preprocess
);
1982 Process_Declarations
1983 (Visible_Declarations
(Spec
), Preprocess
);
1985 -- Either the visible or the private declarations contain a
1986 -- controlled object. The nested package declaration is the
1987 -- last such construct.
1991 and then No
(Last_Top_Level_Ctrl_Construct
)
1992 and then Counter_Val
> Old_Counter_Val
1994 Last_Top_Level_Ctrl_Construct
:= Decl
;
1998 -- Nested package bodies, avoid generics
2000 elsif Nkind
(Decl
) = N_Package_Body
then
2001 Spec
:= Corresponding_Spec
(Decl
);
2003 if Ekind
(Spec
) /= E_Generic_Package
then
2004 Old_Counter_Val
:= Counter_Val
;
2005 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2007 -- The nested package body is the last construct to contain
2008 -- a controlled object.
2012 and then No
(Last_Top_Level_Ctrl_Construct
)
2013 and then Counter_Val
> Old_Counter_Val
2015 Last_Top_Level_Ctrl_Construct
:= Decl
;
2019 -- Handle a rare case caused by a controlled transient variable
2020 -- created as part of a record init proc. The variable is wrapped
2021 -- in a block, but the block is not associated with a transient
2024 elsif Nkind
(Decl
) = N_Block_Statement
2025 and then Inside_Init_Proc
2027 Old_Counter_Val
:= Counter_Val
;
2029 if Present
(Handled_Statement_Sequence
(Decl
)) then
2030 Process_Declarations
2031 (Statements
(Handled_Statement_Sequence
(Decl
)),
2035 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2037 -- Either the declaration or statement list of the block has a
2038 -- controlled object.
2042 and then No
(Last_Top_Level_Ctrl_Construct
)
2043 and then Counter_Val
> Old_Counter_Val
2045 Last_Top_Level_Ctrl_Construct
:= Decl
;
2048 -- Handle the case where the original context has been wrapped in
2049 -- a block to avoid interference between exception handlers and
2050 -- At_End handlers. Treat the block as transparent and process its
2053 elsif Nkind
(Decl
) = N_Block_Statement
2054 and then Is_Finalization_Wrapper
(Decl
)
2056 if Present
(Handled_Statement_Sequence
(Decl
)) then
2057 Process_Declarations
2058 (Statements
(Handled_Statement_Sequence
(Decl
)),
2062 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2065 Prev_Non_Pragma
(Decl
);
2067 end Process_Declarations
;
2069 --------------------------------
2070 -- Process_Object_Declaration --
2071 --------------------------------
2073 procedure Process_Object_Declaration
2075 Has_No_Init
: Boolean := False;
2076 Is_Protected
: Boolean := False)
2078 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2079 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2081 Count_Ins
: Node_Id
;
2083 Fin_Stmts
: List_Id
;
2086 Label_Id
: Entity_Id
;
2088 Obj_Typ
: Entity_Id
;
2090 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2091 -- Once it has been established that the current object is in fact a
2092 -- return object of build-in-place function Func_Id, generate the
2093 -- following cleanup code:
2095 -- if BIPallocfrom > Secondary_Stack'Pos
2096 -- and then BIPfinalizationmaster /= null
2099 -- type Ptr_Typ is access Obj_Typ;
2100 -- for Ptr_Typ'Storage_Pool
2101 -- use Base_Pool (BIPfinalizationmaster);
2103 -- Free (Ptr_Typ (Temp));
2107 -- Obj_Typ is the type of the current object, Temp is the original
2108 -- allocation which Obj_Id renames.
2110 procedure Find_Last_Init
2113 Last_Init
: out Node_Id
;
2114 Body_Insert
: out Node_Id
);
2115 -- An object declaration has at least one and at most two init calls:
2116 -- that of the type and the user-defined initialize. Given an object
2117 -- declaration, Last_Init denotes the last initialization call which
2118 -- follows the declaration. Body_Insert denotes the place where the
2119 -- finalizer body could be potentially inserted.
2121 -----------------------------
2122 -- Build_BIP_Cleanup_Stmts --
2123 -----------------------------
2125 function Build_BIP_Cleanup_Stmts
2126 (Func_Id
: Entity_Id
) return Node_Id
2128 Decls
: constant List_Id
:= New_List
;
2129 Fin_Mas_Id
: constant Entity_Id
:=
2130 Build_In_Place_Formal
2131 (Func_Id
, BIP_Finalization_Master
);
2132 Obj_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2133 Temp_Id
: constant Entity_Id
:=
2134 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2138 Free_Stmt
: Node_Id
;
2139 Pool_Id
: Entity_Id
;
2140 Ptr_Typ
: Entity_Id
;
2144 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2146 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2149 Make_Object_Renaming_Declaration
(Loc
,
2150 Defining_Identifier
=> Pool_Id
,
2152 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2154 Make_Explicit_Dereference
(Loc
,
2156 Make_Function_Call
(Loc
,
2158 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2159 Parameter_Associations
=> New_List
(
2160 Make_Explicit_Dereference
(Loc
,
2162 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2164 -- Create an access type which uses the storage pool of the
2165 -- caller's finalization master.
2168 -- type Ptr_Typ is access Obj_Typ;
2170 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2173 Make_Full_Type_Declaration
(Loc
,
2174 Defining_Identifier
=> Ptr_Typ
,
2176 Make_Access_To_Object_Definition
(Loc
,
2177 Subtype_Indication
=> New_Occurrence_Of
(Obj_Typ
, Loc
))));
2179 -- Perform minor decoration in order to set the master and the
2180 -- storage pool attributes.
2182 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2183 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2184 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2186 -- Create an explicit free statement. Note that the free uses the
2187 -- caller's pool expressed as a renaming.
2190 Make_Free_Statement
(Loc
,
2192 Unchecked_Convert_To
(Ptr_Typ
,
2193 New_Occurrence_Of
(Temp_Id
, Loc
)));
2195 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2197 -- Create a block to house the dummy type and the instantiation as
2198 -- well as to perform the cleanup the temporary.
2204 -- Free (Ptr_Typ (Temp_Id));
2208 Make_Block_Statement
(Loc
,
2209 Declarations
=> Decls
,
2210 Handled_Statement_Sequence
=>
2211 Make_Handled_Sequence_Of_Statements
(Loc
,
2212 Statements
=> New_List
(Free_Stmt
)));
2215 -- if BIPfinalizationmaster /= null then
2219 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2220 Right_Opnd
=> Make_Null
(Loc
));
2222 -- For constrained or tagged results escalate the condition to
2223 -- include the allocation format. Generate:
2225 -- if BIPallocform > Secondary_Stack'Pos
2226 -- and then BIPfinalizationmaster /= null
2229 if not Is_Constrained
(Obj_Typ
)
2230 or else Is_Tagged_Type
(Obj_Typ
)
2233 Alloc
: constant Entity_Id
:=
2234 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2240 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2242 Make_Integer_Literal
(Loc
,
2244 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2246 Right_Opnd
=> Cond
);
2256 Make_If_Statement
(Loc
,
2258 Then_Statements
=> New_List
(Free_Blk
));
2259 end Build_BIP_Cleanup_Stmts
;
2261 --------------------
2262 -- Find_Last_Init --
2263 --------------------
2265 procedure Find_Last_Init
2268 Last_Init
: out Node_Id
;
2269 Body_Insert
: out Node_Id
)
2271 Nod_1
: Node_Id
:= Empty
;
2272 Nod_2
: Node_Id
:= Empty
;
2275 function Is_Init_Call
2277 Typ
: Entity_Id
) return Boolean;
2278 -- Given an arbitrary node, determine whether N is a procedure
2279 -- call and if it is, try to match the name of the call with the
2280 -- [Deep_]Initialize proc of Typ.
2282 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2283 -- Given a statement which is part of a list, return the next
2284 -- real statement while skipping over dynamic elab checks.
2290 function Is_Init_Call
2292 Typ
: Entity_Id
) return Boolean
2295 -- A call to [Deep_]Initialize is always direct
2297 if Nkind
(N
) = N_Procedure_Call_Statement
2298 and then Nkind
(Name
(N
)) = N_Identifier
2301 Call_Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2302 Deep_Init
: constant Entity_Id
:=
2303 TSS
(Typ
, TSS_Deep_Initialize
);
2304 Init
: Entity_Id
:= Empty
;
2307 -- A type may have controlled components but not be
2310 if Is_Controlled
(Typ
) then
2311 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
2313 if Present
(Init
) then
2314 Init
:= Ultimate_Alias
(Init
);
2319 (Present
(Deep_Init
) and then Call_Ent
= Deep_Init
)
2321 (Present
(Init
) and then Call_Ent
= Init
);
2328 -----------------------------
2329 -- Next_Suitable_Statement --
2330 -----------------------------
2332 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2333 Result
: Node_Id
:= Next
(Stmt
);
2336 -- Skip over access-before-elaboration checks
2338 if Dynamic_Elaboration_Checks
2339 and then Nkind
(Result
) = N_Raise_Program_Error
2341 Result
:= Next
(Result
);
2345 end Next_Suitable_Statement
;
2347 -- Start of processing for Find_Last_Init
2351 Body_Insert
:= Empty
;
2353 -- Object renamings and objects associated with controlled
2354 -- function results do not have initialization calls.
2360 if Is_Concurrent_Type
(Typ
) then
2361 Utyp
:= Corresponding_Record_Type
(Typ
);
2366 if Is_Private_Type
(Utyp
)
2367 and then Present
(Full_View
(Utyp
))
2369 Utyp
:= Full_View
(Utyp
);
2372 -- The init procedures are arranged as follows:
2374 -- Object : Controlled_Type;
2375 -- Controlled_TypeIP (Object);
2376 -- [[Deep_]Initialize (Object);]
2378 -- where the user-defined initialize may be optional or may appear
2379 -- inside a block when abort deferral is needed.
2381 Nod_1
:= Next_Suitable_Statement
(Decl
);
2382 if Present
(Nod_1
) then
2383 Nod_2
:= Next_Suitable_Statement
(Nod_1
);
2385 -- The statement following an object declaration is always a
2386 -- call to the type init proc.
2391 -- Optional user-defined init or deep init processing
2393 if Present
(Nod_2
) then
2395 -- The statement following the type init proc may be a block
2396 -- statement in cases where abort deferral is required.
2398 if Nkind
(Nod_2
) = N_Block_Statement
then
2400 HSS
: constant Node_Id
:=
2401 Handled_Statement_Sequence
(Nod_2
);
2406 and then Present
(Statements
(HSS
))
2408 Stmt
:= First
(Statements
(HSS
));
2410 -- Examine individual block statements and locate the
2411 -- call to [Deep_]Initialze.
2413 while Present
(Stmt
) loop
2414 if Is_Init_Call
(Stmt
, Utyp
) then
2416 Body_Insert
:= Nod_2
;
2426 elsif Is_Init_Call
(Nod_2
, Utyp
) then
2432 -- Start of processing for Process_Object_Declaration
2435 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2436 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2438 -- Handle access types
2440 if Is_Access_Type
(Obj_Typ
) then
2441 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2442 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2445 Set_Etype
(Obj_Ref
, Obj_Typ
);
2447 -- Set a new value for the state counter and insert the statement
2448 -- after the object declaration. Generate:
2450 -- Counter := <value>;
2453 Make_Assignment_Statement
(Loc
,
2454 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2455 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2457 -- Insert the counter after all initialization has been done. The
2458 -- place of insertion depends on the context. If an object is being
2459 -- initialized via an aggregate, then the counter must be inserted
2460 -- after the last aggregate assignment.
2462 if Ekind
(Obj_Id
) = E_Variable
2463 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
2465 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2468 -- In all other cases the counter is inserted after the last call to
2469 -- either [Deep_]Initialize or the type specific init proc.
2472 Find_Last_Init
(Decl
, Obj_Typ
, Count_Ins
, Body_Ins
);
2475 Insert_After
(Count_Ins
, Inc_Decl
);
2478 -- If the current declaration is the last in the list, the finalizer
2479 -- body needs to be inserted after the set counter statement for the
2480 -- current object declaration. This is complicated by the fact that
2481 -- the set counter statement may appear in abort deferred block. In
2482 -- that case, the proper insertion place is after the block.
2484 if No
(Finalizer_Insert_Nod
) then
2486 -- Insertion after an abort deffered block
2488 if Present
(Body_Ins
) then
2489 Finalizer_Insert_Nod
:= Body_Ins
;
2491 Finalizer_Insert_Nod
:= Inc_Decl
;
2495 -- Create the associated label with this object, generate:
2497 -- L<counter> : label;
2500 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2502 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2503 Label
:= Make_Label
(Loc
, Label_Id
);
2505 Prepend_To
(Finalizer_Decls
,
2506 Make_Implicit_Label_Declaration
(Loc
,
2507 Defining_Identifier
=> Entity
(Label_Id
),
2508 Label_Construct
=> Label
));
2510 -- Create the associated jump with this object, generate:
2512 -- when <counter> =>
2515 Prepend_To
(Jump_Alts
,
2516 Make_Case_Statement_Alternative
(Loc
,
2517 Discrete_Choices
=> New_List
(
2518 Make_Integer_Literal
(Loc
, Counter_Val
)),
2519 Statements
=> New_List
(
2520 Make_Goto_Statement
(Loc
,
2521 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
2523 -- Insert the jump destination, generate:
2527 Append_To
(Finalizer_Stmts
, Label
);
2529 -- Processing for simple protected objects. Such objects require
2530 -- manual finalization of their lock managers.
2532 if Is_Protected
then
2533 Fin_Stmts
:= No_List
;
2535 if Is_Simple_Protected_Type
(Obj_Typ
) then
2536 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
2538 if Present
(Fin_Call
) then
2539 Fin_Stmts
:= New_List
(Fin_Call
);
2542 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
2543 if Is_Record_Type
(Obj_Typ
) then
2544 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
2545 elsif Is_Array_Type
(Obj_Typ
) then
2546 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
2552 -- System.Tasking.Protected_Objects.Finalize_Protection
2560 if Present
(Fin_Stmts
) then
2561 Append_To
(Finalizer_Stmts
,
2562 Make_Block_Statement
(Loc
,
2563 Handled_Statement_Sequence
=>
2564 Make_Handled_Sequence_Of_Statements
(Loc
,
2565 Statements
=> Fin_Stmts
,
2567 Exception_Handlers
=> New_List
(
2568 Make_Exception_Handler
(Loc
,
2569 Exception_Choices
=> New_List
(
2570 Make_Others_Choice
(Loc
)),
2572 Statements
=> New_List
(
2573 Make_Null_Statement
(Loc
)))))));
2576 -- Processing for regular controlled objects
2580 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2582 -- begin -- Exception handlers allowed
2583 -- [Deep_]Finalize (Obj);
2586 -- when Id : others =>
2587 -- if not Raised then
2589 -- Save_Occurrence (E, Id);
2598 -- For CodePeer, the exception handlers normally generated here
2599 -- generate complex flowgraphs which result in capacity problems.
2600 -- Omitting these handlers for CodePeer is justified as follows:
2602 -- If a handler is dead, then omitting it is surely ok
2604 -- If a handler is live, then CodePeer should flag the
2605 -- potentially-exception-raising construct that causes it
2606 -- to be live. That is what we are interested in, not what
2607 -- happens after the exception is raised.
2609 if Exceptions_OK
and not CodePeer_Mode
then
2610 Fin_Stmts
:= New_List
(
2611 Make_Block_Statement
(Loc
,
2612 Handled_Statement_Sequence
=>
2613 Make_Handled_Sequence_Of_Statements
(Loc
,
2614 Statements
=> New_List
(Fin_Call
),
2616 Exception_Handlers
=> New_List
(
2617 Build_Exception_Handler
2618 (Finalizer_Data
, For_Package
)))));
2620 -- When exception handlers are prohibited, the finalization call
2621 -- appears unprotected. Any exception raised during finalization
2622 -- will bypass the circuitry which ensures the cleanup of all
2623 -- remaining objects.
2626 Fin_Stmts
:= New_List
(Fin_Call
);
2629 -- If we are dealing with a return object of a build-in-place
2630 -- function, generate the following cleanup statements:
2632 -- if BIPallocfrom > Secondary_Stack'Pos
2633 -- and then BIPfinalizationmaster /= null
2636 -- type Ptr_Typ is access Obj_Typ;
2637 -- for Ptr_Typ'Storage_Pool use
2638 -- Base_Pool (BIPfinalizationmaster.all).all;
2640 -- Free (Ptr_Typ (Temp));
2644 -- The generated code effectively detaches the temporary from the
2645 -- caller finalization master and deallocates the object. This is
2646 -- disabled on .NET/JVM because pools are not supported.
2648 if VM_Target
= No_VM
and then Is_Return_Object
(Obj_Id
) then
2650 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
2652 if Is_Build_In_Place_Function
(Func_Id
)
2653 and then Needs_BIP_Finalization_Master
(Func_Id
)
2655 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
2660 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2661 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2663 -- Temporaries created for the purpose of "exporting" a
2664 -- controlled transient out of an Expression_With_Actions (EWA)
2665 -- need guards. The following illustrates the usage of such
2668 -- Access_Typ : access [all] Obj_Typ;
2669 -- Temp : Access_Typ := null;
2670 -- <Counter> := ...;
2673 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2674 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2676 -- Temp := Ctrl_Trans'Unchecked_Access;
2679 -- The finalization machinery does not process EWA nodes as
2680 -- this may lead to premature finalization of expressions. Note
2681 -- that Temp is marked as being properly initialized regardless
2682 -- of whether the initialization of Ctrl_Trans succeeded. Since
2683 -- a failed initialization may leave Temp with a value of null,
2684 -- add a guard to handle this case:
2686 -- if Obj /= null then
2687 -- <object finalization statements>
2690 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2691 N_Object_Declaration
2693 Fin_Stmts
:= New_List
(
2694 Make_If_Statement
(Loc
,
2697 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
2698 Right_Opnd
=> Make_Null
(Loc
)),
2699 Then_Statements
=> Fin_Stmts
));
2701 -- Return objects use a flag to aid in processing their
2702 -- potential finalization when the enclosing function fails
2703 -- to return properly. Generate:
2706 -- <object finalization statements>
2710 Fin_Stmts
:= New_List
(
2711 Make_If_Statement
(Loc
,
2716 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
2718 Then_Statements
=> Fin_Stmts
));
2723 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
2725 -- Since the declarations are examined in reverse, the state counter
2726 -- must be decremented in order to keep with the true position of
2729 Counter_Val
:= Counter_Val
- 1;
2730 end Process_Object_Declaration
;
2732 -------------------------------------
2733 -- Process_Tagged_Type_Declaration --
2734 -------------------------------------
2736 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
2737 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2738 DT_Ptr
: constant Entity_Id
:=
2739 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2742 -- Ada.Tags.Unregister_Tag (<Typ>P);
2744 Append_To
(Tagged_Type_Stmts
,
2745 Make_Procedure_Call_Statement
(Loc
,
2747 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
2748 Parameter_Associations
=> New_List
(
2749 New_Occurrence_Of
(DT_Ptr
, Loc
))));
2750 end Process_Tagged_Type_Declaration
;
2752 -- Start of processing for Build_Finalizer
2757 -- Do not perform this expansion in SPARK mode because it is not
2760 if GNATprove_Mode
then
2764 -- Step 1: Extract all lists which may contain controlled objects or
2765 -- library-level tagged types.
2767 if For_Package_Spec
then
2768 Decls
:= Visible_Declarations
(Specification
(N
));
2769 Priv_Decls
:= Private_Declarations
(Specification
(N
));
2771 -- Retrieve the package spec id
2773 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
2775 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
2776 Spec_Id
:= Defining_Identifier
(Spec_Id
);
2779 -- Accept statement, block, entry body, package body, protected body,
2780 -- subprogram body or task body.
2783 Decls
:= Declarations
(N
);
2784 HSS
:= Handled_Statement_Sequence
(N
);
2786 if Present
(HSS
) then
2787 if Present
(Statements
(HSS
)) then
2788 Stmts
:= Statements
(HSS
);
2791 if Present
(At_End_Proc
(HSS
)) then
2792 Prev_At_End
:= At_End_Proc
(HSS
);
2796 -- Retrieve the package spec id for package bodies
2798 if For_Package_Body
then
2799 Spec_Id
:= Corresponding_Spec
(N
);
2803 -- Do not process nested packages since those are handled by the
2804 -- enclosing scope's finalizer. Do not process non-expanded package
2805 -- instantiations since those will be re-analyzed and re-expanded.
2809 (not Is_Library_Level_Entity
(Spec_Id
)
2811 -- Nested packages are considered to be library level entities,
2812 -- but do not need to be processed separately. True library level
2813 -- packages have a scope value of 1.
2815 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
2816 or else (Is_Generic_Instance
(Spec_Id
)
2817 and then Package_Instantiation
(Spec_Id
) /= N
))
2822 -- Step 2: Object [pre]processing
2826 -- Preprocess the visible declarations now in order to obtain the
2827 -- correct number of controlled object by the time the private
2828 -- declarations are processed.
2830 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2832 -- From all the possible contexts, only package specifications may
2833 -- have private declarations.
2835 if For_Package_Spec
then
2836 Process_Declarations
2837 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
2840 -- The current context may lack controlled objects, but require some
2841 -- other form of completion (task termination for instance). In such
2842 -- cases, the finalizer must be created and carry the additional
2845 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2849 -- The preprocessing has determined that the context has controlled
2850 -- objects or library-level tagged types.
2852 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2854 -- Private declarations are processed first in order to preserve
2855 -- possible dependencies between public and private objects.
2857 if For_Package_Spec
then
2858 Process_Declarations
(Priv_Decls
);
2861 Process_Declarations
(Decls
);
2867 -- Preprocess both declarations and statements
2869 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
2870 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
2872 -- At this point it is known that N has controlled objects. Ensure
2873 -- that N has a declarative list since the finalizer spec will be
2876 if Has_Ctrl_Objs
and then No
(Decls
) then
2877 Set_Declarations
(N
, New_List
);
2878 Decls
:= Declarations
(N
);
2879 Spec_Decls
:= Decls
;
2882 -- The current context may lack controlled objects, but require some
2883 -- other form of completion (task termination for instance). In such
2884 -- cases, the finalizer must be created and carry the additional
2887 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2891 if Has_Ctrl_Objs
or Has_Tagged_Types
then
2892 Process_Declarations
(Stmts
);
2893 Process_Declarations
(Decls
);
2897 -- Step 3: Finalizer creation
2899 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
2902 end Build_Finalizer
;
2904 --------------------------
2905 -- Build_Finalizer_Call --
2906 --------------------------
2908 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
2909 Is_Prot_Body
: constant Boolean :=
2910 Nkind
(N
) = N_Subprogram_Body
2911 and then Is_Protected_Subprogram_Body
(N
);
2912 -- Determine whether N denotes the protected version of a subprogram
2913 -- which belongs to a protected type.
2915 Loc
: constant Source_Ptr
:= Sloc
(N
);
2919 -- Do not perform this expansion in SPARK mode because we do not create
2920 -- finalizers in the first place.
2922 if GNATprove_Mode
then
2926 -- The At_End handler should have been assimilated by the finalizer
2928 HSS
:= Handled_Statement_Sequence
(N
);
2929 pragma Assert
(No
(At_End_Proc
(HSS
)));
2931 -- If the construct to be cleaned up is a protected subprogram body, the
2932 -- finalizer call needs to be associated with the block which wraps the
2933 -- unprotected version of the subprogram. The following illustrates this
2936 -- procedure Prot_SubpP is
2937 -- procedure finalizer is
2939 -- Service_Entries (Prot_Obj);
2946 -- Prot_SubpN (Prot_Obj);
2952 if Is_Prot_Body
then
2953 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
2955 -- An At_End handler and regular exception handlers cannot coexist in
2956 -- the same statement sequence. Wrap the original statements in a block.
2958 elsif Present
(Exception_Handlers
(HSS
)) then
2960 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
2965 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
2967 Set_Handled_Statement_Sequence
(N
,
2968 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
2970 HSS
:= Handled_Statement_Sequence
(N
);
2971 Set_End_Label
(HSS
, End_Lab
);
2975 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
2977 Analyze
(At_End_Proc
(HSS
));
2978 Expand_At_End_Handler
(HSS
, Empty
);
2979 end Build_Finalizer_Call
;
2981 ---------------------
2982 -- Build_Late_Proc --
2983 ---------------------
2985 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
2987 for Final_Prim
in Name_Of
'Range loop
2988 if Name_Of
(Final_Prim
) = Nam
then
2991 (Prim
=> Final_Prim
,
2993 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
2996 end Build_Late_Proc
;
2998 -------------------------------
2999 -- Build_Object_Declarations --
3000 -------------------------------
3002 procedure Build_Object_Declarations
3003 (Data
: out Finalization_Exception_Data
;
3006 For_Package
: Boolean := False)
3012 pragma Assert
(Decls
/= No_List
);
3014 -- Always set the proper location as it may be needed even when
3015 -- exception propagation is forbidden.
3019 if Restriction_Active
(No_Exception_Propagation
) then
3020 Data
.Abort_Id
:= Empty
;
3022 Data
.Raised_Id
:= Empty
;
3026 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3028 -- In certain scenarios, finalization can be triggered by an abort. If
3029 -- the finalization itself fails and raises an exception, the resulting
3030 -- Program_Error must be supressed and replaced by an abort signal. In
3031 -- order to detect this scenario, save the state of entry into the
3032 -- finalization code.
3034 -- No need to do this for VM case, since VM version of Ada.Exceptions
3035 -- does not include routine Raise_From_Controlled_Operation which is the
3036 -- the sole user of flag Abort.
3038 -- This is not needed for library-level finalizers as they are called
3039 -- by the environment task and cannot be aborted.
3042 and then VM_Target
= No_VM
3043 and then not For_Package
3045 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3047 A_Expr
:= New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
);
3051 -- Abort_Id : constant Boolean := <A_Expr>;
3054 Make_Object_Declaration
(Loc
,
3055 Defining_Identifier
=> Data
.Abort_Id
,
3056 Constant_Present
=> True,
3057 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3058 Expression
=> A_Expr
));
3061 -- No abort, .NET/JVM or library-level finalizers
3063 Data
.Abort_Id
:= Empty
;
3066 if Exception_Extra_Info
then
3067 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3071 -- E_Id : Exception_Occurrence;
3074 Make_Object_Declaration
(Loc
,
3075 Defining_Identifier
=> Data
.E_Id
,
3076 Object_Definition
=>
3077 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3078 Set_No_Initialization
(E_Decl
);
3080 Append_To
(Decls
, E_Decl
);
3088 -- Raised_Id : Boolean := False;
3091 Make_Object_Declaration
(Loc
,
3092 Defining_Identifier
=> Data
.Raised_Id
,
3093 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3094 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3095 end Build_Object_Declarations
;
3097 ---------------------------
3098 -- Build_Raise_Statement --
3099 ---------------------------
3101 function Build_Raise_Statement
3102 (Data
: Finalization_Exception_Data
) return Node_Id
3108 -- Standard run-time and .NET/JVM targets use the specialized routine
3109 -- Raise_From_Controlled_Operation.
3111 if Exception_Extra_Info
3112 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3115 Make_Procedure_Call_Statement
(Data
.Loc
,
3118 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3119 Parameter_Associations
=>
3120 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3122 -- Restricted run-time: exception messages are not supported and hence
3123 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3128 Make_Raise_Program_Error
(Data
.Loc
,
3129 Reason
=> PE_Finalize_Raised_Exception
);
3134 -- Raised_Id and then not Abort_Id
3138 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3140 if Present
(Data
.Abort_Id
) then
3141 Expr
:= Make_And_Then
(Data
.Loc
,
3144 Make_Op_Not
(Data
.Loc
,
3145 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3150 -- if Raised_Id and then not Abort_Id then
3151 -- Raise_From_Controlled_Operation (E_Id);
3153 -- raise Program_Error; -- restricted runtime
3157 Make_If_Statement
(Data
.Loc
,
3159 Then_Statements
=> New_List
(Stmt
));
3160 end Build_Raise_Statement
;
3162 -----------------------------
3163 -- Build_Record_Deep_Procs --
3164 -----------------------------
3166 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3170 (Prim
=> Initialize_Case
,
3172 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3174 if not Is_Limited_View
(Typ
) then
3177 (Prim
=> Adjust_Case
,
3179 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3182 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3183 -- suppressed since these routine will not be used.
3185 if not Restriction_Active
(No_Finalization
) then
3188 (Prim
=> Finalize_Case
,
3190 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3192 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3193 -- .NET do not support address arithmetic and unchecked conversions.
3195 if VM_Target
= No_VM
then
3198 (Prim
=> Address_Case
,
3200 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3203 end Build_Record_Deep_Procs
;
3209 function Cleanup_Array
3212 Typ
: Entity_Id
) return List_Id
3214 Loc
: constant Source_Ptr
:= Sloc
(N
);
3215 Index_List
: constant List_Id
:= New_List
;
3217 function Free_Component
return List_Id
;
3218 -- Generate the code to finalize the task or protected subcomponents
3219 -- of a single component of the array.
3221 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3222 -- Generate a loop over one dimension of the array
3224 --------------------
3225 -- Free_Component --
3226 --------------------
3228 function Free_Component
return List_Id
is
3229 Stmts
: List_Id
:= New_List
;
3231 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3234 -- Component type is known to contain tasks or protected objects
3237 Make_Indexed_Component
(Loc
,
3238 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3239 Expressions
=> Index_List
);
3241 Set_Etype
(Tsk
, C_Typ
);
3243 if Is_Task_Type
(C_Typ
) then
3244 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3246 elsif Is_Simple_Protected_Type
(C_Typ
) then
3247 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3249 elsif Is_Record_Type
(C_Typ
) then
3250 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3252 elsif Is_Array_Type
(C_Typ
) then
3253 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3259 ------------------------
3260 -- Free_One_Dimension --
3261 ------------------------
3263 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3267 if Dim
> Number_Dimensions
(Typ
) then
3268 return Free_Component
;
3270 -- Here we generate the required loop
3273 Index
:= Make_Temporary
(Loc
, 'J');
3274 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3277 Make_Implicit_Loop_Statement
(N
,
3278 Identifier
=> Empty
,
3280 Make_Iteration_Scheme
(Loc
,
3281 Loop_Parameter_Specification
=>
3282 Make_Loop_Parameter_Specification
(Loc
,
3283 Defining_Identifier
=> Index
,
3284 Discrete_Subtype_Definition
=>
3285 Make_Attribute_Reference
(Loc
,
3286 Prefix
=> Duplicate_Subexpr
(Obj
),
3287 Attribute_Name
=> Name_Range
,
3288 Expressions
=> New_List
(
3289 Make_Integer_Literal
(Loc
, Dim
))))),
3290 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3292 end Free_One_Dimension
;
3294 -- Start of processing for Cleanup_Array
3297 return Free_One_Dimension
(1);
3300 --------------------
3301 -- Cleanup_Record --
3302 --------------------
3304 function Cleanup_Record
3307 Typ
: Entity_Id
) return List_Id
3309 Loc
: constant Source_Ptr
:= Sloc
(N
);
3312 Stmts
: constant List_Id
:= New_List
;
3313 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3316 if Has_Discriminants
(U_Typ
)
3317 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3319 Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3322 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3324 -- For now, do not attempt to free a component that may appear in a
3325 -- variant, and instead issue a warning. Doing this "properly" would
3326 -- require building a case statement and would be quite a mess. Note
3327 -- that the RM only requires that free "work" for the case of a task
3328 -- access value, so already we go way beyond this in that we deal
3329 -- with the array case and non-discriminated record cases.
3332 ("task/protected object in variant record will not be freed??", N
);
3333 return New_List
(Make_Null_Statement
(Loc
));
3336 Comp
:= First_Component
(Typ
);
3337 while Present
(Comp
) loop
3338 if Has_Task
(Etype
(Comp
))
3339 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3342 Make_Selected_Component
(Loc
,
3343 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3344 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3345 Set_Etype
(Tsk
, Etype
(Comp
));
3347 if Is_Task_Type
(Etype
(Comp
)) then
3348 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3350 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3351 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3353 elsif Is_Record_Type
(Etype
(Comp
)) then
3355 -- Recurse, by generating the prefix of the argument to
3356 -- the eventual cleanup call.
3358 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3360 elsif Is_Array_Type
(Etype
(Comp
)) then
3361 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3365 Next_Component
(Comp
);
3371 ------------------------------
3372 -- Cleanup_Protected_Object --
3373 ------------------------------
3375 function Cleanup_Protected_Object
3377 Ref
: Node_Id
) return Node_Id
3379 Loc
: constant Source_Ptr
:= Sloc
(N
);
3382 -- For restricted run-time libraries (Ravenscar), tasks are
3383 -- non-terminating, and protected objects can only appear at library
3384 -- level, so we do not want finalization of protected objects.
3386 if Restricted_Profile
then
3391 Make_Procedure_Call_Statement
(Loc
,
3393 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3394 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3396 end Cleanup_Protected_Object
;
3402 function Cleanup_Task
3404 Ref
: Node_Id
) return Node_Id
3406 Loc
: constant Source_Ptr
:= Sloc
(N
);
3409 -- For restricted run-time libraries (Ravenscar), tasks are
3410 -- non-terminating and they can only appear at library level, so we do
3411 -- not want finalization of task objects.
3413 if Restricted_Profile
then
3418 Make_Procedure_Call_Statement
(Loc
,
3420 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3421 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3425 ------------------------------
3426 -- Check_Visibly_Controlled --
3427 ------------------------------
3429 procedure Check_Visibly_Controlled
3430 (Prim
: Final_Primitives
;
3432 E
: in out Entity_Id
;
3433 Cref
: in out Node_Id
)
3435 Parent_Type
: Entity_Id
;
3439 if Is_Derived_Type
(Typ
)
3440 and then Comes_From_Source
(E
)
3441 and then not Present
(Overridden_Operation
(E
))
3443 -- We know that the explicit operation on the type does not override
3444 -- the inherited operation of the parent, and that the derivation
3445 -- is from a private type that is not visibly controlled.
3447 Parent_Type
:= Etype
(Typ
);
3448 Op
:= Find_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3450 if Present
(Op
) then
3453 -- Wrap the object to be initialized into the proper
3454 -- unchecked conversion, to be compatible with the operation
3457 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3458 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3460 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3464 end Check_Visibly_Controlled
;
3466 -------------------------------
3467 -- CW_Or_Has_Controlled_Part --
3468 -------------------------------
3470 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
3472 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
3473 end CW_Or_Has_Controlled_Part
;
3479 function Convert_View
3482 Ind
: Pos
:= 1) return Node_Id
3484 Fent
: Entity_Id
:= First_Entity
(Proc
);
3489 for J
in 2 .. Ind
loop
3493 Ftyp
:= Etype
(Fent
);
3495 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3496 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3498 Atyp
:= Etype
(Arg
);
3501 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3502 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3505 and then Present
(Atyp
)
3506 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3507 and then Base_Type
(Underlying_Type
(Atyp
)) =
3508 Base_Type
(Underlying_Type
(Ftyp
))
3510 return Unchecked_Convert_To
(Ftyp
, Arg
);
3512 -- If the argument is already a conversion, as generated by
3513 -- Make_Init_Call, set the target type to the type of the formal
3514 -- directly, to avoid spurious typing problems.
3516 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3517 and then not Is_Class_Wide_Type
(Atyp
)
3519 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3520 Set_Etype
(Arg
, Ftyp
);
3528 ------------------------
3529 -- Enclosing_Function --
3530 ------------------------
3532 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
3533 Func_Id
: Entity_Id
;
3537 while Present
(Func_Id
)
3538 and then Func_Id
/= Standard_Standard
3540 if Ekind
(Func_Id
) = E_Function
then
3544 Func_Id
:= Scope
(Func_Id
);
3548 end Enclosing_Function
;
3550 -------------------------------
3551 -- Establish_Transient_Scope --
3552 -------------------------------
3554 -- This procedure is called each time a transient block has to be inserted
3555 -- that is to say for each call to a function with unconstrained or tagged
3556 -- result. It creates a new scope on the stack scope in order to enclose
3557 -- all transient variables generated.
3559 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
3560 Loc
: constant Source_Ptr
:= Sloc
(N
);
3561 Iter_Loop
: Entity_Id
;
3562 Wrap_Node
: Node_Id
;
3565 -- Do not create a transient scope if we are already inside one
3567 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
3568 if Scope_Stack
.Table
(S
).Is_Transient
then
3570 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
3575 -- If we encounter Standard there are no enclosing transient scopes
3577 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
3582 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
3584 -- The context does not contain a node that requires a transient scope,
3587 if No
(Wrap_Node
) then
3590 -- If the node to wrap is an iteration_scheme, the expression is one of
3591 -- the bounds, and the expansion will make an explicit declaration for
3592 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3593 -- transformations here. Same for an Ada 2012 iterator specification,
3594 -- where a block is created for the expression that build the container.
3596 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
3597 N_Iterator_Specification
)
3601 -- In formal verification mode, if the node to wrap is a pragma check,
3602 -- this node and enclosed expression are not expanded, so do not apply
3603 -- any transformations here.
3605 elsif GNATprove_Mode
3606 and then Nkind
(Wrap_Node
) = N_Pragma
3607 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
3611 -- Create a block entity to act as a transient scope. Note that when the
3612 -- node to be wrapped is an expression or a statement, a real physical
3613 -- block is constructed (see routines Wrap_Transient_Expression and
3614 -- Wrap_Transient_Statement) and inserted into the tree.
3617 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
3618 Set_Scope_Is_Transient
;
3620 -- The transient scope must also take care of the secondary stack
3624 Set_Uses_Sec_Stack
(Current_Scope
);
3625 Check_Restriction
(No_Secondary_Stack
, N
);
3627 -- The expansion of iterator loops generates references to objects
3628 -- in order to extract elements from a container:
3630 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3631 -- Obj : <object type> renames Ref.all.Element.all;
3633 -- These references are controlled and returned on the secondary
3634 -- stack. A new reference is created at each iteration of the loop
3635 -- and as a result it must be finalized and the space occupied by
3636 -- it on the secondary stack reclaimed at the end of the current
3639 -- When the context that requires a transient scope is a call to
3640 -- routine Reference, the node to be wrapped is the source object:
3642 -- for Obj of Container loop
3644 -- Routine Wrap_Transient_Declaration however does not generate a
3645 -- physical block as wrapping a declaration will kill it too ealy.
3646 -- To handle this peculiar case, mark the related iterator loop as
3647 -- requiring the secondary stack. This signals the finalization
3648 -- machinery to manage the secondary stack (see routine
3649 -- Process_Statements_For_Controlled_Objects).
3651 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
3653 if Present
(Iter_Loop
) then
3654 Set_Uses_Sec_Stack
(Iter_Loop
);
3658 Set_Etype
(Current_Scope
, Standard_Void_Type
);
3659 Set_Node_To_Be_Wrapped
(Wrap_Node
);
3661 if Debug_Flag_W
then
3662 Write_Str
(" <Transient>");
3666 end Establish_Transient_Scope
;
3668 ----------------------------
3669 -- Expand_Cleanup_Actions --
3670 ----------------------------
3672 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
3673 Scop
: constant Entity_Id
:= Current_Scope
;
3675 Is_Asynchronous_Call
: constant Boolean :=
3676 Nkind
(N
) = N_Block_Statement
3677 and then Is_Asynchronous_Call_Block
(N
);
3678 Is_Master
: constant Boolean :=
3679 Nkind
(N
) /= N_Entry_Body
3680 and then Is_Task_Master
(N
);
3681 Is_Protected_Body
: constant Boolean :=
3682 Nkind
(N
) = N_Subprogram_Body
3683 and then Is_Protected_Subprogram_Body
(N
);
3684 Is_Task_Allocation
: constant Boolean :=
3685 Nkind
(N
) = N_Block_Statement
3686 and then Is_Task_Allocation_Block
(N
);
3687 Is_Task_Body
: constant Boolean :=
3688 Nkind
(Original_Node
(N
)) = N_Task_Body
;
3689 Needs_Sec_Stack_Mark
: constant Boolean :=
3690 Uses_Sec_Stack
(Scop
)
3692 not Sec_Stack_Needed_For_Return
(Scop
)
3693 and then VM_Target
= No_VM
;
3695 Actions_Required
: constant Boolean :=
3696 Requires_Cleanup_Actions
(N
, True)
3697 or else Is_Asynchronous_Call
3699 or else Is_Protected_Body
3700 or else Is_Task_Allocation
3701 or else Is_Task_Body
3702 or else Needs_Sec_Stack_Mark
;
3704 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3707 procedure Wrap_HSS_In_Block
;
3708 -- Move HSS inside a new block along with the original exception
3709 -- handlers. Make the newly generated block the sole statement of HSS.
3711 -----------------------
3712 -- Wrap_HSS_In_Block --
3713 -----------------------
3715 procedure Wrap_HSS_In_Block
is
3720 -- Preserve end label to provide proper cross-reference information
3722 End_Lab
:= End_Label
(HSS
);
3724 Make_Block_Statement
(Loc
,
3725 Handled_Statement_Sequence
=> HSS
);
3727 -- Signal the finalization machinery that this particular block
3728 -- contains the original context.
3730 Set_Is_Finalization_Wrapper
(Block
);
3732 Set_Handled_Statement_Sequence
(N
,
3733 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3734 HSS
:= Handled_Statement_Sequence
(N
);
3736 Set_First_Real_Statement
(HSS
, Block
);
3737 Set_End_Label
(HSS
, End_Lab
);
3739 -- Comment needed here, see RH for 1.306 ???
3741 if Nkind
(N
) = N_Subprogram_Body
then
3742 Set_Has_Nested_Block_With_Handler
(Scop
);
3744 end Wrap_HSS_In_Block
;
3746 -- Start of processing for Expand_Cleanup_Actions
3749 -- The current construct does not need any form of servicing
3751 if not Actions_Required
then
3754 -- If the current node is a rewritten task body and the descriptors have
3755 -- not been delayed (due to some nested instantiations), do not generate
3756 -- redundant cleanup actions.
3759 and then Nkind
(N
) = N_Subprogram_Body
3760 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
3766 Decls
: List_Id
:= Declarations
(N
);
3768 Mark
: Entity_Id
:= Empty
;
3769 New_Decls
: List_Id
;
3773 -- If we are generating expanded code for debugging purposes, use the
3774 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3775 -- be updated subsequently to reference the proper line in .dg files.
3776 -- If we are not debugging generated code, use No_Location instead,
3777 -- so that no debug information is generated for the cleanup code.
3778 -- This makes the behavior of the NEXT command in GDB monotonic, and
3779 -- makes the placement of breakpoints more accurate.
3781 if Debug_Generated_Code
then
3787 -- Set polling off. The finalization and cleanup code is executed
3788 -- with aborts deferred.
3790 Old_Poll
:= Polling_Required
;
3791 Polling_Required
:= False;
3793 -- A task activation call has already been built for a task
3794 -- allocation block.
3796 if not Is_Task_Allocation
then
3797 Build_Task_Activation_Call
(N
);
3801 Establish_Task_Master
(N
);
3804 New_Decls
:= New_List
;
3806 -- If secondary stack is in use, generate:
3808 -- Mnn : constant Mark_Id := SS_Mark;
3810 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3811 -- secondary stack is never used on a VM.
3813 if Needs_Sec_Stack_Mark
then
3814 Mark
:= Make_Temporary
(Loc
, 'M');
3816 Append_To
(New_Decls
,
3817 Make_Object_Declaration
(Loc
,
3818 Defining_Identifier
=> Mark
,
3819 Object_Definition
=>
3820 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
3822 Make_Function_Call
(Loc
,
3823 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Mark
), Loc
))));
3825 Set_Uses_Sec_Stack
(Scop
, False);
3828 -- If exception handlers are present, wrap the sequence of statements
3829 -- in a block since it is not possible to have exception handlers and
3830 -- an At_End handler in the same construct.
3832 if Present
(Exception_Handlers
(HSS
)) then
3835 -- Ensure that the First_Real_Statement field is set
3837 elsif No
(First_Real_Statement
(HSS
)) then
3838 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
3841 -- Do not move the Activation_Chain declaration in the context of
3842 -- task allocation blocks. Task allocation blocks use _chain in their
3843 -- cleanup handlers and gigi complains if it is declared in the
3844 -- sequence of statements of the scope that declares the handler.
3846 if Is_Task_Allocation
then
3848 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
3852 Decl
:= First
(Decls
);
3853 while Nkind
(Decl
) /= N_Object_Declaration
3854 or else Defining_Identifier
(Decl
) /= Chain
3858 -- A task allocation block should always include a _chain
3861 pragma Assert
(Present
(Decl
));
3865 Prepend_To
(New_Decls
, Decl
);
3869 -- Ensure the presence of a declaration list in order to successfully
3870 -- append all original statements to it.
3873 Set_Declarations
(N
, New_List
);
3874 Decls
:= Declarations
(N
);
3877 -- Move the declarations into the sequence of statements in order to
3878 -- have them protected by the At_End handler. It may seem weird to
3879 -- put declarations in the sequence of statement but in fact nothing
3880 -- forbids that at the tree level.
3882 Append_List_To
(Decls
, Statements
(HSS
));
3883 Set_Statements
(HSS
, Decls
);
3885 -- Reset the Sloc of the handled statement sequence to properly
3886 -- reflect the new initial "statement" in the sequence.
3888 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
3890 -- The declarations of finalizer spec and auxiliary variables replace
3891 -- the old declarations that have been moved inward.
3893 Set_Declarations
(N
, New_Decls
);
3894 Analyze_Declarations
(New_Decls
);
3896 -- Generate finalization calls for all controlled objects appearing
3897 -- in the statements of N. Add context specific cleanup for various
3902 Clean_Stmts
=> Build_Cleanup_Statements
(N
),
3904 Top_Decls
=> New_Decls
,
3905 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
3909 if Present
(Fin_Id
) then
3910 Build_Finalizer_Call
(N
, Fin_Id
);
3913 -- Restore saved polling mode
3915 Polling_Required
:= Old_Poll
;
3917 end Expand_Cleanup_Actions
;
3919 ---------------------------
3920 -- Expand_N_Package_Body --
3921 ---------------------------
3923 -- Add call to Activate_Tasks if body is an activator (actual processing
3924 -- is in chapter 9).
3926 -- Generate subprogram descriptor for elaboration routine
3928 -- Encode entity names in package body
3930 procedure Expand_N_Package_Body
(N
: Node_Id
) is
3931 Spec_Ent
: constant Entity_Id
:= Corresponding_Spec
(N
);
3935 -- This is done only for non-generic packages
3937 if Ekind
(Spec_Ent
) = E_Package
then
3938 Push_Scope
(Corresponding_Spec
(N
));
3940 -- Build dispatch tables of library level tagged types
3942 if Tagged_Type_Expansion
3943 and then Is_Library_Level_Entity
(Spec_Ent
)
3945 Build_Static_Dispatch_Tables
(N
);
3948 Build_Task_Activation_Call
(N
);
3950 -- When the package is subject to pragma Initial_Condition, the
3951 -- assertion expression must be verified at the end of the body
3954 if Present
(Get_Pragma
(Spec_Ent
, Pragma_Initial_Condition
)) then
3955 Expand_Pragma_Initial_Condition
(N
);
3961 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
3962 Set_In_Package_Body
(Spec_Ent
, False);
3964 -- Set to encode entity names in package body before gigi is called
3966 Qualify_Entity_Names
(N
);
3968 if Ekind
(Spec_Ent
) /= E_Generic_Package
then
3971 Clean_Stmts
=> No_List
,
3973 Top_Decls
=> No_List
,
3974 Defer_Abort
=> False,
3977 if Present
(Fin_Id
) then
3979 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
3982 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
3983 Body_Ent
:= Defining_Identifier
(Body_Ent
);
3986 Set_Finalizer
(Body_Ent
, Fin_Id
);
3990 end Expand_N_Package_Body
;
3992 ----------------------------------
3993 -- Expand_N_Package_Declaration --
3994 ----------------------------------
3996 -- Add call to Activate_Tasks if there are tasks declared and the package
3997 -- has no body. Note that in Ada 83 this may result in premature activation
3998 -- of some tasks, given that we cannot tell whether a body will eventually
4001 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4002 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4003 Spec
: constant Node_Id
:= Specification
(N
);
4007 No_Body
: Boolean := False;
4008 -- True in the case of a package declaration that is a compilation
4009 -- unit and for which no associated body will be compiled in this
4013 -- Case of a package declaration other than a compilation unit
4015 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4018 -- Case of a compilation unit that does not require a body
4020 elsif not Body_Required
(Parent
(N
))
4021 and then not Unit_Requires_Body
(Id
)
4025 -- Special case of generating calling stubs for a remote call interface
4026 -- package: even though the package declaration requires one, the body
4027 -- won't be processed in this compilation (so any stubs for RACWs
4028 -- declared in the package must be generated here, along with the spec).
4030 elsif Parent
(N
) = Cunit
(Main_Unit
)
4031 and then Is_Remote_Call_Interface
(Id
)
4032 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4037 -- For a nested instance, delay processing until freeze point
4039 if Has_Delayed_Freeze
(Id
)
4040 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4045 -- For a package declaration that implies no associated body, generate
4046 -- task activation call and RACW supporting bodies now (since we won't
4047 -- have a specific separate compilation unit for that).
4052 -- Generate RACW subprogram bodies
4054 if Has_RACW
(Id
) then
4055 Decls
:= Private_Declarations
(Spec
);
4058 Decls
:= Visible_Declarations
(Spec
);
4063 Set_Visible_Declarations
(Spec
, Decls
);
4066 Append_RACW_Bodies
(Decls
, Id
);
4067 Analyze_List
(Decls
);
4070 -- Generate task activation call as last step of elaboration
4072 if Present
(Activation_Chain_Entity
(N
)) then
4073 Build_Task_Activation_Call
(N
);
4076 -- When the package is subject to pragma Initial_Condition and lacks
4077 -- a body, the assertion expression must be verified at the end of
4078 -- the visible declarations. Otherwise the check is performed at the
4079 -- end of the body statements (see Expand_N_Package_Body).
4081 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4082 Expand_Pragma_Initial_Condition
(N
);
4088 -- Build dispatch tables of library level tagged types
4090 if Tagged_Type_Expansion
4091 and then (Is_Compilation_Unit
(Id
)
4092 or else (Is_Generic_Instance
(Id
)
4093 and then Is_Library_Level_Entity
(Id
)))
4095 Build_Static_Dispatch_Tables
(N
);
4098 -- Note: it is not necessary to worry about generating a subprogram
4099 -- descriptor, since the only way to get exception handlers into a
4100 -- package spec is to include instantiations, and that would cause
4101 -- generation of subprogram descriptors to be delayed in any case.
4103 -- Set to encode entity names in package spec before gigi is called
4105 Qualify_Entity_Names
(N
);
4107 if Ekind
(Id
) /= E_Generic_Package
then
4110 Clean_Stmts
=> No_List
,
4112 Top_Decls
=> No_List
,
4113 Defer_Abort
=> False,
4116 Set_Finalizer
(Id
, Fin_Id
);
4118 end Expand_N_Package_Declaration
;
4120 -------------------------------------
4121 -- Expand_Pragma_Initial_Condition --
4122 -------------------------------------
4124 procedure Expand_Pragma_Initial_Condition
(N
: Node_Id
) is
4125 Loc
: constant Source_Ptr
:= Sloc
(N
);
4128 Init_Cond
: Node_Id
;
4130 Pack_Id
: Entity_Id
;
4133 if Nkind
(N
) = N_Package_Body
then
4134 Pack_Id
:= Corresponding_Spec
(N
);
4136 if Present
(Handled_Statement_Sequence
(N
)) then
4137 List
:= Statements
(Handled_Statement_Sequence
(N
));
4139 -- The package body lacks statements, create an empty list
4144 Set_Handled_Statement_Sequence
(N
,
4145 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> List
));
4148 elsif Nkind
(N
) = N_Package_Declaration
then
4149 Pack_Id
:= Defining_Entity
(N
);
4151 if Present
(Visible_Declarations
(Specification
(N
))) then
4152 List
:= Visible_Declarations
(Specification
(N
));
4154 -- The package lacks visible declarations, create an empty list
4159 Set_Visible_Declarations
(Specification
(N
), List
);
4162 -- This routine should not be used on anything other than packages
4165 raise Program_Error
;
4168 Init_Cond
:= Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
4170 -- The caller should check whether the package is subject to pragma
4171 -- Initial_Condition.
4173 pragma Assert
(Present
(Init_Cond
));
4176 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Init_Cond
)));
4178 -- The assertion expression was found to be illegal, do not generate the
4179 -- runtime check as it will repeat the illegality.
4181 if Error_Posted
(Init_Cond
) or else Error_Posted
(Expr
) then
4186 -- pragma Check (Initial_Condition, <Expr>);
4190 Chars
=> Name_Check
,
4191 Pragma_Argument_Associations
=> New_List
(
4192 Make_Pragma_Argument_Association
(Loc
,
4193 Expression
=> Make_Identifier
(Loc
, Name_Initial_Condition
)),
4195 Make_Pragma_Argument_Association
(Loc
,
4196 Expression
=> New_Copy_Tree
(Expr
))));
4198 Append_To
(List
, Check
);
4200 end Expand_Pragma_Initial_Condition
;
4202 -----------------------------
4203 -- Find_Node_To_Be_Wrapped --
4204 -----------------------------
4206 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4208 The_Parent
: Node_Id
;
4214 pragma Assert
(P
/= Empty
);
4215 The_Parent
:= Parent
(P
);
4217 case Nkind
(The_Parent
) is
4219 -- Simple statement can be wrapped
4224 -- Usually assignments are good candidate for wrapping except
4225 -- when they have been generated as part of a controlled aggregate
4226 -- where the wrapping should take place more globally. Note that
4227 -- No_Ctrl_Actions may be set also for non-controlled assignements
4228 -- in order to disable the use of dispatching _assign, so we need
4229 -- to test explicitly for a controlled type here.
4231 when N_Assignment_Statement
=>
4232 if No_Ctrl_Actions
(The_Parent
)
4233 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4240 -- An entry call statement is a special case if it occurs in the
4241 -- context of a Timed_Entry_Call. In this case we wrap the entire
4242 -- timed entry call.
4244 when N_Entry_Call_Statement |
4245 N_Procedure_Call_Statement
=>
4246 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4247 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4249 N_Conditional_Entry_Call
)
4251 return Parent
(Parent
(The_Parent
));
4256 -- Object declarations are also a boundary for the transient scope
4257 -- even if they are not really wrapped. For further details, see
4258 -- Wrap_Transient_Declaration.
4260 when N_Object_Declaration |
4261 N_Object_Renaming_Declaration |
4262 N_Subtype_Declaration
=>
4265 -- The expression itself is to be wrapped if its parent is a
4266 -- compound statement or any other statement where the expression
4267 -- is known to be scalar
4269 when N_Accept_Alternative |
4270 N_Attribute_Definition_Clause |
4273 N_Delay_Alternative |
4274 N_Delay_Until_Statement |
4275 N_Delay_Relative_Statement |
4276 N_Discriminant_Association |
4278 N_Entry_Body_Formal_Part |
4281 N_Iteration_Scheme |
4282 N_Terminate_Alternative
=>
4285 when N_Attribute_Reference
=>
4287 if Is_Procedure_Attribute_Name
4288 (Attribute_Name
(The_Parent
))
4293 -- A raise statement can be wrapped. This will arise when the
4294 -- expression in a raise_with_expression uses the secondary
4295 -- stack, for example.
4297 when N_Raise_Statement
=>
4300 -- If the expression is within the iteration scheme of a loop,
4301 -- we must create a declaration for it, followed by an assignment
4302 -- in order to have a usable statement to wrap.
4304 when N_Loop_Parameter_Specification
=>
4305 return Parent
(The_Parent
);
4307 -- The following nodes contains "dummy calls" which don't need to
4310 when N_Parameter_Specification |
4311 N_Discriminant_Specification |
4312 N_Component_Declaration
=>
4315 -- The return statement is not to be wrapped when the function
4316 -- itself needs wrapping at the outer-level
4318 when N_Simple_Return_Statement
=>
4320 Applies_To
: constant Entity_Id
:=
4322 (Return_Statement_Entity
(The_Parent
));
4323 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4325 if Requires_Transient_Scope
(Return_Type
) then
4332 -- If we leave a scope without having been able to find a node to
4333 -- wrap, something is going wrong but this can happen in error
4334 -- situation that are not detected yet (such as a dynamic string
4335 -- in a pragma export)
4337 when N_Subprogram_Body |
4338 N_Package_Declaration |
4340 N_Block_Statement
=>
4343 -- Otherwise continue the search
4349 end Find_Node_To_Be_Wrapped
;
4351 -------------------------------------
4352 -- Get_Global_Pool_For_Access_Type --
4353 -------------------------------------
4355 function Get_Global_Pool_For_Access_Type
(T
: Entity_Id
) return Entity_Id
is
4357 -- Access types whose size is smaller than System.Address size can exist
4358 -- only on VMS. We can't use the usual global pool which returns an
4359 -- object of type Address as truncation will make it invalid. To handle
4360 -- this case, VMS has a dedicated global pool that returns addresses
4361 -- that fit into 32 bit accesses.
4363 if Opt
.True_VMS_Target
and then Esize
(T
) = 32 then
4364 return RTE
(RE_Global_Pool_32_Object
);
4366 return RTE
(RE_Global_Pool_Object
);
4368 end Get_Global_Pool_For_Access_Type
;
4370 ----------------------------------
4371 -- Has_New_Controlled_Component --
4372 ----------------------------------
4374 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4378 if not Is_Tagged_Type
(E
) then
4379 return Has_Controlled_Component
(E
);
4380 elsif not Is_Derived_Type
(E
) then
4381 return Has_Controlled_Component
(E
);
4384 Comp
:= First_Component
(E
);
4385 while Present
(Comp
) loop
4386 if Chars
(Comp
) = Name_uParent
then
4389 elsif Scope
(Original_Record_Component
(Comp
)) = E
4390 and then Needs_Finalization
(Etype
(Comp
))
4395 Next_Component
(Comp
);
4399 end Has_New_Controlled_Component
;
4401 ---------------------------------
4402 -- Has_Simple_Protected_Object --
4403 ---------------------------------
4405 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4407 if Has_Task
(T
) then
4410 elsif Is_Simple_Protected_Type
(T
) then
4413 elsif Is_Array_Type
(T
) then
4414 return Has_Simple_Protected_Object
(Component_Type
(T
));
4416 elsif Is_Record_Type
(T
) then
4421 Comp
:= First_Component
(T
);
4422 while Present
(Comp
) loop
4423 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4427 Next_Component
(Comp
);
4436 end Has_Simple_Protected_Object
;
4438 ------------------------------------
4439 -- Insert_Actions_In_Scope_Around --
4440 ------------------------------------
4442 procedure Insert_Actions_In_Scope_Around
(N
: Node_Id
) is
4443 After
: constant List_Id
:=
4444 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_After
;
4445 Before
: constant List_Id
:=
4446 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped_Before
;
4447 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4448 -- Last), but this was incorrect as Process_Transient_Object may
4449 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4451 procedure Process_Transient_Objects
4452 (First_Object
: Node_Id
;
4453 Last_Object
: Node_Id
;
4454 Related_Node
: Node_Id
);
4455 -- First_Object and Last_Object define a list which contains potential
4456 -- controlled transient objects. Finalization flags are inserted before
4457 -- First_Object and finalization calls are inserted after Last_Object.
4458 -- Related_Node is the node for which transient objects have been
4461 -------------------------------
4462 -- Process_Transient_Objects --
4463 -------------------------------
4465 procedure Process_Transient_Objects
4466 (First_Object
: Node_Id
;
4467 Last_Object
: Node_Id
;
4468 Related_Node
: Node_Id
)
4470 Must_Hook
: Boolean := False;
4471 -- Flag denoting whether the context requires transient variable
4472 -- export to the outer finalizer.
4474 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4475 -- Determine whether an arbitrary node denotes a subprogram call
4477 procedure Detect_Subprogram_Call
is
4478 new Traverse_Proc
(Is_Subprogram_Call
);
4480 ------------------------
4481 -- Is_Subprogram_Call --
4482 ------------------------
4484 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4486 -- Complex constructs are factored out by the expander and their
4487 -- occurrences are replaced with references to temporaries. Due to
4488 -- this expansion activity, inspect the original tree to detect
4489 -- subprogram calls.
4491 if Nkind
(N
) = N_Identifier
and then Original_Node
(N
) /= N
then
4492 Detect_Subprogram_Call
(Original_Node
(N
));
4494 -- The original construct contains a subprogram call, there is
4495 -- no point in continuing the tree traversal.
4503 -- The original construct contains a subprogram call, there is no
4504 -- point in continuing the tree traversal.
4506 elsif Nkind
(N
) = N_Object_Declaration
4507 and then Present
(Expression
(N
))
4508 and then Nkind
(Original_Node
(Expression
(N
))) = N_Function_Call
4513 -- A regular procedure or function call
4515 elsif Nkind
(N
) in N_Subprogram_Call
then
4524 end Is_Subprogram_Call
;
4528 Built
: Boolean := False;
4529 Desig_Typ
: Entity_Id
;
4531 Fin_Block
: Node_Id
;
4532 Fin_Data
: Finalization_Exception_Data
;
4533 Fin_Decls
: List_Id
;
4534 Fin_Insrt
: Node_Id
;
4535 Last_Fin
: Node_Id
:= Empty
;
4539 Obj_Typ
: Entity_Id
;
4540 Prev_Fin
: Node_Id
:= Empty
;
4544 Temp_Id
: Entity_Id
;
4547 -- Start of processing for Process_Transient_Objects
4550 -- Recognize a scenario where the transient context is an object
4551 -- declaration initialized by a build-in-place function call:
4553 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4555 -- The rough expansion of the above is:
4557 -- Temp : ... := Ctrl_Func_Call;
4559 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4561 -- The finalization of any controlled transient must happen after
4562 -- the build-in-place function call is executed.
4564 if Nkind
(N
) = N_Object_Declaration
4565 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
4568 Fin_Insrt
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
4570 -- Search the context for at least one subprogram call. If found, the
4571 -- machinery exports all transient objects to the enclosing finalizer
4572 -- due to the possibility of abnormal call termination.
4575 Detect_Subprogram_Call
(N
);
4576 Fin_Insrt
:= Last_Object
;
4579 -- Examine all objects in the list First_Object .. Last_Object
4581 Stmt
:= First_Object
;
4582 while Present
(Stmt
) loop
4583 if Nkind
(Stmt
) = N_Object_Declaration
4584 and then Analyzed
(Stmt
)
4585 and then Is_Finalizable_Transient
(Stmt
, N
)
4587 -- Do not process the node to be wrapped since it will be
4588 -- handled by the enclosing finalizer.
4590 and then Stmt
/= Related_Node
4593 Obj_Id
:= Defining_Identifier
(Stmt
);
4594 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
4595 Desig_Typ
:= Obj_Typ
;
4597 Set_Is_Processed_Transient
(Obj_Id
);
4599 -- Handle access types
4601 if Is_Access_Type
(Desig_Typ
) then
4602 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
4605 -- Create the necessary entities and declarations the first
4610 Fin_Decls
:= New_List
;
4612 Build_Object_Declarations
(Fin_Data
, Fin_Decls
, Loc
);
4615 -- Transient variables associated with subprogram calls need
4616 -- extra processing. These variables are usually created right
4617 -- before the call and finalized immediately after the call.
4618 -- If an exception occurs during the call, the clean up code
4619 -- is skipped due to the sudden change in control and the
4620 -- transient is never finalized.
4622 -- To handle this case, such variables are "exported" to the
4623 -- enclosing sequence of statements where their corresponding
4624 -- "hooks" are picked up by the finalization machinery.
4628 -- Step 1: Create an access type which provides a reference
4629 -- to the transient object. Generate:
4631 -- Ann : access [all] <Desig_Typ>;
4633 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
4635 Insert_Action
(Stmt
,
4636 Make_Full_Type_Declaration
(Loc
,
4637 Defining_Identifier
=> Ptr_Id
,
4639 Make_Access_To_Object_Definition
(Loc
,
4641 Ekind
(Obj_Typ
) = E_General_Access_Type
,
4642 Subtype_Indication
=>
4643 New_Occurrence_Of
(Desig_Typ
, Loc
))));
4645 -- Step 2: Create a temporary which acts as a hook to the
4646 -- transient object. Generate:
4648 -- Temp : Ptr_Id := null;
4650 Temp_Id
:= Make_Temporary
(Loc
, 'T');
4652 Insert_Action
(Stmt
,
4653 Make_Object_Declaration
(Loc
,
4654 Defining_Identifier
=> Temp_Id
,
4655 Object_Definition
=>
4656 New_Occurrence_Of
(Ptr_Id
, Loc
)));
4658 -- Mark the temporary as a transient hook. This signals the
4659 -- machinery in Build_Finalizer to recognize this special
4662 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Stmt
);
4664 -- Step 3: Hook the transient object to the temporary
4666 if Is_Access_Type
(Obj_Typ
) then
4668 Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
4671 Make_Attribute_Reference
(Loc
,
4672 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
4673 Attribute_Name
=> Name_Unrestricted_Access
);
4677 -- Temp := Ptr_Id (Obj_Id);
4679 -- Temp := Obj_Id'Unrestricted_Access;
4681 -- When the transient object is initialized by an aggregate,
4682 -- the hook must capture the object after the last component
4683 -- assignment takes place. Only then is the object fully
4686 if Ekind
(Obj_Id
) = E_Variable
4687 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
4689 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
4691 -- Otherwise the hook seizes the related object immediately
4697 Insert_After_And_Analyze
(Temp_Ins
,
4698 Make_Assignment_Statement
(Loc
,
4699 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4700 Expression
=> Expr
));
4705 -- The transient object is about to be finalized by the clean
4706 -- up code following the subprogram call. In order to avoid
4707 -- double finalization, clear the hook.
4714 Make_Assignment_Statement
(Loc
,
4715 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4716 Expression
=> Make_Null
(Loc
)));
4720 -- [Deep_]Finalize (Obj_Ref);
4722 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
4724 if Is_Access_Type
(Obj_Typ
) then
4725 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
4729 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
));
4734 -- [Deep_]Finalize (Obj_Ref);
4738 -- if not Raised then
4741 -- (Enn, Get_Current_Excep.all.all);
4746 Make_Block_Statement
(Loc
,
4747 Handled_Statement_Sequence
=>
4748 Make_Handled_Sequence_Of_Statements
(Loc
,
4749 Statements
=> Stmts
,
4750 Exception_Handlers
=> New_List
(
4751 Build_Exception_Handler
(Fin_Data
))));
4753 -- The single raise statement must be inserted after all the
4754 -- finalization blocks, and we put everything into a wrapper
4755 -- block to clearly expose the construct to the back-end.
4757 if Present
(Prev_Fin
) then
4758 Insert_Before_And_Analyze
(Prev_Fin
, Fin_Block
);
4760 Insert_After_And_Analyze
(Fin_Insrt
,
4761 Make_Block_Statement
(Loc
,
4762 Declarations
=> Fin_Decls
,
4763 Handled_Statement_Sequence
=>
4764 Make_Handled_Sequence_Of_Statements
(Loc
,
4765 Statements
=> New_List
(Fin_Block
))));
4767 Last_Fin
:= Fin_Block
;
4770 Prev_Fin
:= Fin_Block
;
4773 -- Terminate the scan after the last object has been processed to
4774 -- avoid touching unrelated code.
4776 if Stmt
= Last_Object
then
4784 -- if Raised and then not Abort then
4785 -- Raise_From_Controlled_Operation (E);
4788 if Built
and then Present
(Last_Fin
) then
4789 Insert_After_And_Analyze
(Last_Fin
,
4790 Build_Raise_Statement
(Fin_Data
));
4792 end Process_Transient_Objects
;
4794 -- Start of processing for Insert_Actions_In_Scope_Around
4797 if No
(Before
) and then No
(After
) then
4802 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
4803 First_Obj
: Node_Id
;
4808 -- If the node to be wrapped is the trigger of an asynchronous
4809 -- select, it is not part of a statement list. The actions must be
4810 -- inserted before the select itself, which is part of some list of
4811 -- statements. Note that the triggering alternative includes the
4812 -- triggering statement and an optional statement list. If the node
4813 -- to be wrapped is part of that list, the normal insertion applies.
4815 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
4816 and then not Is_List_Member
(Node_To_Wrap
)
4818 Target
:= Parent
(Parent
(Node_To_Wrap
));
4823 First_Obj
:= Target
;
4826 -- Add all actions associated with a transient scope into the main
4827 -- tree. There are several scenarios here:
4829 -- +--- Before ----+ +----- After ---+
4830 -- 1) First_Obj ....... Target ........ Last_Obj
4832 -- 2) First_Obj ....... Target
4834 -- 3) Target ........ Last_Obj
4836 if Present
(Before
) then
4838 -- Flag declarations are inserted before the first object
4840 First_Obj
:= First
(Before
);
4842 Insert_List_Before
(Target
, Before
);
4845 if Present
(After
) then
4847 -- Finalization calls are inserted after the last object
4849 Last_Obj
:= Last
(After
);
4851 Insert_List_After
(Target
, After
);
4854 -- Check for transient controlled objects associated with Target and
4855 -- generate the appropriate finalization actions for them.
4857 Process_Transient_Objects
4858 (First_Object
=> First_Obj
,
4859 Last_Object
=> Last_Obj
,
4860 Related_Node
=> Target
);
4862 -- Reset the action lists
4864 if Present
(Before
) then
4865 Scope_Stack
.Table
(Scope_Stack
.Last
).
4866 Actions_To_Be_Wrapped_Before
:= No_List
;
4869 if Present
(After
) then
4870 Scope_Stack
.Table
(Scope_Stack
.Last
).
4871 Actions_To_Be_Wrapped_After
:= No_List
;
4874 end Insert_Actions_In_Scope_Around
;
4876 ------------------------------
4877 -- Is_Simple_Protected_Type --
4878 ------------------------------
4880 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
4883 Is_Protected_Type
(T
)
4884 and then not Uses_Lock_Free
(T
)
4885 and then not Has_Entries
(T
)
4886 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
4887 end Is_Simple_Protected_Type
;
4889 -----------------------
4890 -- Make_Adjust_Call --
4891 -----------------------
4893 function Make_Adjust_Call
4896 For_Parent
: Boolean := False) return Node_Id
4898 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
4899 Adj_Id
: Entity_Id
:= Empty
;
4900 Ref
: Node_Id
:= Obj_Ref
;
4904 -- Recover the proper type which contains Deep_Adjust
4906 if Is_Class_Wide_Type
(Typ
) then
4907 Utyp
:= Root_Type
(Typ
);
4912 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
4913 Set_Assignment_OK
(Ref
);
4915 -- Deal with non-tagged derivation of private views
4917 if Is_Untagged_Derivation
(Typ
) then
4918 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
4919 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4920 Set_Assignment_OK
(Ref
);
4923 -- When dealing with the completion of a private type, use the base
4926 if Utyp
/= Base_Type
(Utyp
) then
4927 pragma Assert
(Is_Private_Type
(Typ
));
4929 Utyp
:= Base_Type
(Utyp
);
4930 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
4933 -- Select the appropriate version of adjust
4936 if Has_Controlled_Component
(Utyp
) then
4937 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4940 -- Class-wide types, interfaces and types with controlled components
4942 elsif Is_Class_Wide_Type
(Typ
)
4943 or else Is_Interface
(Typ
)
4944 or else Has_Controlled_Component
(Utyp
)
4946 if Is_Tagged_Type
(Utyp
) then
4947 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4949 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
4952 -- Derivations from [Limited_]Controlled
4954 elsif Is_Controlled
(Utyp
) then
4955 if Has_Controlled_Component
(Utyp
) then
4956 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4958 Adj_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
4963 elsif Is_Tagged_Type
(Utyp
) then
4964 Adj_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
4967 raise Program_Error
;
4970 if Present
(Adj_Id
) then
4972 -- If the object is unanalyzed, set its expected type for use in
4973 -- Convert_View in case an additional conversion is needed.
4976 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
4978 Set_Etype
(Ref
, Typ
);
4981 -- The object reference may need another conversion depending on the
4982 -- type of the formal and that of the actual.
4984 if not Is_Class_Wide_Type
(Typ
) then
4985 Ref
:= Convert_View
(Adj_Id
, Ref
);
4988 return Make_Call
(Loc
, Adj_Id
, New_Copy_Tree
(Ref
), For_Parent
);
4992 end Make_Adjust_Call
;
4994 ----------------------
4995 -- Make_Attach_Call --
4996 ----------------------
4998 function Make_Attach_Call
5000 Ptr_Typ
: Entity_Id
) return Node_Id
5002 pragma Assert
(VM_Target
/= No_VM
);
5004 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5007 Make_Procedure_Call_Statement
(Loc
,
5009 New_Occurrence_Of
(RTE
(RE_Attach
), Loc
),
5010 Parameter_Associations
=> New_List
(
5011 New_Occurrence_Of
(Finalization_Master
(Ptr_Typ
), Loc
),
5012 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5013 end Make_Attach_Call
;
5015 ----------------------
5016 -- Make_Detach_Call --
5017 ----------------------
5019 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5020 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5024 Make_Procedure_Call_Statement
(Loc
,
5026 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5027 Parameter_Associations
=> New_List
(
5028 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5029 end Make_Detach_Call
;
5037 Proc_Id
: Entity_Id
;
5039 For_Parent
: Boolean := False) return Node_Id
5041 Params
: constant List_Id
:= New_List
(Param
);
5044 -- When creating a call to Deep_Finalize for a _parent field of a
5045 -- derived type, disable the invocation of the nested Finalize by giving
5046 -- the corresponding flag a False value.
5049 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5053 Make_Procedure_Call_Statement
(Loc
,
5054 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5055 Parameter_Associations
=> Params
);
5058 --------------------------
5059 -- Make_Deep_Array_Body --
5060 --------------------------
5062 function Make_Deep_Array_Body
5063 (Prim
: Final_Primitives
;
5064 Typ
: Entity_Id
) return List_Id
5066 function Build_Adjust_Or_Finalize_Statements
5067 (Typ
: Entity_Id
) return List_Id
;
5068 -- Create the statements necessary to adjust or finalize an array of
5069 -- controlled elements. Generate:
5072 -- Abort : constant Boolean := Triggered_By_Abort;
5074 -- Abort : constant Boolean := False; -- no abort
5076 -- E : Exception_Occurrence;
5077 -- Raised : Boolean := False;
5080 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5081 -- ^-- in the finalization case
5083 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5085 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5089 -- if not Raised then
5091 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5098 -- if Raised and then not Abort then
5099 -- Raise_From_Controlled_Operation (E);
5103 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5104 -- Create the statements necessary to initialize an array of controlled
5105 -- elements. Include a mechanism to carry out partial finalization if an
5106 -- exception occurs. Generate:
5109 -- Counter : Integer := 0;
5112 -- for J1 in V'Range (1) loop
5114 -- for JN in V'Range (N) loop
5116 -- [Deep_]Initialize (V (J1, ..., JN));
5118 -- Counter := Counter + 1;
5123 -- Abort : constant Boolean := Triggered_By_Abort;
5125 -- Abort : constant Boolean := False; -- no abort
5126 -- E : Exception_Occurence;
5127 -- Raised : Boolean := False;
5134 -- V'Length (N) - Counter;
5136 -- for F1 in reverse V'Range (1) loop
5138 -- for FN in reverse V'Range (N) loop
5139 -- if Counter > 0 then
5140 -- Counter := Counter - 1;
5143 -- [Deep_]Finalize (V (F1, ..., FN));
5147 -- if not Raised then
5149 -- Save_Occurrence (E,
5150 -- Get_Current_Excep.all.all);
5159 -- if Raised and then not Abort then
5160 -- Raise_From_Controlled_Operation (E);
5169 function New_References_To
5171 Loc
: Source_Ptr
) return List_Id
;
5172 -- Given a list of defining identifiers, return a list of references to
5173 -- the original identifiers, in the same order as they appear.
5175 -----------------------------------------
5176 -- Build_Adjust_Or_Finalize_Statements --
5177 -----------------------------------------
5179 function Build_Adjust_Or_Finalize_Statements
5180 (Typ
: Entity_Id
) return List_Id
5182 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5183 Index_List
: constant List_Id
:= New_List
;
5184 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5185 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5186 Finalizer_Decls
: List_Id
:= No_List
;
5187 Finalizer_Data
: Finalization_Exception_Data
;
5190 Core_Loop
: Node_Id
;
5193 Loop_Id
: Entity_Id
;
5196 Exceptions_OK
: constant Boolean :=
5197 not Restriction_Active
(No_Exception_Propagation
);
5199 procedure Build_Indexes
;
5200 -- Generate the indexes used in the dimension loops
5206 procedure Build_Indexes
is
5208 -- Generate the following identifiers:
5209 -- Jnn - for initialization
5211 for Dim
in 1 .. Num_Dims
loop
5212 Append_To
(Index_List
,
5213 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5217 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5220 Finalizer_Decls
:= New_List
;
5223 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5226 Make_Indexed_Component
(Loc
,
5227 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5228 Expressions
=> New_References_To
(Index_List
, Loc
));
5229 Set_Etype
(Comp_Ref
, Comp_Typ
);
5232 -- [Deep_]Adjust (V (J1, ..., JN))
5234 if Prim
= Adjust_Case
then
5235 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5238 -- [Deep_]Finalize (V (J1, ..., JN))
5240 else pragma Assert
(Prim
= Finalize_Case
);
5241 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5244 -- Generate the block which houses the adjust or finalize call:
5246 -- <adjust or finalize call>; -- No_Exception_Propagation
5248 -- begin -- Exception handlers allowed
5249 -- <adjust or finalize call>
5253 -- if not Raised then
5255 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5259 if Exceptions_OK
then
5261 Make_Block_Statement
(Loc
,
5262 Handled_Statement_Sequence
=>
5263 Make_Handled_Sequence_Of_Statements
(Loc
,
5264 Statements
=> New_List
(Call
),
5265 Exception_Handlers
=> New_List
(
5266 Build_Exception_Handler
(Finalizer_Data
))));
5271 -- Generate the dimension loops starting from the innermost one
5273 -- for Jnn in [reverse] V'Range (Dim) loop
5277 J
:= Last
(Index_List
);
5279 while Present
(J
) 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
=> Prim
= Finalize_Case
)),
5300 Statements
=> New_List
(Core_Loop
),
5301 End_Label
=> Empty
);
5306 -- Generate the block which contains the core loop, the declarations
5307 -- of the abort flag, the exception occurrence, the raised flag and
5308 -- 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;
5321 -- if Raised and then not Abort then -- Expection handlers OK
5322 -- Raise_From_Controlled_Operation (E);
5326 Stmts
:= New_List
(Core_Loop
);
5328 if Exceptions_OK
then
5330 Build_Raise_Statement
(Finalizer_Data
));
5335 Make_Block_Statement
(Loc
,
5338 Handled_Statement_Sequence
=>
5339 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5340 end Build_Adjust_Or_Finalize_Statements
;
5342 ---------------------------------
5343 -- Build_Initialize_Statements --
5344 ---------------------------------
5346 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5347 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5348 Final_List
: constant List_Id
:= New_List
;
5349 Index_List
: constant List_Id
:= New_List
;
5350 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5351 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5352 Counter_Id
: Entity_Id
;
5356 Final_Block
: Node_Id
;
5357 Final_Loop
: Node_Id
;
5358 Finalizer_Data
: Finalization_Exception_Data
;
5359 Finalizer_Decls
: List_Id
:= No_List
;
5360 Init_Loop
: Node_Id
;
5365 Exceptions_OK
: constant Boolean :=
5366 not Restriction_Active
(No_Exception_Propagation
);
5368 function Build_Counter_Assignment
return Node_Id
;
5369 -- Generate the following assignment:
5370 -- Counter := V'Length (1) *
5372 -- V'Length (N) - Counter;
5374 function Build_Finalization_Call
return Node_Id
;
5375 -- Generate a deep finalization call for an array element
5377 procedure Build_Indexes
;
5378 -- Generate the initialization and finalization indexes used in the
5381 function Build_Initialization_Call
return Node_Id
;
5382 -- Generate a deep initialization call for an array element
5384 ------------------------------
5385 -- Build_Counter_Assignment --
5386 ------------------------------
5388 function Build_Counter_Assignment
return Node_Id
is
5393 -- Start from the first dimension and generate:
5398 Make_Attribute_Reference
(Loc
,
5399 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5400 Attribute_Name
=> Name_Length
,
5401 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5403 -- Process the rest of the dimensions, generate:
5404 -- Expr * V'Length (N)
5407 while Dim
<= Num_Dims
loop
5409 Make_Op_Multiply
(Loc
,
5412 Make_Attribute_Reference
(Loc
,
5413 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5414 Attribute_Name
=> Name_Length
,
5415 Expressions
=> New_List
(
5416 Make_Integer_Literal
(Loc
, Dim
))));
5422 -- Counter := Expr - Counter;
5425 Make_Assignment_Statement
(Loc
,
5426 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5428 Make_Op_Subtract
(Loc
,
5430 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5431 end Build_Counter_Assignment
;
5433 -----------------------------
5434 -- Build_Finalization_Call --
5435 -----------------------------
5437 function Build_Finalization_Call
return Node_Id
is
5438 Comp_Ref
: constant Node_Id
:=
5439 Make_Indexed_Component
(Loc
,
5440 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5441 Expressions
=> New_References_To
(Final_List
, Loc
));
5444 Set_Etype
(Comp_Ref
, Comp_Typ
);
5447 -- [Deep_]Finalize (V);
5449 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5450 end Build_Finalization_Call
;
5456 procedure Build_Indexes
is
5458 -- Generate the following identifiers:
5459 -- Jnn - for initialization
5460 -- Fnn - for finalization
5462 for Dim
in 1 .. Num_Dims
loop
5463 Append_To
(Index_List
,
5464 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5466 Append_To
(Final_List
,
5467 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5471 -------------------------------
5472 -- Build_Initialization_Call --
5473 -------------------------------
5475 function Build_Initialization_Call
return Node_Id
is
5476 Comp_Ref
: constant Node_Id
:=
5477 Make_Indexed_Component
(Loc
,
5478 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5479 Expressions
=> New_References_To
(Index_List
, Loc
));
5482 Set_Etype
(Comp_Ref
, Comp_Typ
);
5485 -- [Deep_]Initialize (V (J1, ..., JN));
5487 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5488 end Build_Initialization_Call
;
5490 -- Start of processing for Build_Initialize_Statements
5493 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5494 Finalizer_Decls
:= New_List
;
5497 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5499 -- Generate the block which houses the finalization call, the index
5500 -- guard and the handler which triggers Program_Error later on.
5502 -- if Counter > 0 then
5503 -- Counter := Counter - 1;
5505 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5507 -- begin -- Exceptions allowed
5508 -- [Deep_]Finalize (V (F1, ..., FN));
5511 -- if not Raised then
5513 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5518 if Exceptions_OK
then
5520 Make_Block_Statement
(Loc
,
5521 Handled_Statement_Sequence
=>
5522 Make_Handled_Sequence_Of_Statements
(Loc
,
5523 Statements
=> New_List
(Build_Finalization_Call
),
5524 Exception_Handlers
=> New_List
(
5525 Build_Exception_Handler
(Finalizer_Data
))));
5527 Fin_Stmt
:= Build_Finalization_Call
;
5530 -- This is the core of the loop, the dimension iterators are added
5531 -- one by one in reverse.
5534 Make_If_Statement
(Loc
,
5537 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5538 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5540 Then_Statements
=> New_List
(
5541 Make_Assignment_Statement
(Loc
,
5542 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5544 Make_Op_Subtract
(Loc
,
5545 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5546 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
5548 Else_Statements
=> New_List
(Fin_Stmt
));
5550 -- Generate all finalization loops starting from the innermost
5553 -- for Fnn in reverse V'Range (Dim) loop
5557 F
:= Last
(Final_List
);
5559 while Present
(F
) and then Dim
> 0 loop
5565 Make_Loop_Statement
(Loc
,
5567 Make_Iteration_Scheme
(Loc
,
5568 Loop_Parameter_Specification
=>
5569 Make_Loop_Parameter_Specification
(Loc
,
5570 Defining_Identifier
=> Loop_Id
,
5571 Discrete_Subtype_Definition
=>
5572 Make_Attribute_Reference
(Loc
,
5573 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5574 Attribute_Name
=> Name_Range
,
5575 Expressions
=> New_List
(
5576 Make_Integer_Literal
(Loc
, Dim
))),
5578 Reverse_Present
=> True)),
5580 Statements
=> New_List
(Final_Loop
),
5581 End_Label
=> Empty
);
5586 -- Generate the block which contains the finalization loops, the
5587 -- declarations of the abort flag, the exception occurrence, the
5588 -- raised flag and the conditional raise.
5591 -- Abort : constant Boolean := Triggered_By_Abort;
5593 -- Abort : constant Boolean := False; -- no abort
5595 -- E : Exception_Occurrence;
5596 -- Raised : Boolean := False;
5602 -- V'Length (N) - Counter;
5606 -- if Raised and then not Abort then -- Exception handlers OK
5607 -- Raise_From_Controlled_Operation (E);
5610 -- raise; -- Exception handlers OK
5613 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
5615 if Exceptions_OK
then
5617 Build_Raise_Statement
(Finalizer_Data
));
5618 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
5622 Make_Block_Statement
(Loc
,
5625 Handled_Statement_Sequence
=>
5626 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
5628 -- Generate the block which contains the initialization call and
5629 -- the partial finalization code.
5632 -- [Deep_]Initialize (V (J1, ..., JN));
5634 -- Counter := Counter + 1;
5638 -- <finalization code>
5642 Make_Block_Statement
(Loc
,
5643 Handled_Statement_Sequence
=>
5644 Make_Handled_Sequence_Of_Statements
(Loc
,
5645 Statements
=> New_List
(Build_Initialization_Call
),
5646 Exception_Handlers
=> New_List
(
5647 Make_Exception_Handler
(Loc
,
5648 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5649 Statements
=> New_List
(Final_Block
)))));
5651 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
5652 Make_Assignment_Statement
(Loc
,
5653 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5656 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5657 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
5659 -- Generate all initialization loops starting from the innermost
5662 -- for Jnn in V'Range (Dim) loop
5666 J
:= Last
(Index_List
);
5668 while Present
(J
) and then Dim
> 0 loop
5674 Make_Loop_Statement
(Loc
,
5676 Make_Iteration_Scheme
(Loc
,
5677 Loop_Parameter_Specification
=>
5678 Make_Loop_Parameter_Specification
(Loc
,
5679 Defining_Identifier
=> Loop_Id
,
5680 Discrete_Subtype_Definition
=>
5681 Make_Attribute_Reference
(Loc
,
5682 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5683 Attribute_Name
=> Name_Range
,
5684 Expressions
=> New_List
(
5685 Make_Integer_Literal
(Loc
, Dim
))))),
5687 Statements
=> New_List
(Init_Loop
),
5688 End_Label
=> Empty
);
5693 -- Generate the block which contains the counter variable and the
5694 -- initialization loops.
5697 -- Counter : Integer := 0;
5704 Make_Block_Statement
(Loc
,
5705 Declarations
=> New_List
(
5706 Make_Object_Declaration
(Loc
,
5707 Defining_Identifier
=> Counter_Id
,
5708 Object_Definition
=>
5709 New_Occurrence_Of
(Standard_Integer
, Loc
),
5710 Expression
=> Make_Integer_Literal
(Loc
, 0))),
5712 Handled_Statement_Sequence
=>
5713 Make_Handled_Sequence_Of_Statements
(Loc
,
5714 Statements
=> New_List
(Init_Loop
))));
5715 end Build_Initialize_Statements
;
5717 -----------------------
5718 -- New_References_To --
5719 -----------------------
5721 function New_References_To
5723 Loc
: Source_Ptr
) return List_Id
5725 Refs
: constant List_Id
:= New_List
;
5730 while Present
(Id
) loop
5731 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
5736 end New_References_To
;
5738 -- Start of processing for Make_Deep_Array_Body
5742 when Address_Case
=>
5743 return Make_Finalize_Address_Stmts
(Typ
);
5747 return Build_Adjust_Or_Finalize_Statements
(Typ
);
5749 when Initialize_Case
=>
5750 return Build_Initialize_Statements
(Typ
);
5752 end Make_Deep_Array_Body
;
5754 --------------------
5755 -- Make_Deep_Proc --
5756 --------------------
5758 function Make_Deep_Proc
5759 (Prim
: Final_Primitives
;
5761 Stmts
: List_Id
) return Entity_Id
5763 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5765 Proc_Id
: Entity_Id
;
5768 -- Create the object formal, generate:
5769 -- V : System.Address
5771 if Prim
= Address_Case
then
5772 Formals
:= New_List
(
5773 Make_Parameter_Specification
(Loc
,
5774 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5776 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5783 Formals
:= New_List
(
5784 Make_Parameter_Specification
(Loc
,
5785 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5787 Out_Present
=> True,
5788 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
5790 -- F : Boolean := True
5792 if Prim
= Adjust_Case
5793 or else Prim
= Finalize_Case
5796 Make_Parameter_Specification
(Loc
,
5797 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
5799 New_Occurrence_Of
(Standard_Boolean
, Loc
),
5801 New_Occurrence_Of
(Standard_True
, Loc
)));
5806 Make_Defining_Identifier
(Loc
,
5807 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
5810 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5813 -- exception -- Finalize and Adjust cases only
5814 -- raise Program_Error;
5815 -- end Deep_Initialize / Adjust / Finalize;
5819 -- procedure Finalize_Address (V : System.Address) is
5822 -- end Finalize_Address;
5825 Make_Subprogram_Body
(Loc
,
5827 Make_Procedure_Specification
(Loc
,
5828 Defining_Unit_Name
=> Proc_Id
,
5829 Parameter_Specifications
=> Formals
),
5831 Declarations
=> Empty_List
,
5833 Handled_Statement_Sequence
=>
5834 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
5839 ---------------------------
5840 -- Make_Deep_Record_Body --
5841 ---------------------------
5843 function Make_Deep_Record_Body
5844 (Prim
: Final_Primitives
;
5846 Is_Local
: Boolean := False) return List_Id
5848 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
5849 -- Build the statements necessary to adjust a record type. The type may
5850 -- have discriminants and contain variant parts. Generate:
5854 -- [Deep_]Adjust (V.Comp_1);
5856 -- when Id : others =>
5857 -- if not Raised then
5859 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5864 -- [Deep_]Adjust (V.Comp_N);
5866 -- when Id : others =>
5867 -- if not Raised then
5869 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5874 -- Deep_Adjust (V._parent, False); -- If applicable
5876 -- when Id : others =>
5877 -- if not Raised then
5879 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5885 -- Adjust (V); -- If applicable
5888 -- if not Raised then
5890 -- Save_Occurence (E, Get_Current_Excep.all.all);
5895 -- if Raised and then not Abort then
5896 -- Raise_From_Controlled_Operation (E);
5900 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
5901 -- Build the statements necessary to finalize a record type. The type
5902 -- may have discriminants and contain variant parts. Generate:
5905 -- Abort : constant Boolean := Triggered_By_Abort;
5907 -- Abort : constant Boolean := False; -- no abort
5908 -- E : Exception_Occurence;
5909 -- Raised : Boolean := False;
5914 -- Finalize (V); -- If applicable
5917 -- if not Raised then
5919 -- Save_Occurence (E, Get_Current_Excep.all.all);
5924 -- case Variant_1 is
5926 -- case State_Counter_N => -- If Is_Local is enabled
5936 -- <<LN>> -- If Is_Local is enabled
5938 -- [Deep_]Finalize (V.Comp_N);
5941 -- if not Raised then
5943 -- Save_Occurence (E, Get_Current_Excep.all.all);
5949 -- [Deep_]Finalize (V.Comp_1);
5952 -- if not Raised then
5954 -- Save_Occurence (E, Get_Current_Excep.all.all);
5960 -- case State_Counter_1 => -- If Is_Local is enabled
5966 -- Deep_Finalize (V._parent, False); -- If applicable
5968 -- when Id : others =>
5969 -- if not Raised then
5971 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5975 -- if Raised and then not Abort then
5976 -- Raise_From_Controlled_Operation (E);
5980 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
5981 -- Given a derived tagged type Typ, traverse all components, find field
5982 -- _parent and return its type.
5984 procedure Preprocess_Components
5986 Num_Comps
: out Int
;
5987 Has_POC
: out Boolean);
5988 -- Examine all components in component list Comps, count all controlled
5989 -- components and determine whether at least one of them is per-object
5990 -- constrained. Component _parent is always skipped.
5992 -----------------------------
5993 -- Build_Adjust_Statements --
5994 -----------------------------
5996 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
5997 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5998 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
5999 Bod_Stmts
: List_Id
;
6000 Finalizer_Data
: Finalization_Exception_Data
;
6001 Finalizer_Decls
: List_Id
:= No_List
;
6005 Exceptions_OK
: constant Boolean :=
6006 not Restriction_Active
(No_Exception_Propagation
);
6008 function Process_Component_List_For_Adjust
6009 (Comps
: Node_Id
) return List_Id
;
6010 -- Build all necessary adjust statements for a single component list
6012 ---------------------------------------
6013 -- Process_Component_List_For_Adjust --
6014 ---------------------------------------
6016 function Process_Component_List_For_Adjust
6017 (Comps
: Node_Id
) return List_Id
6019 Stmts
: constant List_Id
:= New_List
;
6021 Decl_Id
: Entity_Id
;
6022 Decl_Typ
: Entity_Id
;
6026 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6027 -- Process the declaration of a single controlled component
6029 ----------------------------------
6030 -- Process_Component_For_Adjust --
6031 ----------------------------------
6033 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6034 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6035 Typ
: constant Entity_Id
:= Etype
(Id
);
6040 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6042 -- begin -- Exception handlers allowed
6043 -- [Deep_]Adjust (V.Id);
6046 -- if not Raised then
6048 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6055 Make_Selected_Component
(Loc
,
6056 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6057 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6060 if Exceptions_OK
then
6062 Make_Block_Statement
(Loc
,
6063 Handled_Statement_Sequence
=>
6064 Make_Handled_Sequence_Of_Statements
(Loc
,
6065 Statements
=> New_List
(Adj_Stmt
),
6066 Exception_Handlers
=> New_List
(
6067 Build_Exception_Handler
(Finalizer_Data
))));
6070 Append_To
(Stmts
, Adj_Stmt
);
6071 end Process_Component_For_Adjust
;
6073 -- Start of processing for Process_Component_List_For_Adjust
6076 -- Perform an initial check, determine the number of controlled
6077 -- components in the current list and whether at least one of them
6078 -- is per-object constrained.
6080 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6082 -- The processing in this routine is done in the following order:
6083 -- 1) Regular components
6084 -- 2) Per-object constrained components
6087 if Num_Comps
> 0 then
6089 -- Process all regular components in order of declarations
6091 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6092 while Present
(Decl
) loop
6093 Decl_Id
:= Defining_Identifier
(Decl
);
6094 Decl_Typ
:= Etype
(Decl_Id
);
6096 -- Skip _parent as well as per-object constrained components
6098 if Chars
(Decl_Id
) /= Name_uParent
6099 and then Needs_Finalization
(Decl_Typ
)
6101 if Has_Access_Constraint
(Decl_Id
)
6102 and then No
(Expression
(Decl
))
6106 Process_Component_For_Adjust
(Decl
);
6110 Next_Non_Pragma
(Decl
);
6113 -- Process all per-object constrained components in order of
6117 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6118 while Present
(Decl
) loop
6119 Decl_Id
:= Defining_Identifier
(Decl
);
6120 Decl_Typ
:= Etype
(Decl_Id
);
6124 if Chars
(Decl_Id
) /= Name_uParent
6125 and then Needs_Finalization
(Decl_Typ
)
6126 and then Has_Access_Constraint
(Decl_Id
)
6127 and then No
(Expression
(Decl
))
6129 Process_Component_For_Adjust
(Decl
);
6132 Next_Non_Pragma
(Decl
);
6137 -- Process all variants, if any
6140 if Present
(Variant_Part
(Comps
)) then
6142 Var_Alts
: constant List_Id
:= New_List
;
6146 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6147 while Present
(Var
) loop
6150 -- when <discrete choices> =>
6151 -- <adjust statements>
6153 Append_To
(Var_Alts
,
6154 Make_Case_Statement_Alternative
(Loc
,
6156 New_Copy_List
(Discrete_Choices
(Var
)),
6158 Process_Component_List_For_Adjust
(
6159 Component_List
(Var
))));
6161 Next_Non_Pragma
(Var
);
6165 -- case V.<discriminant> is
6166 -- when <discrete choices 1> =>
6167 -- <adjust statements 1>
6169 -- when <discrete choices N> =>
6170 -- <adjust statements N>
6174 Make_Case_Statement
(Loc
,
6176 Make_Selected_Component
(Loc
,
6177 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6179 Make_Identifier
(Loc
,
6180 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6181 Alternatives
=> Var_Alts
);
6185 -- Add the variant case statement to the list of statements
6187 if Present
(Var_Case
) then
6188 Append_To
(Stmts
, Var_Case
);
6191 -- If the component list did not have any controlled components
6192 -- nor variants, return null.
6194 if Is_Empty_List
(Stmts
) then
6195 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6199 end Process_Component_List_For_Adjust
;
6201 -- Start of processing for Build_Adjust_Statements
6204 Finalizer_Decls
:= New_List
;
6205 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6207 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6208 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6213 -- Create an adjust sequence for all record components
6215 if Present
(Component_List
(Rec_Def
)) then
6217 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6220 -- A derived record type must adjust all inherited components. This
6221 -- action poses the following problem:
6223 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6228 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6230 -- Deep_Adjust (Obj._parent);
6235 -- Adjusting the derived type will invoke Adjust of the parent and
6236 -- then that of the derived type. This is undesirable because both
6237 -- routines may modify shared components. Only the Adjust of the
6238 -- derived type should be invoked.
6240 -- To prevent this double adjustment of shared components,
6241 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6243 -- procedure Deep_Adjust
6244 -- (Obj : in out Some_Type;
6245 -- Flag : Boolean := True)
6253 -- When Deep_Adjust is invokes for field _parent, a value of False is
6254 -- provided for the flag:
6256 -- Deep_Adjust (Obj._parent, False);
6258 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6260 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6265 if Needs_Finalization
(Par_Typ
) then
6269 Make_Selected_Component
(Loc
,
6270 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6272 Make_Identifier
(Loc
, Name_uParent
)),
6274 For_Parent
=> True);
6277 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6279 -- begin -- Exceptions OK
6280 -- Deep_Adjust (V._parent, False);
6282 -- when Id : others =>
6283 -- if not Raised then
6285 -- Save_Occurrence (E,
6286 -- Get_Current_Excep.all.all);
6290 if Present
(Call
) then
6293 if Exceptions_OK
then
6295 Make_Block_Statement
(Loc
,
6296 Handled_Statement_Sequence
=>
6297 Make_Handled_Sequence_Of_Statements
(Loc
,
6298 Statements
=> New_List
(Adj_Stmt
),
6299 Exception_Handlers
=> New_List
(
6300 Build_Exception_Handler
(Finalizer_Data
))));
6303 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6309 -- Adjust the object. This action must be performed last after all
6310 -- components have been adjusted.
6312 if Is_Controlled
(Typ
) then
6318 Proc
:= Find_Prim_Op
(Typ
, Name_Adjust
);
6322 -- Adjust (V); -- No_Exception_Propagation
6324 -- begin -- Exception handlers allowed
6328 -- if not Raised then
6330 -- Save_Occurrence (E,
6331 -- Get_Current_Excep.all.all);
6336 if Present
(Proc
) then
6338 Make_Procedure_Call_Statement
(Loc
,
6339 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6340 Parameter_Associations
=> New_List
(
6341 Make_Identifier
(Loc
, Name_V
)));
6343 if Exceptions_OK
then
6345 Make_Block_Statement
(Loc
,
6346 Handled_Statement_Sequence
=>
6347 Make_Handled_Sequence_Of_Statements
(Loc
,
6348 Statements
=> New_List
(Adj_Stmt
),
6349 Exception_Handlers
=> New_List
(
6350 Build_Exception_Handler
6351 (Finalizer_Data
))));
6354 Append_To
(Bod_Stmts
,
6355 Make_If_Statement
(Loc
,
6356 Condition
=> Make_Identifier
(Loc
, Name_F
),
6357 Then_Statements
=> New_List
(Adj_Stmt
)));
6362 -- At this point either all adjustment statements have been generated
6363 -- or the type is not controlled.
6365 if Is_Empty_List
(Bod_Stmts
) then
6366 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6372 -- Abort : constant Boolean := Triggered_By_Abort;
6374 -- Abort : constant Boolean := False; -- no abort
6376 -- E : Exception_Occurence;
6377 -- Raised : Boolean := False;
6380 -- <adjust statements>
6382 -- if Raised and then not Abort then
6383 -- Raise_From_Controlled_Operation (E);
6388 if Exceptions_OK
then
6389 Append_To
(Bod_Stmts
,
6390 Build_Raise_Statement
(Finalizer_Data
));
6395 Make_Block_Statement
(Loc
,
6398 Handled_Statement_Sequence
=>
6399 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6401 end Build_Adjust_Statements
;
6403 -------------------------------
6404 -- Build_Finalize_Statements --
6405 -------------------------------
6407 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6408 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6409 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6410 Bod_Stmts
: List_Id
;
6412 Finalizer_Data
: Finalization_Exception_Data
;
6413 Finalizer_Decls
: List_Id
:= No_List
;
6417 Exceptions_OK
: constant Boolean :=
6418 not Restriction_Active
(No_Exception_Propagation
);
6420 function Process_Component_List_For_Finalize
6421 (Comps
: Node_Id
) return List_Id
;
6422 -- Build all necessary finalization statements for a single component
6423 -- list. The statements may include a jump circuitry if flag Is_Local
6426 -----------------------------------------
6427 -- Process_Component_List_For_Finalize --
6428 -----------------------------------------
6430 function Process_Component_List_For_Finalize
6431 (Comps
: Node_Id
) return List_Id
6434 Counter_Id
: Entity_Id
;
6436 Decl_Id
: Entity_Id
;
6437 Decl_Typ
: Entity_Id
;
6440 Jump_Block
: Node_Id
;
6442 Label_Id
: Entity_Id
;
6446 procedure Process_Component_For_Finalize
6451 -- Process the declaration of a single controlled component. If
6452 -- flag Is_Local is enabled, create the corresponding label and
6453 -- jump circuitry. Alts is the list of case alternatives, Decls
6454 -- is the top level declaration list where labels are declared
6455 -- and Stmts is the list of finalization actions.
6457 ------------------------------------
6458 -- Process_Component_For_Finalize --
6459 ------------------------------------
6461 procedure Process_Component_For_Finalize
6467 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6468 Typ
: constant Entity_Id
:= Etype
(Id
);
6475 Label_Id
: Entity_Id
;
6482 Make_Identifier
(Loc
,
6483 Chars
=> New_External_Name
('L', Num_Comps
));
6484 Set_Entity
(Label_Id
,
6485 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6486 Label
:= Make_Label
(Loc
, Label_Id
);
6489 Make_Implicit_Label_Declaration
(Loc
,
6490 Defining_Identifier
=> Entity
(Label_Id
),
6491 Label_Construct
=> Label
));
6498 Make_Case_Statement_Alternative
(Loc
,
6499 Discrete_Choices
=> New_List
(
6500 Make_Integer_Literal
(Loc
, Num_Comps
)),
6502 Statements
=> New_List
(
6503 Make_Goto_Statement
(Loc
,
6505 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6510 Append_To
(Stmts
, Label
);
6512 -- Decrease the number of components to be processed.
6513 -- This action yields a new Label_Id in future calls.
6515 Num_Comps
:= Num_Comps
- 1;
6520 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6522 -- begin -- Exception handlers allowed
6523 -- [Deep_]Finalize (V.Id);
6526 -- if not Raised then
6528 -- Save_Occurrence (E,
6529 -- Get_Current_Excep.all.all);
6536 Make_Selected_Component
(Loc
,
6537 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6538 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6541 if not Restriction_Active
(No_Exception_Propagation
) then
6543 Make_Block_Statement
(Loc
,
6544 Handled_Statement_Sequence
=>
6545 Make_Handled_Sequence_Of_Statements
(Loc
,
6546 Statements
=> New_List
(Fin_Stmt
),
6547 Exception_Handlers
=> New_List
(
6548 Build_Exception_Handler
(Finalizer_Data
))));
6551 Append_To
(Stmts
, Fin_Stmt
);
6552 end Process_Component_For_Finalize
;
6554 -- Start of processing for Process_Component_List_For_Finalize
6557 -- Perform an initial check, look for controlled and per-object
6558 -- constrained components.
6560 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6562 -- Create a state counter to service the current component list.
6563 -- This step is performed before the variants are inspected in
6564 -- order to generate the same state counter names as those from
6565 -- Build_Initialize_Statements.
6570 Counter
:= Counter
+ 1;
6573 Make_Defining_Identifier
(Loc
,
6574 Chars
=> New_External_Name
('C', Counter
));
6577 -- Process the component in the following order:
6579 -- 2) Per-object constrained components
6580 -- 3) Regular components
6582 -- Start with the variant parts
6585 if Present
(Variant_Part
(Comps
)) then
6587 Var_Alts
: constant List_Id
:= New_List
;
6591 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6592 while Present
(Var
) loop
6595 -- when <discrete choices> =>
6596 -- <finalize statements>
6598 Append_To
(Var_Alts
,
6599 Make_Case_Statement_Alternative
(Loc
,
6601 New_Copy_List
(Discrete_Choices
(Var
)),
6603 Process_Component_List_For_Finalize
(
6604 Component_List
(Var
))));
6606 Next_Non_Pragma
(Var
);
6610 -- case V.<discriminant> is
6611 -- when <discrete choices 1> =>
6612 -- <finalize statements 1>
6614 -- when <discrete choices N> =>
6615 -- <finalize statements N>
6619 Make_Case_Statement
(Loc
,
6621 Make_Selected_Component
(Loc
,
6622 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6624 Make_Identifier
(Loc
,
6625 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6626 Alternatives
=> Var_Alts
);
6630 -- The current component list does not have a single controlled
6631 -- component, however it may contain variants. Return the case
6632 -- statement for the variants or nothing.
6634 if Num_Comps
= 0 then
6635 if Present
(Var_Case
) then
6636 return New_List
(Var_Case
);
6638 return New_List
(Make_Null_Statement
(Loc
));
6642 -- Prepare all lists
6648 -- Process all per-object constrained components in reverse order
6651 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6652 while Present
(Decl
) loop
6653 Decl_Id
:= Defining_Identifier
(Decl
);
6654 Decl_Typ
:= Etype
(Decl_Id
);
6658 if Chars
(Decl_Id
) /= Name_uParent
6659 and then Needs_Finalization
(Decl_Typ
)
6660 and then Has_Access_Constraint
(Decl_Id
)
6661 and then No
(Expression
(Decl
))
6663 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6666 Prev_Non_Pragma
(Decl
);
6670 -- Process the rest of the components in reverse order
6672 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
6673 while Present
(Decl
) loop
6674 Decl_Id
:= Defining_Identifier
(Decl
);
6675 Decl_Typ
:= Etype
(Decl_Id
);
6679 if Chars
(Decl_Id
) /= Name_uParent
6680 and then Needs_Finalization
(Decl_Typ
)
6682 -- Skip per-object constrained components since they were
6683 -- handled in the above step.
6685 if Has_Access_Constraint
(Decl_Id
)
6686 and then No
(Expression
(Decl
))
6690 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
6694 Prev_Non_Pragma
(Decl
);
6699 -- LN : label; -- If Is_Local is enabled
6704 -- case CounterX is .
6714 -- <<LN>> -- If Is_Local is enabled
6716 -- [Deep_]Finalize (V.CompY);
6718 -- when Id : others =>
6719 -- if not Raised then
6721 -- Save_Occurrence (E,
6722 -- Get_Current_Excep.all.all);
6726 -- <<L0>> -- If Is_Local is enabled
6731 -- Add the declaration of default jump location L0, its
6732 -- corresponding alternative and its place in the statements.
6734 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
6735 Set_Entity
(Label_Id
,
6736 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6737 Label
:= Make_Label
(Loc
, Label_Id
);
6739 Append_To
(Decls
, -- declaration
6740 Make_Implicit_Label_Declaration
(Loc
,
6741 Defining_Identifier
=> Entity
(Label_Id
),
6742 Label_Construct
=> Label
));
6744 Append_To
(Alts
, -- alternative
6745 Make_Case_Statement_Alternative
(Loc
,
6746 Discrete_Choices
=> New_List
(
6747 Make_Others_Choice
(Loc
)),
6749 Statements
=> New_List
(
6750 Make_Goto_Statement
(Loc
,
6751 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6753 Append_To
(Stmts
, Label
); -- statement
6755 -- Create the jump block
6758 Make_Case_Statement
(Loc
,
6759 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
6760 Alternatives
=> Alts
));
6764 Make_Block_Statement
(Loc
,
6765 Declarations
=> Decls
,
6766 Handled_Statement_Sequence
=>
6767 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
6769 if Present
(Var_Case
) then
6770 return New_List
(Var_Case
, Jump_Block
);
6772 return New_List
(Jump_Block
);
6774 end Process_Component_List_For_Finalize
;
6776 -- Start of processing for Build_Finalize_Statements
6779 Finalizer_Decls
:= New_List
;
6780 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6782 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6783 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6788 -- Create a finalization sequence for all record components
6790 if Present
(Component_List
(Rec_Def
)) then
6792 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
6795 -- A derived record type must finalize all inherited components. This
6796 -- action poses the following problem:
6798 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6803 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6805 -- Deep_Finalize (Obj._parent);
6810 -- Finalizing the derived type will invoke Finalize of the parent and
6811 -- then that of the derived type. This is undesirable because both
6812 -- routines may modify shared components. Only the Finalize of the
6813 -- derived type should be invoked.
6815 -- To prevent this double adjustment of shared components,
6816 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6818 -- procedure Deep_Finalize
6819 -- (Obj : in out Some_Type;
6820 -- Flag : Boolean := True)
6828 -- When Deep_Finalize is invokes for field _parent, a value of False
6829 -- is provided for the flag:
6831 -- Deep_Finalize (Obj._parent, False);
6833 if Is_Tagged_Type
(Typ
)
6834 and then Is_Derived_Type
(Typ
)
6837 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6842 if Needs_Finalization
(Par_Typ
) then
6846 Make_Selected_Component
(Loc
,
6847 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6849 Make_Identifier
(Loc
, Name_uParent
)),
6851 For_Parent
=> True);
6854 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6856 -- begin -- Exceptions OK
6857 -- Deep_Finalize (V._parent, False);
6859 -- when Id : others =>
6860 -- if not Raised then
6862 -- Save_Occurrence (E,
6863 -- Get_Current_Excep.all.all);
6867 if Present
(Call
) then
6870 if Exceptions_OK
then
6872 Make_Block_Statement
(Loc
,
6873 Handled_Statement_Sequence
=>
6874 Make_Handled_Sequence_Of_Statements
(Loc
,
6875 Statements
=> New_List
(Fin_Stmt
),
6876 Exception_Handlers
=> New_List
(
6877 Build_Exception_Handler
6878 (Finalizer_Data
))));
6881 Append_To
(Bod_Stmts
, Fin_Stmt
);
6887 -- Finalize the object. This action must be performed first before
6888 -- all components have been finalized.
6890 if Is_Controlled
(Typ
)
6891 and then not Is_Local
6898 Proc
:= Find_Prim_Op
(Typ
, Name_Finalize
);
6902 -- Finalize (V); -- No_Exception_Propagation
6908 -- if not Raised then
6910 -- Save_Occurrence (E,
6911 -- Get_Current_Excep.all.all);
6916 if Present
(Proc
) then
6918 Make_Procedure_Call_Statement
(Loc
,
6919 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6920 Parameter_Associations
=> New_List
(
6921 Make_Identifier
(Loc
, Name_V
)));
6923 if Exceptions_OK
then
6925 Make_Block_Statement
(Loc
,
6926 Handled_Statement_Sequence
=>
6927 Make_Handled_Sequence_Of_Statements
(Loc
,
6928 Statements
=> New_List
(Fin_Stmt
),
6929 Exception_Handlers
=> New_List
(
6930 Build_Exception_Handler
6931 (Finalizer_Data
))));
6934 Prepend_To
(Bod_Stmts
,
6935 Make_If_Statement
(Loc
,
6936 Condition
=> Make_Identifier
(Loc
, Name_F
),
6937 Then_Statements
=> New_List
(Fin_Stmt
)));
6942 -- At this point either all finalization statements have been
6943 -- generated or the type is not controlled.
6945 if No
(Bod_Stmts
) then
6946 return New_List
(Make_Null_Statement
(Loc
));
6950 -- Abort : constant Boolean := Triggered_By_Abort;
6952 -- Abort : constant Boolean := False; -- no abort
6954 -- E : Exception_Occurence;
6955 -- Raised : Boolean := False;
6958 -- <finalize statements>
6960 -- if Raised and then not Abort then
6961 -- Raise_From_Controlled_Operation (E);
6966 if Exceptions_OK
then
6967 Append_To
(Bod_Stmts
,
6968 Build_Raise_Statement
(Finalizer_Data
));
6973 Make_Block_Statement
(Loc
,
6976 Handled_Statement_Sequence
=>
6977 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6979 end Build_Finalize_Statements
;
6981 -----------------------
6982 -- Parent_Field_Type --
6983 -----------------------
6985 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
6989 Field
:= First_Entity
(Typ
);
6990 while Present
(Field
) loop
6991 if Chars
(Field
) = Name_uParent
then
6992 return Etype
(Field
);
6995 Next_Entity
(Field
);
6998 -- A derived tagged type should always have a parent field
7000 raise Program_Error
;
7001 end Parent_Field_Type
;
7003 ---------------------------
7004 -- Preprocess_Components --
7005 ---------------------------
7007 procedure Preprocess_Components
7009 Num_Comps
: out Int
;
7010 Has_POC
: out Boolean)
7020 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7021 while Present
(Decl
) loop
7022 Id
:= Defining_Identifier
(Decl
);
7025 -- Skip field _parent
7027 if Chars
(Id
) /= Name_uParent
7028 and then Needs_Finalization
(Typ
)
7030 Num_Comps
:= Num_Comps
+ 1;
7032 if Has_Access_Constraint
(Id
)
7033 and then No
(Expression
(Decl
))
7039 Next_Non_Pragma
(Decl
);
7041 end Preprocess_Components
;
7043 -- Start of processing for Make_Deep_Record_Body
7047 when Address_Case
=>
7048 return Make_Finalize_Address_Stmts
(Typ
);
7051 return Build_Adjust_Statements
(Typ
);
7053 when Finalize_Case
=>
7054 return Build_Finalize_Statements
(Typ
);
7056 when Initialize_Case
=>
7058 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7061 if Is_Controlled
(Typ
) then
7063 Make_Procedure_Call_Statement
(Loc
,
7066 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7067 Parameter_Associations
=> New_List
(
7068 Make_Identifier
(Loc
, Name_V
))));
7074 end Make_Deep_Record_Body
;
7076 ----------------------
7077 -- Make_Final_Call --
7078 ----------------------
7080 function Make_Final_Call
7083 For_Parent
: Boolean := False) return Node_Id
7085 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7087 Fin_Id
: Entity_Id
:= Empty
;
7092 -- Recover the proper type which contains [Deep_]Finalize
7094 if Is_Class_Wide_Type
(Typ
) then
7095 Utyp
:= Root_Type
(Typ
);
7099 elsif Is_Concurrent_Type
(Typ
) then
7100 Utyp
:= Corresponding_Record_Type
(Typ
);
7102 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7104 elsif Is_Private_Type
(Typ
)
7105 and then Present
(Full_View
(Typ
))
7106 and then Is_Concurrent_Type
(Full_View
(Typ
))
7108 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7110 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7118 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7119 Set_Assignment_OK
(Ref
);
7121 -- Deal with non-tagged derivation of private views. If the parent type
7122 -- is a protected type, Deep_Finalize is found on the corresponding
7123 -- record of the ancestor.
7125 if Is_Untagged_Derivation
(Typ
) then
7126 if Is_Protected_Type
(Typ
) then
7127 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7129 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7131 if Is_Protected_Type
(Utyp
) then
7132 Utyp
:= Corresponding_Record_Type
(Utyp
);
7136 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7137 Set_Assignment_OK
(Ref
);
7140 -- Deal with derived private types which do not inherit primitives from
7141 -- their parents. In this case, [Deep_]Finalize can be found in the full
7142 -- view of the parent type.
7144 if Is_Tagged_Type
(Utyp
)
7145 and then Is_Derived_Type
(Utyp
)
7146 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7147 and then Is_Private_Type
(Etype
(Utyp
))
7148 and then Present
(Full_View
(Etype
(Utyp
)))
7150 Utyp
:= Full_View
(Etype
(Utyp
));
7151 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7152 Set_Assignment_OK
(Ref
);
7155 -- When dealing with the completion of a private type, use the base type
7158 if Utyp
/= Base_Type
(Utyp
) then
7159 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7161 Utyp
:= Base_Type
(Utyp
);
7162 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7163 Set_Assignment_OK
(Ref
);
7166 -- Select the appropriate version of Finalize
7169 if Has_Controlled_Component
(Utyp
) then
7170 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7173 -- Class-wide types, interfaces and types with controlled components
7175 elsif Is_Class_Wide_Type
(Typ
)
7176 or else Is_Interface
(Typ
)
7177 or else Has_Controlled_Component
(Utyp
)
7179 if Is_Tagged_Type
(Utyp
) then
7180 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7182 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7185 -- Derivations from [Limited_]Controlled
7187 elsif Is_Controlled
(Utyp
) then
7188 if Has_Controlled_Component
(Utyp
) then
7189 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7191 Fin_Id
:= Find_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7196 elsif Is_Tagged_Type
(Utyp
) then
7197 Fin_Id
:= Find_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7200 raise Program_Error
;
7203 if Present
(Fin_Id
) then
7205 -- When finalizing a class-wide object, do not convert to the root
7206 -- type in order to produce a dispatching call.
7208 if Is_Class_Wide_Type
(Typ
) then
7211 -- Ensure that a finalization routine is at least decorated in order
7212 -- to inspect the object parameter.
7214 elsif Analyzed
(Fin_Id
)
7215 or else Ekind
(Fin_Id
) = E_Procedure
7217 -- In certain cases, such as the creation of Stream_Read, the
7218 -- visible entity of the type is its full view. Since Stream_Read
7219 -- will have to create an object of type Typ, the local object
7220 -- will be finalzed by the scope finalizer generated later on. The
7221 -- object parameter of Deep_Finalize will always use the private
7222 -- view of the type. To avoid such a clash between a private and a
7223 -- full view, perform an unchecked conversion of the object
7224 -- reference to the private view.
7227 Formal_Typ
: constant Entity_Id
:=
7228 Etype
(First_Formal
(Fin_Id
));
7230 if Is_Private_Type
(Formal_Typ
)
7231 and then Present
(Full_View
(Formal_Typ
))
7232 and then Full_View
(Formal_Typ
) = Utyp
7234 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7238 Ref
:= Convert_View
(Fin_Id
, Ref
);
7241 return Make_Call
(Loc
, Fin_Id
, New_Copy_Tree
(Ref
), For_Parent
);
7245 end Make_Final_Call
;
7247 --------------------------------
7248 -- Make_Finalize_Address_Body --
7249 --------------------------------
7251 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7252 Is_Task
: constant Boolean :=
7253 Ekind
(Typ
) = E_Record_Type
7254 and then Is_Concurrent_Record_Type
(Typ
)
7255 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7257 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7258 Proc_Id
: Entity_Id
;
7262 -- The corresponding records of task types are not controlled by design.
7263 -- For the sake of completeness, create an empty Finalize_Address to be
7264 -- used in task class-wide allocations.
7269 -- Nothing to do if the type is not controlled or it already has a
7270 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7271 -- come from source. These are usually generated for completeness and
7272 -- do not need the Finalize_Address primitive.
7274 elsif not Needs_Finalization
(Typ
)
7275 or else Is_Abstract_Type
(Typ
)
7276 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7278 (Is_Class_Wide_Type
(Typ
)
7279 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7280 and then not Comes_From_Source
(Root_Type
(Typ
)))
7286 Make_Defining_Identifier
(Loc
,
7287 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7291 -- procedure <Typ>FD (V : System.Address) is
7293 -- null; -- for tasks
7295 -- declare -- for all other types
7296 -- type Pnn is access all Typ;
7297 -- for Pnn'Storage_Size use 0;
7299 -- [Deep_]Finalize (Pnn (V).all);
7304 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7306 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7310 Make_Subprogram_Body
(Loc
,
7312 Make_Procedure_Specification
(Loc
,
7313 Defining_Unit_Name
=> Proc_Id
,
7315 Parameter_Specifications
=> New_List
(
7316 Make_Parameter_Specification
(Loc
,
7317 Defining_Identifier
=>
7318 Make_Defining_Identifier
(Loc
, Name_V
),
7320 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7322 Declarations
=> No_List
,
7324 Handled_Statement_Sequence
=>
7325 Make_Handled_Sequence_Of_Statements
(Loc
,
7326 Statements
=> Stmts
)));
7328 Set_TSS
(Typ
, Proc_Id
);
7329 end Make_Finalize_Address_Body
;
7331 ---------------------------------
7332 -- Make_Finalize_Address_Stmts --
7333 ---------------------------------
7335 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7336 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7337 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7339 Desg_Typ
: Entity_Id
;
7343 if Is_Array_Type
(Typ
) then
7344 if Is_Constrained
(First_Subtype
(Typ
)) then
7345 Desg_Typ
:= First_Subtype
(Typ
);
7347 Desg_Typ
:= Base_Type
(Typ
);
7350 -- Class-wide types of constrained root types
7352 elsif Is_Class_Wide_Type
(Typ
)
7353 and then Has_Discriminants
(Root_Type
(Typ
))
7355 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7358 Parent_Typ
: Entity_Id
;
7361 -- Climb the parent type chain looking for a non-constrained type
7363 Parent_Typ
:= Root_Type
(Typ
);
7364 while Parent_Typ
/= Etype
(Parent_Typ
)
7365 and then Has_Discriminants
(Parent_Typ
)
7367 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7369 Parent_Typ
:= Etype
(Parent_Typ
);
7372 -- Handle views created for tagged types with unknown
7375 if Is_Underlying_Record_View
(Parent_Typ
) then
7376 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7379 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7389 -- type Ptr_Typ is access all Typ;
7390 -- for Ptr_Typ'Storage_Size use 0;
7393 Make_Full_Type_Declaration
(Loc
,
7394 Defining_Identifier
=> Ptr_Typ
,
7396 Make_Access_To_Object_Definition
(Loc
,
7397 All_Present
=> True,
7398 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7400 Make_Attribute_Definition_Clause
(Loc
,
7401 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7402 Chars
=> Name_Storage_Size
,
7403 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7405 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7407 -- Unconstrained arrays require special processing in order to retrieve
7408 -- the elements. To achieve this, we have to skip the dope vector which
7409 -- lays in front of the elements and then use a thin pointer to perform
7410 -- the address-to-access conversion.
7412 if Is_Array_Type
(Typ
)
7413 and then not Is_Constrained
(First_Subtype
(Typ
))
7416 Dope_Id
: Entity_Id
;
7419 -- Ensure that Ptr_Typ a thin pointer, generate:
7420 -- for Ptr_Typ'Size use System.Address'Size;
7423 Make_Attribute_Definition_Clause
(Loc
,
7424 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7427 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7430 -- Dnn : constant Storage_Offset :=
7431 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7433 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7436 Make_Object_Declaration
(Loc
,
7437 Defining_Identifier
=> Dope_Id
,
7438 Constant_Present
=> True,
7439 Object_Definition
=>
7440 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7442 Make_Op_Divide
(Loc
,
7444 Make_Attribute_Reference
(Loc
,
7445 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7446 Attribute_Name
=> Name_Descriptor_Size
),
7448 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7450 -- Shift the address from the start of the dope vector to the
7451 -- start of the elements:
7455 -- Note that this is done through a wrapper routine since RTSfind
7456 -- cannot retrieve operations with string names of the form "+".
7459 Make_Function_Call
(Loc
,
7461 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7462 Parameter_Associations
=> New_List
(
7464 New_Occurrence_Of
(Dope_Id
, Loc
)));
7468 -- Create the block and the finalization call
7471 Make_Block_Statement
(Loc
,
7472 Declarations
=> Decls
,
7474 Handled_Statement_Sequence
=>
7475 Make_Handled_Sequence_Of_Statements
(Loc
,
7476 Statements
=> New_List
(
7479 Make_Explicit_Dereference
(Loc
,
7480 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7481 Typ
=> Desg_Typ
)))));
7482 end Make_Finalize_Address_Stmts
;
7484 -------------------------------------
7485 -- Make_Handler_For_Ctrl_Operation --
7486 -------------------------------------
7490 -- when E : others =>
7491 -- Raise_From_Controlled_Operation (E);
7496 -- raise Program_Error [finalize raised exception];
7498 -- depending on whether Raise_From_Controlled_Operation is available
7500 function Make_Handler_For_Ctrl_Operation
7501 (Loc
: Source_Ptr
) return Node_Id
7504 -- Choice parameter (for the first case above)
7506 Raise_Node
: Node_Id
;
7507 -- Procedure call or raise statement
7510 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7511 -- it to Raise_From_Controlled_Operation so that the original exception
7512 -- name and message can be recorded in the exception message for
7515 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7516 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7518 Make_Procedure_Call_Statement
(Loc
,
7521 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7522 Parameter_Associations
=> New_List
(
7523 New_Occurrence_Of
(E_Occ
, Loc
)));
7525 -- Restricted run-time: exception messages are not supported
7530 Make_Raise_Program_Error
(Loc
,
7531 Reason
=> PE_Finalize_Raised_Exception
);
7535 Make_Implicit_Exception_Handler
(Loc
,
7536 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7537 Choice_Parameter
=> E_Occ
,
7538 Statements
=> New_List
(Raise_Node
));
7539 end Make_Handler_For_Ctrl_Operation
;
7541 --------------------
7542 -- Make_Init_Call --
7543 --------------------
7545 function Make_Init_Call
7547 Typ
: Entity_Id
) return Node_Id
7549 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7556 -- Deal with the type and object reference. Depending on the context, an
7557 -- object reference may need several conversions.
7559 if Is_Concurrent_Type
(Typ
) then
7561 Utyp
:= Corresponding_Record_Type
(Typ
);
7562 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7564 elsif Is_Private_Type
(Typ
)
7565 and then Present
(Full_View
(Typ
))
7566 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
7569 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
7570 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
7578 Set_Assignment_OK
(Ref
);
7580 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7582 -- Deal with non-tagged derivation of private views
7584 if Is_Untagged_Derivation
(Typ
)
7585 and then not Is_Conc
7587 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7588 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7590 -- The following is to prevent problems with UC see 1.156 RH ???
7592 Set_Assignment_OK
(Ref
);
7595 -- If the underlying_type is a subtype, then we are dealing with the
7596 -- completion of a private type. We need to access the base type and
7597 -- generate a conversion to it.
7599 if Utyp
/= Base_Type
(Utyp
) then
7600 pragma Assert
(Is_Private_Type
(Typ
));
7601 Utyp
:= Base_Type
(Utyp
);
7602 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7605 -- Select the appropriate version of initialize
7607 if Has_Controlled_Component
(Utyp
) then
7608 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
7610 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
7611 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
7614 -- The object reference may need another conversion depending on the
7615 -- type of the formal and that of the actual.
7617 Ref
:= Convert_View
(Proc
, Ref
);
7620 -- [Deep_]Initialize (Ref);
7623 Make_Procedure_Call_Statement
(Loc
,
7625 New_Occurrence_Of
(Proc
, Loc
),
7626 Parameter_Associations
=> New_List
(Ref
));
7629 ------------------------------
7630 -- Make_Local_Deep_Finalize --
7631 ------------------------------
7633 function Make_Local_Deep_Finalize
7635 Nam
: Entity_Id
) return Node_Id
7637 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7641 Formals
:= New_List
(
7645 Make_Parameter_Specification
(Loc
,
7646 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7648 Out_Present
=> True,
7649 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
7651 -- F : Boolean := True
7653 Make_Parameter_Specification
(Loc
,
7654 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7655 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7656 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
7658 -- Add the necessary number of counters to represent the initialization
7659 -- state of an object.
7662 Make_Subprogram_Body
(Loc
,
7664 Make_Procedure_Specification
(Loc
,
7665 Defining_Unit_Name
=> Nam
,
7666 Parameter_Specifications
=> Formals
),
7668 Declarations
=> No_List
,
7670 Handled_Statement_Sequence
=>
7671 Make_Handled_Sequence_Of_Statements
(Loc
,
7672 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
7673 end Make_Local_Deep_Finalize
;
7675 ------------------------------------
7676 -- Make_Set_Finalize_Address_Call --
7677 ------------------------------------
7679 function Make_Set_Finalize_Address_Call
7682 Ptr_Typ
: Entity_Id
) return Node_Id
7684 Desig_Typ
: constant Entity_Id
:=
7685 Available_View
(Designated_Type
(Ptr_Typ
));
7686 Fin_Mas_Id
: constant Entity_Id
:= Finalization_Master
(Ptr_Typ
);
7687 Fin_Mas_Ref
: Node_Id
;
7691 -- If the context is a class-wide allocator, we use the class-wide type
7692 -- to obtain the proper Finalize_Address routine.
7694 if Is_Class_Wide_Type
(Desig_Typ
) then
7700 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
7701 Utyp
:= Full_View
(Utyp
);
7704 if Is_Concurrent_Type
(Utyp
) then
7705 Utyp
:= Corresponding_Record_Type
(Utyp
);
7709 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7711 -- Deal with non-tagged derivation of private views. If the parent is
7712 -- now known to be protected, the finalization routine is the one
7713 -- defined on the corresponding record of the ancestor (corresponding
7714 -- records do not automatically inherit operations, but maybe they
7717 if Is_Untagged_Derivation
(Typ
) then
7718 if Is_Protected_Type
(Typ
) then
7719 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7721 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7723 if Is_Protected_Type
(Utyp
) then
7724 Utyp
:= Corresponding_Record_Type
(Utyp
);
7729 -- If the underlying_type is a subtype, we are dealing with the
7730 -- completion of a private type. We need to access the base type and
7731 -- generate a conversion to it.
7733 if Utyp
/= Base_Type
(Utyp
) then
7734 pragma Assert
(Is_Private_Type
(Typ
));
7736 Utyp
:= Base_Type
(Utyp
);
7739 Fin_Mas_Ref
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
7741 -- If the call is from a build-in-place function, the Master parameter
7742 -- is actually a pointer. Dereference it for the call.
7744 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
7745 Fin_Mas_Ref
:= Make_Explicit_Dereference
(Loc
, Fin_Mas_Ref
);
7749 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7752 Make_Procedure_Call_Statement
(Loc
,
7754 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
7755 Parameter_Associations
=> New_List
(
7757 Make_Attribute_Reference
(Loc
,
7759 New_Occurrence_Of
(TSS
(Utyp
, TSS_Finalize_Address
), Loc
),
7760 Attribute_Name
=> Name_Unrestricted_Access
)));
7761 end Make_Set_Finalize_Address_Call
;
7763 --------------------------
7764 -- Make_Transient_Block --
7765 --------------------------
7767 function Make_Transient_Block
7770 Par
: Node_Id
) return Node_Id
7772 Decls
: constant List_Id
:= New_List
;
7773 Instrs
: constant List_Id
:= New_List
(Action
);
7778 -- Case where only secondary stack use is involved
7780 if VM_Target
= No_VM
7781 and then Uses_Sec_Stack
(Current_Scope
)
7782 and then Nkind
(Action
) /= N_Simple_Return_Statement
7783 and then Nkind
(Par
) /= N_Exception_Handler
7789 S
:= Scope
(Current_Scope
);
7791 -- At the outer level, no need to release the sec stack
7793 if S
= Standard_Standard
then
7794 Set_Uses_Sec_Stack
(Current_Scope
, False);
7797 -- In a function, only release the sec stack if the function
7798 -- does not return on the sec stack otherwise the result may
7799 -- be lost. The caller is responsible for releasing.
7801 elsif Ekind
(S
) = E_Function
then
7802 Set_Uses_Sec_Stack
(Current_Scope
, False);
7804 if not Requires_Transient_Scope
(Etype
(S
)) then
7805 Set_Uses_Sec_Stack
(S
, True);
7806 Check_Restriction
(No_Secondary_Stack
, Action
);
7811 -- In a loop or entry we should install a block encompassing
7812 -- all the construct. For now just release right away.
7814 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
7817 -- In a procedure or a block, we release on exit of the
7818 -- procedure or block. ??? memory leak can be created by
7821 elsif Ekind_In
(S
, E_Block
, E_Procedure
) then
7822 Set_Uses_Sec_Stack
(S
, True);
7823 Check_Restriction
(No_Secondary_Stack
, Action
);
7824 Set_Uses_Sec_Stack
(Current_Scope
, False);
7834 -- Create the transient block. Set the parent now since the block itself
7835 -- is not part of the tree.
7838 Make_Block_Statement
(Loc
,
7839 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
7840 Declarations
=> Decls
,
7841 Handled_Statement_Sequence
=>
7842 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
7843 Has_Created_Identifier
=> True);
7844 Set_Parent
(Block
, Par
);
7846 -- Insert actions stuck in the transient scopes as well as all freezing
7847 -- nodes needed by those actions.
7849 Insert_Actions_In_Scope_Around
(Action
);
7851 Insert
:= Prev
(Action
);
7852 if Present
(Insert
) then
7853 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
7856 -- When the transient scope was established, we pushed the entry for the
7857 -- transient scope onto the scope stack, so that the scope was active
7858 -- for the installation of finalizable entities etc. Now we must remove
7859 -- this entry, since we have constructed a proper block.
7864 end Make_Transient_Block
;
7866 ------------------------
7867 -- Node_To_Be_Wrapped --
7868 ------------------------
7870 function Node_To_Be_Wrapped
return Node_Id
is
7872 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
7873 end Node_To_Be_Wrapped
;
7875 ----------------------------
7876 -- Set_Node_To_Be_Wrapped --
7877 ----------------------------
7879 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
7881 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
7882 end Set_Node_To_Be_Wrapped
;
7884 ----------------------------------
7885 -- Store_After_Actions_In_Scope --
7886 ----------------------------------
7888 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
7889 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7892 if Present
(SE
.Actions_To_Be_Wrapped_After
) then
7893 Insert_List_Before_And_Analyze
(
7894 First
(SE
.Actions_To_Be_Wrapped_After
), L
);
7897 SE
.Actions_To_Be_Wrapped_After
:= L
;
7899 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7900 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7902 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7907 end Store_After_Actions_In_Scope
;
7909 -----------------------------------
7910 -- Store_Before_Actions_In_Scope --
7911 -----------------------------------
7913 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
7914 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
7917 if Present
(SE
.Actions_To_Be_Wrapped_Before
) then
7918 Insert_List_After_And_Analyze
(
7919 Last
(SE
.Actions_To_Be_Wrapped_Before
), L
);
7922 SE
.Actions_To_Be_Wrapped_Before
:= L
;
7924 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
7925 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
7927 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
7932 end Store_Before_Actions_In_Scope
;
7934 --------------------------------
7935 -- Wrap_Transient_Declaration --
7936 --------------------------------
7938 -- If a transient scope has been established during the processing of the
7939 -- Expression of an Object_Declaration, it is not possible to wrap the
7940 -- declaration into a transient block as usual case, otherwise the object
7941 -- would be itself declared in the wrong scope. Therefore, all entities (if
7942 -- any) defined in the transient block are moved to the proper enclosing
7943 -- scope, furthermore, if they are controlled variables they are finalized
7944 -- right after the declaration. The finalization list of the transient
7945 -- scope is defined as a renaming of the enclosing one so during their
7946 -- initialization they will be attached to the proper finalization list.
7947 -- For instance, the following declaration :
7949 -- X : Typ := F (G (A), G (B));
7951 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7952 -- is expanded into :
7954 -- X : Typ := [ complex Expression-Action ];
7955 -- [Deep_]Finalize (_v1);
7956 -- [Deep_]Finalize (_v2);
7958 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
7965 Encl_S
:= Scope
(S
);
7967 -- Insert Actions kept in the Scope stack
7969 Insert_Actions_In_Scope_Around
(N
);
7971 -- If the declaration is consuming some secondary stack, mark the
7972 -- enclosing scope appropriately.
7974 Uses_SS
:= Uses_Sec_Stack
(S
);
7977 -- Put the local entities back in the enclosing scope, and set the
7978 -- Is_Public flag appropriately.
7980 Transfer_Entities
(S
, Encl_S
);
7982 -- Mark the enclosing dynamic scope so that the sec stack will be
7983 -- released upon its exit unless this is a function that returns on
7984 -- the sec stack in which case this will be done by the caller.
7986 if VM_Target
= No_VM
and then Uses_SS
then
7987 S
:= Enclosing_Dynamic_Scope
(S
);
7989 if Ekind
(S
) = E_Function
7990 and then Requires_Transient_Scope
(Etype
(S
))
7994 Set_Uses_Sec_Stack
(S
);
7995 Check_Restriction
(No_Secondary_Stack
, N
);
7998 end Wrap_Transient_Declaration
;
8000 -------------------------------
8001 -- Wrap_Transient_Expression --
8002 -------------------------------
8004 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8005 Loc
: constant Source_Ptr
:= Sloc
(N
);
8006 Expr
: Node_Id
:= Relocate_Node
(N
);
8007 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8008 Typ
: constant Entity_Id
:= Etype
(N
);
8015 -- M : constant Mark_Id := SS_Mark;
8016 -- procedure Finalizer is ... (See Build_Finalizer)
8019 -- Temp := <Expr>; -- general case
8020 -- Temp := (if <Expr> then True else False); -- boolean case
8026 -- A special case is made for Boolean expressions so that the back-end
8027 -- knows to generate a conditional branch instruction, if running with
8028 -- -fpreserve-control-flow. This ensures that a control flow change
8029 -- signalling the decision outcome occurs before the cleanup actions.
8031 if Opt
.Suppress_Control_Flow_Optimizations
8032 and then Is_Boolean_Type
(Typ
)
8035 Make_If_Expression
(Loc
,
8036 Expressions
=> New_List
(
8038 New_Occurrence_Of
(Standard_True
, Loc
),
8039 New_Occurrence_Of
(Standard_False
, Loc
)));
8042 Insert_Actions
(N
, New_List
(
8043 Make_Object_Declaration
(Loc
,
8044 Defining_Identifier
=> Temp
,
8045 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8047 Make_Transient_Block
(Loc
,
8049 Make_Assignment_Statement
(Loc
,
8050 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8051 Expression
=> Expr
),
8052 Par
=> Parent
(N
))));
8054 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8055 Analyze_And_Resolve
(N
, Typ
);
8056 end Wrap_Transient_Expression
;
8058 ------------------------------
8059 -- Wrap_Transient_Statement --
8060 ------------------------------
8062 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8063 Loc
: constant Source_Ptr
:= Sloc
(N
);
8064 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8069 -- M : constant Mark_Id := SS_Mark;
8070 -- procedure Finalizer is ... (See Build_Finalizer)
8080 Make_Transient_Block
(Loc
,
8082 Par
=> Parent
(N
)));
8084 -- With the scope stack back to normal, we can call analyze on the
8085 -- resulting block. At this point, the transient scope is being
8086 -- treated like a perfectly normal scope, so there is nothing
8087 -- special about it.
8089 -- Note: Wrap_Transient_Statement is called with the node already
8090 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8091 -- otherwise we would get a recursive processing of the node when
8092 -- we do this Analyze call.
8095 end Wrap_Transient_Statement
;