1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
154 -- Shared processing for Store_xxx_Actions_In_Scope
156 -----------------------------
157 -- Finalization Management --
158 -----------------------------
160 -- This part describe how Initialization/Adjustment/Finalization procedures
161 -- are generated and called. Two cases must be considered, types that are
162 -- Controlled (Is_Controlled flag set) and composite types that contain
163 -- controlled components (Has_Controlled_Component flag set). In the first
164 -- case the procedures to call are the user-defined primitive operations
165 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
166 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
167 -- of calling the former procedures on the controlled components.
169 -- For records with Has_Controlled_Component set, a hidden "controller"
170 -- component is inserted. This controller component contains its own
171 -- finalization list on which all controlled components are attached
172 -- creating an indirection on the upper-level Finalization list. This
173 -- technique facilitates the management of objects whose number of
174 -- controlled components changes during execution. This controller
175 -- component is itself controlled and is attached to the upper-level
176 -- finalization chain. Its adjust primitive is in charge of calling adjust
177 -- on the components and adjusting the finalization pointer to match their
178 -- new location (see a-finali.adb).
180 -- It is not possible to use a similar technique for arrays that have
181 -- Has_Controlled_Component set. In this case, deep procedures are
182 -- generated that call initialize/adjust/finalize + attachment or
183 -- detachment on the finalization list for all component.
185 -- Initialize calls: they are generated for declarations or dynamic
186 -- allocations of Controlled objects with no initial value. They are always
187 -- followed by an attachment to the current Finalization Chain. For the
188 -- dynamic allocation case this the chain attached to the scope of the
189 -- access type definition otherwise, this is the chain of the current
192 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
193 -- or dynamic allocations of Controlled objects with an initial value.
194 -- (2) after an assignment. In the first case they are followed by an
195 -- attachment to the final chain, in the second case they are not.
197 -- Finalization Calls: They are generated on (1) scope exit, (2)
198 -- assignments, (3) unchecked deallocations. In case (3) they have to
199 -- be detached from the final chain, in case (2) they must not and in
200 -- case (1) this is not important since we are exiting the scope anyway.
204 -- Type extensions will have a new record controller at each derivation
205 -- level containing controlled components. The record controller for
206 -- the parent/ancestor is attached to the finalization list of the
207 -- extension's record controller (i.e. the parent is like a component
208 -- of the extension).
210 -- For types that are both Is_Controlled and Has_Controlled_Components,
211 -- the record controller and the object itself are handled separately.
212 -- It could seem simpler to attach the object at the end of its record
213 -- controller but this would not tackle view conversions properly.
215 -- A classwide type can always potentially have controlled components
216 -- but the record controller of the corresponding actual type may not
217 -- be known at compile time so the dispatch table contains a special
218 -- field that allows computation of the offset of the record controller
219 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
221 -- Here is a simple example of the expansion of a controlled block :
225 -- Y : Controlled := Init;
231 -- Z : R := (C => X);
241 -- _L : System.FI.Finalizable_Ptr;
243 -- procedure _Clean is
246 -- System.FI.Finalize_List (_L);
254 -- Attach_To_Final_List (_L, Finalizable (X), 1);
255 -- at end: Abort_Undefer;
256 -- Y : Controlled := Init;
258 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
266 -- Deep_Initialize (W, _L, 1);
267 -- at end: Abort_Under;
268 -- Z : R := (C => X);
269 -- Deep_Adjust (Z, _L, 1);
273 -- Deep_Finalize (W, False);
274 -- <save W's final pointers>
276 -- <restore W's final pointers>
277 -- Deep_Adjust (W, _L, 0);
282 type Final_Primitives is
283 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
284 -- This enumeration type is defined in order to ease sharing code for
285 -- building finalization procedures for composite types.
287 Name_Of : constant array (Final_Primitives) of Name_Id :=
288 (Initialize_Case => Name_Initialize,
289 Adjust_Case => Name_Adjust,
290 Finalize_Case => Name_Finalize,
291 Address_Case => Name_Finalize_Address);
292 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
293 (Initialize_Case => TSS_Deep_Initialize,
294 Adjust_Case => TSS_Deep_Adjust,
295 Finalize_Case => TSS_Deep_Finalize,
296 Address_Case => TSS_Finalize_Address);
298 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
299 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
300 -- Has_Controlled_Component set and store them using the TSS mechanism.
302 function Build_Cleanup_Statements
304 Additional_Cleanup : List_Id) return List_Id;
305 -- Create the clean up calls for an asynchronous call block, task master,
306 -- protected subprogram body, task allocation block or task body, or
307 -- additional cleanup actions parked on a transient block. If the context
308 -- does not contain the above constructs, the routine returns an empty
311 procedure Build_Finalizer
313 Clean_Stmts : List_Id;
316 Defer_Abort : Boolean;
317 Fin_Id : out Entity_Id);
318 -- N may denote an accept statement, block, entry body, package body,
319 -- package spec, protected body, subprogram body, or a task body. Create
320 -- a procedure which contains finalization calls for all controlled objects
321 -- declared in the declarative or statement region of N. The calls are
322 -- built in reverse order relative to the original declarations. In the
323 -- case of a task body, the routine delays the creation of the finalizer
324 -- until all statements have been moved to the task body procedure.
325 -- Clean_Stmts may contain additional context-dependent code used to abort
326 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
327 -- Mark_Id is the secondary stack used in the current context or Empty if
328 -- missing. Top_Decls is the list on which the declaration of the finalizer
329 -- is attached in the non-package case. Defer_Abort indicates that the
330 -- statements passed in perform actions that require abort to be deferred,
331 -- such as for task termination. Fin_Id is the finalizer declaration
334 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
335 -- N is a construct which contains a handled sequence of statements, Fin_Id
336 -- is the entity of a finalizer. Create an At_End handler which covers the
337 -- statements of N and calls Fin_Id. If the handled statement sequence has
338 -- an exception handler, the statements will be wrapped in a block to avoid
339 -- unwanted interaction with the new At_End handler.
341 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
342 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
343 -- Has_Component_Component set and store them using the TSS mechanism.
345 procedure Check_Visibly_Controlled
346 (Prim : Final_Primitives;
348 E : in out Entity_Id;
349 Cref : in out Node_Id);
350 -- The controlled operation declared for a derived type may not be
351 -- overriding, if the controlled operations of the parent type are hidden,
352 -- for example when the parent is a private type whose full view is
353 -- controlled. For other primitive operations we modify the name of the
354 -- operation to indicate that it is not overriding, but this is not
355 -- possible for Initialize, etc. because they have to be retrievable by
356 -- name. Before generating the proper call to one of these operations we
357 -- check whether Typ is known to be controlled at the point of definition.
358 -- If it is not then we must retrieve the hidden operation of the parent
359 -- and use it instead. This is one case that might be solved more cleanly
360 -- once Overriding pragmas or declarations are in place.
362 function Convert_View
365 Ind : Pos := 1) return Node_Id;
366 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
367 -- argument being passed to it. Ind indicates which formal of procedure
368 -- Proc we are trying to match. This function will, if necessary, generate
369 -- a conversion between the partial and full view of Arg to match the type
370 -- of the formal of Proc, or force a conversion to the class-wide type in
371 -- the case where the operation is abstract.
373 function Enclosing_Function (E : Entity_Id) return Entity_Id;
374 -- Given an arbitrary entity, traverse the scope chain looking for the
375 -- first enclosing function. Return Empty if no function was found.
377 procedure Expand_Pragma_Initial_Condition (N : Node_Id);
378 -- Subsidiary to the expansion of package specs and bodies. Generate a
379 -- runtime check needed to verify the assumption introduced by pragma
380 -- Initial_Condition. N denotes the package spec or body.
386 Skip_Self : Boolean := False) return Node_Id;
387 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
388 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
389 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
390 -- action has an effect on the components only (if any).
392 function Make_Deep_Proc
393 (Prim : Final_Primitives;
395 Stmts : List_Id) return Node_Id;
396 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
397 -- Deep_Finalize procedures according to the first parameter, these
398 -- procedures operate on the type Typ. The Stmts parameter gives the body
401 function Make_Deep_Array_Body
402 (Prim : Final_Primitives;
403 Typ : Entity_Id) return List_Id;
404 -- This function generates the list of statements for implementing
405 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
406 -- the first parameter, these procedures operate on the array type Typ.
408 function Make_Deep_Record_Body
409 (Prim : Final_Primitives;
411 Is_Local : Boolean := False) return List_Id;
412 -- This function generates the list of statements for implementing
413 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
414 -- the first parameter, these procedures operate on the record type Typ.
415 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
416 -- whether the inner logic should be dictated by state counters.
418 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
419 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
420 -- Make_Deep_Record_Body. Generate the following statements:
423 -- type Acc_Typ is access all Typ;
424 -- for Acc_Typ'Storage_Size use 0;
426 -- [Deep_]Finalize (Acc_Typ (V).all);
429 ----------------------------
430 -- Build_Array_Deep_Procs --
431 ----------------------------
433 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
437 (Prim => Initialize_Case,
439 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
441 if not Is_Limited_View (Typ) then
444 (Prim => Adjust_Case,
446 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
449 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
450 -- suppressed since these routine will not be used.
452 if not Restriction_Active (No_Finalization) then
455 (Prim => Finalize_Case,
457 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
459 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
460 -- .NET do not support address arithmetic and unchecked conversions.
462 if VM_Target = No_VM then
465 (Prim => Address_Case,
467 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
470 end Build_Array_Deep_Procs;
472 ------------------------------
473 -- Build_Cleanup_Statements --
474 ------------------------------
476 function Build_Cleanup_Statements
478 Additional_Cleanup : List_Id) return List_Id
480 Is_Asynchronous_Call : constant Boolean :=
481 Nkind (N) = N_Block_Statement
482 and then Is_Asynchronous_Call_Block (N);
483 Is_Master : constant Boolean :=
484 Nkind (N) /= N_Entry_Body
485 and then Is_Task_Master (N);
486 Is_Protected_Body : constant Boolean :=
487 Nkind (N) = N_Subprogram_Body
488 and then Is_Protected_Subprogram_Body (N);
489 Is_Task_Allocation : constant Boolean :=
490 Nkind (N) = N_Block_Statement
491 and then Is_Task_Allocation_Block (N);
492 Is_Task_Body : constant Boolean :=
493 Nkind (Original_Node (N)) = N_Task_Body;
495 Loc : constant Source_Ptr := Sloc (N);
496 Stmts : constant List_Id := New_List;
500 if Restricted_Profile then
502 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
504 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
508 if Restriction_Active (No_Task_Hierarchy) = False then
509 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
512 -- Add statements to unlock the protected object parameter and to
513 -- undefer abort. If the context is a protected procedure and the object
514 -- has entries, call the entry service routine.
516 -- NOTE: The generated code references _object, a parameter to the
519 elsif Is_Protected_Body then
521 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
522 Conc_Typ : Entity_Id;
524 Param_Typ : Entity_Id;
527 -- Find the _object parameter representing the protected object
529 Param := First (Parameter_Specifications (Spec));
531 Param_Typ := Etype (Parameter_Type (Param));
533 if Ekind (Param_Typ) = E_Record_Type then
534 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
537 exit when No (Param) or else Present (Conc_Typ);
541 pragma Assert (Present (Param));
543 -- Historical note: In earlier versions of GNAT, there was code
544 -- at this point to generate stuff to service entry queues. It is
545 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
547 Build_Protected_Subprogram_Call_Cleanup
548 (Specification (N), Conc_Typ, Loc, Stmts);
551 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
552 -- tasks. Other unactivated tasks are completed by Complete_Task or
555 -- NOTE: The generated code references _chain, a local object
557 elsif Is_Task_Allocation then
560 -- Expunge_Unactivated_Tasks (_chain);
562 -- where _chain is the list of tasks created by the allocator but not
563 -- yet activated. This list will be empty unless the block completes
567 Make_Procedure_Call_Statement (Loc,
570 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
571 Parameter_Associations => New_List (
572 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
574 -- Attempt to cancel an asynchronous entry call whenever the block which
575 -- contains the abortable part is exited.
577 -- NOTE: The generated code references Cnn, a local object
579 elsif Is_Asynchronous_Call then
581 Cancel_Param : constant Entity_Id :=
582 Entry_Cancel_Parameter (Entity (Identifier (N)));
585 -- If it is of type Communication_Block, this must be a protected
586 -- entry call. Generate:
588 -- if Enqueued (Cancel_Param) then
589 -- Cancel_Protected_Entry_Call (Cancel_Param);
592 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
594 Make_If_Statement (Loc,
596 Make_Function_Call (Loc,
598 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
599 Parameter_Associations => New_List (
600 New_Occurrence_Of (Cancel_Param, Loc))),
602 Then_Statements => New_List (
603 Make_Procedure_Call_Statement (Loc,
606 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
607 Parameter_Associations => New_List (
608 New_Occurrence_Of (Cancel_Param, Loc))))));
610 -- Asynchronous delay, generate:
611 -- Cancel_Async_Delay (Cancel_Param);
613 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
615 Make_Procedure_Call_Statement (Loc,
617 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
618 Parameter_Associations => New_List (
619 Make_Attribute_Reference (Loc,
621 New_Occurrence_Of (Cancel_Param, Loc),
622 Attribute_Name => Name_Unchecked_Access))));
624 -- Task entry call, generate:
625 -- Cancel_Task_Entry_Call (Cancel_Param);
629 Make_Procedure_Call_Statement (Loc,
631 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
632 Parameter_Associations => New_List (
633 New_Occurrence_Of (Cancel_Param, Loc))));
638 Append_List_To (Stmts, Additional_Cleanup);
640 end Build_Cleanup_Statements;
642 -----------------------------
643 -- Build_Controlling_Procs --
644 -----------------------------
646 procedure Build_Controlling_Procs (Typ : Entity_Id) is
648 if Is_Array_Type (Typ) then
649 Build_Array_Deep_Procs (Typ);
650 else pragma Assert (Is_Record_Type (Typ));
651 Build_Record_Deep_Procs (Typ);
653 end Build_Controlling_Procs;
655 -----------------------------
656 -- Build_Exception_Handler --
657 -----------------------------
659 function Build_Exception_Handler
660 (Data : Finalization_Exception_Data;
661 For_Library : Boolean := False) return Node_Id
664 Proc_To_Call : Entity_Id;
669 pragma Assert (Present (Data.Raised_Id));
671 if Exception_Extra_Info
672 or else (For_Library and not Restricted_Profile)
674 if Exception_Extra_Info then
678 -- Get_Current_Excep.all
681 Make_Function_Call (Data.Loc,
683 Make_Explicit_Dereference (Data.Loc,
686 (RTE (RE_Get_Current_Excep), Data.Loc)));
693 Except := Make_Null (Data.Loc);
696 if For_Library and then not Restricted_Profile then
697 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
698 Actuals := New_List (Except);
701 Proc_To_Call := RTE (RE_Save_Occurrence);
703 -- The dereference occurs only when Exception_Extra_Info is true,
704 -- and therefore Except is not null.
708 New_Occurrence_Of (Data.E_Id, Data.Loc),
709 Make_Explicit_Dereference (Data.Loc, Except));
715 -- if not Raised_Id then
716 -- Raised_Id := True;
718 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
720 -- Save_Library_Occurrence (Get_Current_Excep.all);
725 Make_If_Statement (Data.Loc,
727 Make_Op_Not (Data.Loc,
728 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
730 Then_Statements => New_List (
731 Make_Assignment_Statement (Data.Loc,
732 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
733 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
735 Make_Procedure_Call_Statement (Data.Loc,
737 New_Occurrence_Of (Proc_To_Call, Data.Loc),
738 Parameter_Associations => Actuals))));
743 -- Raised_Id := True;
746 Make_Assignment_Statement (Data.Loc,
747 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
748 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
756 Make_Exception_Handler (Data.Loc,
757 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
758 Statements => Stmts);
759 end Build_Exception_Handler;
761 -------------------------------
762 -- Build_Finalization_Master --
763 -------------------------------
765 procedure Build_Finalization_Master
767 Ins_Node : Node_Id := Empty;
768 Encl_Scope : Entity_Id := Empty)
770 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
771 -- Determine whether entity E is inside a wrapper package created for
772 -- an instance of Ada.Unchecked_Deallocation.
774 ------------------------------
775 -- In_Deallocation_Instance --
776 ------------------------------
778 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
779 Pkg : constant Entity_Id := Scope (E);
780 Par : Node_Id := Empty;
783 if Ekind (Pkg) = E_Package
784 and then Present (Related_Instance (Pkg))
785 and then Ekind (Related_Instance (Pkg)) = E_Procedure
787 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
791 and then Chars (Par) = Name_Unchecked_Deallocation
792 and then Chars (Scope (Par)) = Name_Ada
793 and then Scope (Scope (Par)) = Standard_Standard;
797 end In_Deallocation_Instance;
801 Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
803 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
804 -- A finalization master created for a named access type is associated
805 -- with the full view (if applicable) as a consequence of freezing. The
806 -- full view criteria does not apply to anonymous access types because
807 -- those cannot have a private and a full view.
809 -- Start of processing for Build_Finalization_Master
812 -- Certain run-time configurations and targets do not provide support
813 -- for controlled types.
815 if Restriction_Active (No_Finalization) then
818 -- Do not process C, C++, CIL and Java types since it is assumend that
819 -- the non-Ada side will handle their clean up.
821 elsif Convention (Desig_Typ) = Convention_C
822 or else Convention (Desig_Typ) = Convention_CIL
823 or else Convention (Desig_Typ) = Convention_CPP
824 or else Convention (Desig_Typ) = Convention_Java
828 -- Various machinery such as freezing may have already created a
829 -- finalization master.
831 elsif Present (Finalization_Master (Ptr_Typ)) then
834 -- Do not process types that return on the secondary stack
836 elsif Present (Associated_Storage_Pool (Ptr_Typ))
837 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
841 -- Do not process types which may never allocate an object
843 elsif No_Pool_Assigned (Ptr_Typ) then
846 -- Do not process access types coming from Ada.Unchecked_Deallocation
847 -- instances. Even though the designated type may be controlled, the
848 -- access type will never participate in allocation.
850 elsif In_Deallocation_Instance (Ptr_Typ) then
853 -- Ignore the general use of anonymous access types unless the context
854 -- requires a finalization master.
856 elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
857 and then No (Ins_Node)
861 -- Do not process non-library access types when restriction No_Nested_
862 -- Finalization is in effect since masters are controlled objects.
864 elsif Restriction_Active (No_Nested_Finalization)
865 and then not Is_Library_Level_Entity (Ptr_Typ)
869 -- For .NET/JVM targets, allow the processing of access-to-controlled
870 -- types where the designated type is explicitly derived from [Limited_]
873 elsif VM_Target /= No_VM
874 and then not Is_Controlled (Desig_Typ)
878 -- Do not create finalization masters in SPARK mode because they result
879 -- in unwanted expansion.
881 -- More detail would be useful here ???
883 elsif GNATprove_Mode then
888 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
889 Actions : constant List_Id := New_List;
890 Fin_Mas_Id : Entity_Id;
895 -- Fnn : aliased Finalization_Master;
897 -- Source access types use fixed master names since the master is
898 -- inserted in the same source unit only once. The only exception to
899 -- this are instances using the same access type as generic actual.
901 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
903 Make_Defining_Identifier (Loc,
904 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
906 -- Internally generated access types use temporaries as their names
907 -- due to possible collision with identical names coming from other
911 Fin_Mas_Id := Make_Temporary (Loc, 'F');
915 Make_Object_Declaration (Loc,
916 Defining_Identifier => Fin_Mas_Id,
917 Aliased_Present => True,
919 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
921 -- Storage pool selection and attribute decoration of the generated
922 -- master. Since .NET/JVM compilers do not support pools, this step
925 if VM_Target = No_VM then
927 -- If the access type has a user-defined pool, use it as the base
928 -- storage medium for the finalization pool.
930 if Present (Associated_Storage_Pool (Ptr_Typ)) then
931 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
933 -- The default choice is the global pool
936 Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
937 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
941 -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
944 Make_Procedure_Call_Statement (Loc,
946 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
947 Parameter_Associations => New_List (
948 New_Occurrence_Of (Fin_Mas_Id, Loc),
949 Make_Attribute_Reference (Loc,
950 Prefix => New_Occurrence_Of (Pool_Id, Loc),
951 Attribute_Name => Name_Unrestricted_Access))));
954 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
956 -- A finalization master created for an anonymous access type must be
957 -- inserted before a context-dependent node.
959 if Present (Ins_Node) then
960 Push_Scope (Encl_Scope);
962 -- Treat use clauses as declarations and insert directly in front
965 if Nkind_In (Ins_Node, N_Use_Package_Clause,
968 Insert_List_Before_And_Analyze (Ins_Node, Actions);
970 Insert_Actions (Ins_Node, Actions);
975 elsif Ekind (Desig_Typ) = E_Incomplete_Type
976 and then Has_Completion_In_Body (Desig_Typ)
978 Insert_Actions (Parent (Ptr_Typ), Actions);
980 -- If the designated type is not yet frozen, then append the actions
981 -- to that type's freeze actions. The actions need to be appended to
982 -- whichever type is frozen later, similarly to what Freeze_Type does
983 -- for appending the storage pool declaration for an access type.
984 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
985 -- pool object before it's declared. However, it's not clear that
986 -- this is exactly the right test to accomplish that here. ???
988 elsif Present (Freeze_Node (Desig_Typ))
989 and then not Analyzed (Freeze_Node (Desig_Typ))
991 Append_Freeze_Actions (Desig_Typ, Actions);
993 elsif Present (Freeze_Node (Ptr_Typ))
994 and then not Analyzed (Freeze_Node (Ptr_Typ))
996 Append_Freeze_Actions (Ptr_Typ, Actions);
998 -- If there's a pool created locally for the access type, then we
999 -- need to ensure that the master gets created after the pool object,
1000 -- because otherwise we can have a forward reference, so we force the
1001 -- master actions to be inserted and analyzed after the pool entity.
1002 -- Note that both the access type and its designated type may have
1003 -- already been frozen and had their freezing actions analyzed at
1004 -- this point. (This seems a little unclean.???)
1006 elsif VM_Target = No_VM
1007 and then Scope (Pool_Id) = Scope (Ptr_Typ)
1009 Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
1012 Insert_Actions (Parent (Ptr_Typ), Actions);
1015 end Build_Finalization_Master;
1017 ---------------------
1018 -- Build_Finalizer --
1019 ---------------------
1021 procedure Build_Finalizer
1023 Clean_Stmts : List_Id;
1024 Mark_Id : Entity_Id;
1025 Top_Decls : List_Id;
1026 Defer_Abort : Boolean;
1027 Fin_Id : out Entity_Id)
1029 Acts_As_Clean : constant Boolean :=
1032 (Present (Clean_Stmts)
1033 and then Is_Non_Empty_List (Clean_Stmts));
1034 Exceptions_OK : constant Boolean :=
1035 not Restriction_Active (No_Exception_Propagation);
1036 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1037 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1038 For_Package : constant Boolean :=
1039 For_Package_Body or else For_Package_Spec;
1040 Loc : constant Source_Ptr := Sloc (N);
1042 -- NOTE: Local variable declarations are conservative and do not create
1043 -- structures right from the start. Entities and lists are created once
1044 -- it has been established that N has at least one controlled object.
1046 Components_Built : Boolean := False;
1047 -- A flag used to avoid double initialization of entities and lists. If
1048 -- the flag is set then the following variables have been initialized:
1054 Counter_Id : Entity_Id := Empty;
1055 Counter_Val : Int := 0;
1056 -- Name and value of the state counter
1058 Decls : List_Id := No_List;
1059 -- Declarative region of N (if available). If N is a package declaration
1060 -- Decls denotes the visible declarations.
1062 Finalizer_Data : Finalization_Exception_Data;
1063 -- Data for the exception
1065 Finalizer_Decls : List_Id := No_List;
1066 -- Local variable declarations. This list holds the label declarations
1067 -- of all jump block alternatives as well as the declaration of the
1068 -- local exception occurence and the raised flag:
1069 -- E : Exception_Occurrence;
1070 -- Raised : Boolean := False;
1071 -- L<counter value> : label;
1073 Finalizer_Insert_Nod : Node_Id := Empty;
1074 -- Insertion point for the finalizer body. Depending on the context
1075 -- (Nkind of N) and the individual grouping of controlled objects, this
1076 -- node may denote a package declaration or body, package instantiation,
1077 -- block statement or a counter update statement.
1079 Finalizer_Stmts : List_Id := No_List;
1080 -- The statement list of the finalizer body. It contains the following:
1082 -- Abort_Defer; -- Added if abort is allowed
1083 -- <call to Prev_At_End> -- Added if exists
1084 -- <cleanup statements> -- Added if Acts_As_Clean
1085 -- <jump block> -- Added if Has_Ctrl_Objs
1086 -- <finalization statements> -- Added if Has_Ctrl_Objs
1087 -- <stack release> -- Added if Mark_Id exists
1088 -- Abort_Undefer; -- Added if abort is allowed
1090 Has_Ctrl_Objs : Boolean := False;
1091 -- A general flag which denotes whether N has at least one controlled
1094 Has_Tagged_Types : Boolean := False;
1095 -- A general flag which indicates whether N has at least one library-
1096 -- level tagged type declaration.
1098 HSS : Node_Id := Empty;
1099 -- The sequence of statements of N (if available)
1101 Jump_Alts : List_Id := No_List;
1102 -- Jump block alternatives. Depending on the value of the state counter,
1103 -- the control flow jumps to a sequence of finalization statements. This
1104 -- list contains the following:
1106 -- when <counter value> =>
1107 -- goto L<counter value>;
1109 Jump_Block_Insert_Nod : Node_Id := Empty;
1110 -- Specific point in the finalizer statements where the jump block is
1113 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1114 -- The last controlled construct encountered when processing the top
1115 -- level lists of N. This can be a nested package, an instantiation or
1116 -- an object declaration.
1118 Prev_At_End : Entity_Id := Empty;
1119 -- The previous at end procedure of the handled statements block of N
1121 Priv_Decls : List_Id := No_List;
1122 -- The private declarations of N if N is a package declaration
1124 Spec_Id : Entity_Id := Empty;
1125 Spec_Decls : List_Id := Top_Decls;
1126 Stmts : List_Id := No_List;
1128 Tagged_Type_Stmts : List_Id := No_List;
1129 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1130 -- tagged types found in N.
1132 -----------------------
1133 -- Local subprograms --
1134 -----------------------
1136 procedure Build_Components;
1137 -- Create all entites and initialize all lists used in the creation of
1140 procedure Create_Finalizer;
1141 -- Create the spec and body of the finalizer and insert them in the
1142 -- proper place in the tree depending on the context.
1144 procedure Process_Declarations
1146 Preprocess : Boolean := False;
1147 Top_Level : Boolean := False);
1148 -- Inspect a list of declarations or statements which may contain
1149 -- objects that need finalization. When flag Preprocess is set, the
1150 -- routine will simply count the total number of controlled objects in
1151 -- Decls. Flag Top_Level denotes whether the processing is done for
1152 -- objects in nested package declarations or instances.
1154 procedure Process_Object_Declaration
1156 Has_No_Init : Boolean := False;
1157 Is_Protected : Boolean := False);
1158 -- Generate all the machinery associated with the finalization of a
1159 -- single object. Flag Has_No_Init is used to denote certain contexts
1160 -- where Decl does not have initialization call(s). Flag Is_Protected
1161 -- is set when Decl denotes a simple protected object.
1163 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1164 -- Generate all the code necessary to unregister the external tag of a
1167 ----------------------
1168 -- Build_Components --
1169 ----------------------
1171 procedure Build_Components is
1172 Counter_Decl : Node_Id;
1173 Counter_Typ : Entity_Id;
1174 Counter_Typ_Decl : Node_Id;
1177 pragma Assert (Present (Decls));
1179 -- This routine might be invoked several times when dealing with
1180 -- constructs that have two lists (either two declarative regions
1181 -- or declarations and statements). Avoid double initialization.
1183 if Components_Built then
1187 Components_Built := True;
1189 if Has_Ctrl_Objs then
1191 -- Create entities for the counter, its type, the local exception
1192 -- and the raised flag.
1194 Counter_Id := Make_Temporary (Loc, 'C');
1195 Counter_Typ := Make_Temporary (Loc, 'T');
1197 Finalizer_Decls := New_List;
1199 Build_Object_Declarations
1200 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1202 -- Since the total number of controlled objects is always known,
1203 -- build a subtype of Natural with precise bounds. This allows
1204 -- the backend to optimize the case statement. Generate:
1206 -- subtype Tnn is Natural range 0 .. Counter_Val;
1209 Make_Subtype_Declaration (Loc,
1210 Defining_Identifier => Counter_Typ,
1211 Subtype_Indication =>
1212 Make_Subtype_Indication (Loc,
1213 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1215 Make_Range_Constraint (Loc,
1219 Make_Integer_Literal (Loc, Uint_0),
1221 Make_Integer_Literal (Loc, Counter_Val)))));
1223 -- Generate the declaration of the counter itself:
1225 -- Counter : Integer := 0;
1228 Make_Object_Declaration (Loc,
1229 Defining_Identifier => Counter_Id,
1230 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1231 Expression => Make_Integer_Literal (Loc, 0));
1233 -- Set the type of the counter explicitly to prevent errors when
1234 -- examining object declarations later on.
1236 Set_Etype (Counter_Id, Counter_Typ);
1238 -- The counter and its type are inserted before the source
1239 -- declarations of N.
1241 Prepend_To (Decls, Counter_Decl);
1242 Prepend_To (Decls, Counter_Typ_Decl);
1244 -- The counter and its associated type must be manually analized
1245 -- since N has already been analyzed. Use the scope of the spec
1246 -- when inserting in a package.
1249 Push_Scope (Spec_Id);
1250 Analyze (Counter_Typ_Decl);
1251 Analyze (Counter_Decl);
1255 Analyze (Counter_Typ_Decl);
1256 Analyze (Counter_Decl);
1259 Jump_Alts := New_List;
1262 -- If the context requires additional clean up, the finalization
1263 -- machinery is added after the clean up code.
1265 if Acts_As_Clean then
1266 Finalizer_Stmts := Clean_Stmts;
1267 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1269 Finalizer_Stmts := New_List;
1272 if Has_Tagged_Types then
1273 Tagged_Type_Stmts := New_List;
1275 end Build_Components;
1277 ----------------------
1278 -- Create_Finalizer --
1279 ----------------------
1281 procedure Create_Finalizer is
1282 Body_Id : Entity_Id;
1285 Jump_Block : Node_Id;
1287 Label_Id : Entity_Id;
1289 function New_Finalizer_Name return Name_Id;
1290 -- Create a fully qualified name of a package spec or body finalizer.
1291 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1293 ------------------------
1294 -- New_Finalizer_Name --
1295 ------------------------
1297 function New_Finalizer_Name return Name_Id is
1298 procedure New_Finalizer_Name (Id : Entity_Id);
1299 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1300 -- has a non-standard scope, process the scope first.
1302 ------------------------
1303 -- New_Finalizer_Name --
1304 ------------------------
1306 procedure New_Finalizer_Name (Id : Entity_Id) is
1308 if Scope (Id) = Standard_Standard then
1309 Get_Name_String (Chars (Id));
1312 New_Finalizer_Name (Scope (Id));
1313 Add_Str_To_Name_Buffer ("__");
1314 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1316 end New_Finalizer_Name;
1318 -- Start of processing for New_Finalizer_Name
1321 -- Create the fully qualified name of the enclosing scope
1323 New_Finalizer_Name (Spec_Id);
1326 -- __finalize_[spec|body]
1328 Add_Str_To_Name_Buffer ("__finalize_");
1330 if For_Package_Spec then
1331 Add_Str_To_Name_Buffer ("spec");
1333 Add_Str_To_Name_Buffer ("body");
1337 end New_Finalizer_Name;
1339 -- Start of processing for Create_Finalizer
1342 -- Step 1: Creation of the finalizer name
1344 -- Packages must use a distinct name for their finalizers since the
1345 -- binder will have to generate calls to them by name. The name is
1346 -- of the following form:
1348 -- xx__yy__finalize_[spec|body]
1351 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1352 Set_Has_Qualified_Name (Fin_Id);
1353 Set_Has_Fully_Qualified_Name (Fin_Id);
1355 -- The default name is _finalizer
1359 Make_Defining_Identifier (Loc,
1360 Chars => New_External_Name (Name_uFinalizer));
1362 -- The visibility semantics of AT_END handlers force a strange
1363 -- separation of spec and body for stack-related finalizers:
1365 -- declare : Enclosing_Scope
1366 -- procedure _finalizer;
1368 -- <controlled objects>
1369 -- procedure _finalizer is
1375 -- Both spec and body are within the same construct and scope, but
1376 -- the body is part of the handled sequence of statements. This
1377 -- placement confuses the elaboration mechanism on targets where
1378 -- AT_END handlers are expanded into "when all others" handlers:
1381 -- when all others =>
1382 -- _finalizer; -- appears to require elab checks
1387 -- Since the compiler guarantees that the body of a _finalizer is
1388 -- always inserted in the same construct where the AT_END handler
1389 -- resides, there is no need for elaboration checks.
1391 Set_Kill_Elaboration_Checks (Fin_Id);
1394 -- Step 2: Creation of the finalizer specification
1397 -- procedure Fin_Id;
1400 Make_Subprogram_Declaration (Loc,
1402 Make_Procedure_Specification (Loc,
1403 Defining_Unit_Name => Fin_Id));
1405 -- Step 3: Creation of the finalizer body
1407 if Has_Ctrl_Objs then
1409 -- Add L0, the default destination to the jump block
1411 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1412 Set_Entity (Label_Id,
1413 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1414 Label := Make_Label (Loc, Label_Id);
1419 Prepend_To (Finalizer_Decls,
1420 Make_Implicit_Label_Declaration (Loc,
1421 Defining_Identifier => Entity (Label_Id),
1422 Label_Construct => Label));
1428 Append_To (Jump_Alts,
1429 Make_Case_Statement_Alternative (Loc,
1430 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1431 Statements => New_List (
1432 Make_Goto_Statement (Loc,
1433 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1438 Append_To (Finalizer_Stmts, Label);
1440 -- Create the jump block which controls the finalization flow
1441 -- depending on the value of the state counter.
1444 Make_Case_Statement (Loc,
1445 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1446 Alternatives => Jump_Alts);
1448 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1449 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1451 Prepend_To (Finalizer_Stmts, Jump_Block);
1455 -- Add the library-level tagged type unregistration machinery before
1456 -- the jump block circuitry. This ensures that external tags will be
1457 -- removed even if a finalization exception occurs at some point.
1459 if Has_Tagged_Types then
1460 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1463 -- Add a call to the previous At_End handler if it exists. The call
1464 -- must always precede the jump block.
1466 if Present (Prev_At_End) then
1467 Prepend_To (Finalizer_Stmts,
1468 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1470 -- Clear the At_End handler since we have already generated the
1471 -- proper replacement call for it.
1473 Set_At_End_Proc (HSS, Empty);
1476 -- Release the secondary stack mark
1478 if Present (Mark_Id) then
1479 Append_To (Finalizer_Stmts,
1480 Make_Procedure_Call_Statement (Loc,
1482 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
1483 Parameter_Associations => New_List (
1484 New_Occurrence_Of (Mark_Id, Loc))));
1487 -- Protect the statements with abort defer/undefer. This is only when
1488 -- aborts are allowed and the clean up statements require deferral or
1489 -- there are controlled objects to be finalized.
1491 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1492 Prepend_To (Finalizer_Stmts,
1493 Make_Procedure_Call_Statement (Loc,
1494 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc)));
1496 Append_To (Finalizer_Stmts,
1497 Make_Procedure_Call_Statement (Loc,
1498 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc)));
1501 -- The local exception does not need to be reraised for library-level
1502 -- finalizers. Note that this action must be carried out after object
1503 -- clean up, secondary stack release and abort undeferral. Generate:
1505 -- if Raised and then not Abort then
1506 -- Raise_From_Controlled_Operation (E);
1509 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1510 Append_To (Finalizer_Stmts,
1511 Build_Raise_Statement (Finalizer_Data));
1515 -- procedure Fin_Id is
1516 -- Abort : constant Boolean := Triggered_By_Abort;
1518 -- Abort : constant Boolean := False; -- no abort
1520 -- E : Exception_Occurrence; -- All added if flag
1521 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1527 -- Abort_Defer; -- Added if abort is allowed
1528 -- <call to Prev_At_End> -- Added if exists
1529 -- <cleanup statements> -- Added if Acts_As_Clean
1530 -- <jump block> -- Added if Has_Ctrl_Objs
1531 -- <finalization statements> -- Added if Has_Ctrl_Objs
1532 -- <stack release> -- Added if Mark_Id exists
1533 -- Abort_Undefer; -- Added if abort is allowed
1534 -- <exception propagation> -- Added if Has_Ctrl_Objs
1537 -- Create the body of the finalizer
1539 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1542 Set_Has_Qualified_Name (Body_Id);
1543 Set_Has_Fully_Qualified_Name (Body_Id);
1547 Make_Subprogram_Body (Loc,
1549 Make_Procedure_Specification (Loc,
1550 Defining_Unit_Name => Body_Id),
1551 Declarations => Finalizer_Decls,
1552 Handled_Statement_Sequence =>
1553 Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1555 -- Step 4: Spec and body insertion, analysis
1559 -- If the package spec has private declarations, the finalizer
1560 -- body must be added to the end of the list in order to have
1561 -- visibility of all private controlled objects.
1563 if For_Package_Spec then
1564 if Present (Priv_Decls) then
1565 Append_To (Priv_Decls, Fin_Spec);
1566 Append_To (Priv_Decls, Fin_Body);
1568 Append_To (Decls, Fin_Spec);
1569 Append_To (Decls, Fin_Body);
1572 -- For package bodies, both the finalizer spec and body are
1573 -- inserted at the end of the package declarations.
1576 Append_To (Decls, Fin_Spec);
1577 Append_To (Decls, Fin_Body);
1580 -- Push the name of the package
1582 Push_Scope (Spec_Id);
1590 -- Create the spec for the finalizer. The At_End handler must be
1591 -- able to call the body which resides in a nested structure.
1595 -- procedure Fin_Id; -- Spec
1597 -- <objects and possibly statements>
1598 -- procedure Fin_Id is ... -- Body
1601 -- Fin_Id; -- At_End handler
1604 pragma Assert (Present (Spec_Decls));
1606 Append_To (Spec_Decls, Fin_Spec);
1609 -- When the finalizer acts solely as a clean up routine, the body
1610 -- is inserted right after the spec.
1612 if Acts_As_Clean and then not Has_Ctrl_Objs then
1613 Insert_After (Fin_Spec, Fin_Body);
1615 -- In all other cases the body is inserted after either:
1617 -- 1) The counter update statement of the last controlled object
1618 -- 2) The last top level nested controlled package
1619 -- 3) The last top level controlled instantiation
1622 -- Manually freeze the spec. This is somewhat of a hack because
1623 -- a subprogram is frozen when its body is seen and the freeze
1624 -- node appears right before the body. However, in this case,
1625 -- the spec must be frozen earlier since the At_End handler
1626 -- must be able to call it.
1629 -- procedure Fin_Id; -- Spec
1630 -- [Fin_Id] -- Freeze node
1634 -- Fin_Id; -- At_End handler
1637 Ensure_Freeze_Node (Fin_Id);
1638 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1639 Set_Is_Frozen (Fin_Id);
1641 -- In the case where the last construct to contain a controlled
1642 -- object is either a nested package, an instantiation or a
1643 -- freeze node, the body must be inserted directly after the
1646 if Nkind_In (Last_Top_Level_Ctrl_Construct,
1648 N_Package_Declaration,
1651 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1654 Insert_After (Finalizer_Insert_Nod, Fin_Body);
1659 end Create_Finalizer;
1661 --------------------------
1662 -- Process_Declarations --
1663 --------------------------
1665 procedure Process_Declarations
1667 Preprocess : Boolean := False;
1668 Top_Level : Boolean := False)
1673 Obj_Typ : Entity_Id;
1674 Pack_Id : Entity_Id;
1678 Old_Counter_Val : Int;
1679 -- This variable is used to determine whether a nested package or
1680 -- instance contains at least one controlled object.
1682 procedure Processing_Actions
1683 (Has_No_Init : Boolean := False;
1684 Is_Protected : Boolean := False);
1685 -- Depending on the mode of operation of Process_Declarations, either
1686 -- increment the controlled object counter, set the controlled object
1687 -- flag and store the last top level construct or process the current
1688 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1689 -- the current declaration may not have initialization proc(s). Flag
1690 -- Is_Protected should be set when the current declaration denotes a
1691 -- simple protected object.
1693 ------------------------
1694 -- Processing_Actions --
1695 ------------------------
1697 procedure Processing_Actions
1698 (Has_No_Init : Boolean := False;
1699 Is_Protected : Boolean := False)
1702 -- Library-level tagged type
1704 if Nkind (Decl) = N_Full_Type_Declaration then
1706 Has_Tagged_Types := True;
1708 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
1709 Last_Top_Level_Ctrl_Construct := Decl;
1713 Process_Tagged_Type_Declaration (Decl);
1716 -- Controlled object declaration
1720 Counter_Val := Counter_Val + 1;
1721 Has_Ctrl_Objs := True;
1723 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
1724 Last_Top_Level_Ctrl_Construct := Decl;
1728 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1731 end Processing_Actions;
1733 -- Start of processing for Process_Declarations
1736 if No (Decls) or else Is_Empty_List (Decls) then
1740 -- Process all declarations in reverse order
1742 Decl := Last_Non_Pragma (Decls);
1743 while Present (Decl) loop
1745 -- Library-level tagged types
1747 if Nkind (Decl) = N_Full_Type_Declaration then
1748 Typ := Defining_Identifier (Decl);
1750 if Is_Tagged_Type (Typ)
1751 and then Is_Library_Level_Entity (Typ)
1752 and then Convention (Typ) = Convention_Ada
1753 and then Present (Access_Disp_Table (Typ))
1754 and then RTE_Available (RE_Register_Tag)
1755 and then not No_Run_Time_Mode
1756 and then not Is_Abstract_Type (Typ)
1761 -- Regular object declarations
1763 elsif Nkind (Decl) = N_Object_Declaration then
1764 Obj_Id := Defining_Identifier (Decl);
1765 Obj_Typ := Base_Type (Etype (Obj_Id));
1766 Expr := Expression (Decl);
1768 -- Bypass any form of processing for objects which have their
1769 -- finalization disabled. This applies only to objects at the
1772 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
1775 -- Transient variables are treated separately in order to
1776 -- minimize the size of the generated code. For details, see
1777 -- Process_Transient_Objects.
1779 elsif Is_Processed_Transient (Obj_Id) then
1782 -- The object is of the form:
1783 -- Obj : Typ [:= Expr];
1785 -- Do not process the incomplete view of a deferred constant.
1786 -- Do not consider tag-to-class-wide conversions.
1788 elsif not Is_Imported (Obj_Id)
1789 and then Needs_Finalization (Obj_Typ)
1790 and then not (Ekind (Obj_Id) = E_Constant
1791 and then not Has_Completion (Obj_Id))
1792 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
1796 -- The object is of the form:
1797 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1799 -- Obj : Access_Typ :=
1800 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
1802 elsif Is_Access_Type (Obj_Typ)
1803 and then Needs_Finalization
1804 (Available_View (Designated_Type (Obj_Typ)))
1805 and then Present (Expr)
1807 (Is_Secondary_Stack_BIP_Func_Call (Expr)
1809 (Is_Non_BIP_Func_Call (Expr)
1810 and then not Is_Related_To_Func_Return (Obj_Id)))
1812 Processing_Actions (Has_No_Init => True);
1814 -- Processing for "hook" objects generated for controlled
1815 -- transients declared inside an Expression_With_Actions.
1817 elsif Is_Access_Type (Obj_Typ)
1818 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1819 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
1820 N_Object_Declaration
1821 and then Is_Finalizable_Transient
1822 (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
1824 Processing_Actions (Has_No_Init => True);
1826 -- Process intermediate results of an if expression with one
1827 -- of the alternatives using a controlled function call.
1829 elsif Is_Access_Type (Obj_Typ)
1830 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1831 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
1832 N_Defining_Identifier
1833 and then Present (Expr)
1834 and then Nkind (Expr) = N_Null
1836 Processing_Actions (Has_No_Init => True);
1838 -- Simple protected objects which use type System.Tasking.
1839 -- Protected_Objects.Protection to manage their locks should
1840 -- be treated as controlled since they require manual cleanup.
1841 -- The only exception is illustrated in the following example:
1844 -- type Ctrl is new Controlled ...
1845 -- procedure Finalize (Obj : in out Ctrl);
1849 -- package body Pkg is
1850 -- protected Prot is
1851 -- procedure Do_Something (Obj : in out Ctrl);
1854 -- protected body Prot is
1855 -- procedure Do_Something (Obj : in out Ctrl) is ...
1858 -- procedure Finalize (Obj : in out Ctrl) is
1860 -- Prot.Do_Something (Obj);
1864 -- Since for the most part entities in package bodies depend on
1865 -- those in package specs, Prot's lock should be cleaned up
1866 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1867 -- This act however attempts to invoke Do_Something and fails
1868 -- because the lock has disappeared.
1870 elsif Ekind (Obj_Id) = E_Variable
1871 and then not In_Library_Level_Package_Body (Obj_Id)
1873 (Is_Simple_Protected_Type (Obj_Typ)
1874 or else Has_Simple_Protected_Object (Obj_Typ))
1876 Processing_Actions (Is_Protected => True);
1879 -- Specific cases of object renamings
1881 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
1882 Obj_Id := Defining_Identifier (Decl);
1883 Obj_Typ := Base_Type (Etype (Obj_Id));
1885 -- Bypass any form of processing for objects which have their
1886 -- finalization disabled. This applies only to objects at the
1889 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
1892 -- Return object of a build-in-place function. This case is
1893 -- recognized and marked by the expansion of an extended return
1894 -- statement (see Expand_N_Extended_Return_Statement).
1896 elsif Needs_Finalization (Obj_Typ)
1897 and then Is_Return_Object (Obj_Id)
1898 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1900 Processing_Actions (Has_No_Init => True);
1902 -- Detect a case where a source object has been initialized by
1903 -- a controlled function call or another object which was later
1904 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
1906 -- Obj1 : CW_Type := Src_Obj;
1907 -- Obj2 : CW_Type := Function_Call (...);
1909 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1910 -- Tmp : ... := Function_Call (...)'reference;
1911 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1913 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
1914 Processing_Actions (Has_No_Init => True);
1917 -- Inspect the freeze node of an access-to-controlled type and
1918 -- look for a delayed finalization master. This case arises when
1919 -- the freeze actions are inserted at a later time than the
1920 -- expansion of the context. Since Build_Finalizer is never called
1921 -- on a single construct twice, the master will be ultimately
1922 -- left out and never finalized. This is also needed for freeze
1923 -- actions of designated types themselves, since in some cases the
1924 -- finalization master is associated with a designated type's
1925 -- freeze node rather than that of the access type (see handling
1926 -- for freeze actions in Build_Finalization_Master).
1928 elsif Nkind (Decl) = N_Freeze_Entity
1929 and then Present (Actions (Decl))
1931 Typ := Entity (Decl);
1933 if (Is_Access_Type (Typ)
1934 and then not Is_Access_Subprogram_Type (Typ)
1935 and then Needs_Finalization
1936 (Available_View (Designated_Type (Typ))))
1937 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
1939 Old_Counter_Val := Counter_Val;
1941 -- Freeze nodes are considered to be identical to packages
1942 -- and blocks in terms of nesting. The difference is that
1943 -- a finalization master created inside the freeze node is
1944 -- at the same nesting level as the node itself.
1946 Process_Declarations (Actions (Decl), Preprocess);
1948 -- The freeze node contains a finalization master
1952 and then No (Last_Top_Level_Ctrl_Construct)
1953 and then Counter_Val > Old_Counter_Val
1955 Last_Top_Level_Ctrl_Construct := Decl;
1959 -- Nested package declarations, avoid generics
1961 elsif Nkind (Decl) = N_Package_Declaration then
1962 Spec := Specification (Decl);
1963 Pack_Id := Defining_Unit_Name (Spec);
1965 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
1966 Pack_Id := Defining_Identifier (Pack_Id);
1969 if Ekind (Pack_Id) /= E_Generic_Package then
1970 Old_Counter_Val := Counter_Val;
1971 Process_Declarations
1972 (Private_Declarations (Spec), Preprocess);
1973 Process_Declarations
1974 (Visible_Declarations (Spec), Preprocess);
1976 -- Either the visible or the private declarations contain a
1977 -- controlled object. The nested package declaration is the
1978 -- last such construct.
1982 and then No (Last_Top_Level_Ctrl_Construct)
1983 and then Counter_Val > Old_Counter_Val
1985 Last_Top_Level_Ctrl_Construct := Decl;
1989 -- Nested package bodies, avoid generics
1991 elsif Nkind (Decl) = N_Package_Body then
1992 Spec := Corresponding_Spec (Decl);
1994 if Ekind (Spec) /= E_Generic_Package then
1995 Old_Counter_Val := Counter_Val;
1996 Process_Declarations (Declarations (Decl), Preprocess);
1998 -- The nested package body is the last construct to contain
1999 -- a controlled object.
2003 and then No (Last_Top_Level_Ctrl_Construct)
2004 and then Counter_Val > Old_Counter_Val
2006 Last_Top_Level_Ctrl_Construct := Decl;
2010 -- Handle a rare case caused by a controlled transient variable
2011 -- created as part of a record init proc. The variable is wrapped
2012 -- in a block, but the block is not associated with a transient
2015 elsif Nkind (Decl) = N_Block_Statement
2016 and then Inside_Init_Proc
2018 Old_Counter_Val := Counter_Val;
2020 if Present (Handled_Statement_Sequence (Decl)) then
2021 Process_Declarations
2022 (Statements (Handled_Statement_Sequence (Decl)),
2026 Process_Declarations (Declarations (Decl), Preprocess);
2028 -- Either the declaration or statement list of the block has a
2029 -- controlled object.
2033 and then No (Last_Top_Level_Ctrl_Construct)
2034 and then Counter_Val > Old_Counter_Val
2036 Last_Top_Level_Ctrl_Construct := Decl;
2039 -- Handle the case where the original context has been wrapped in
2040 -- a block to avoid interference between exception handlers and
2041 -- At_End handlers. Treat the block as transparent and process its
2044 elsif Nkind (Decl) = N_Block_Statement
2045 and then Is_Finalization_Wrapper (Decl)
2047 if Present (Handled_Statement_Sequence (Decl)) then
2048 Process_Declarations
2049 (Statements (Handled_Statement_Sequence (Decl)),
2053 Process_Declarations (Declarations (Decl), Preprocess);
2056 Prev_Non_Pragma (Decl);
2058 end Process_Declarations;
2060 --------------------------------
2061 -- Process_Object_Declaration --
2062 --------------------------------
2064 procedure Process_Object_Declaration
2066 Has_No_Init : Boolean := False;
2067 Is_Protected : Boolean := False)
2069 Loc : constant Source_Ptr := Sloc (Decl);
2070 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2072 Init_Typ : Entity_Id;
2073 -- The initialization type of the related object declaration. Note
2074 -- that this is not necessarely the same type as Obj_Typ because of
2075 -- possible type derivations.
2077 Obj_Typ : Entity_Id;
2078 -- The type of the related object declaration
2080 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2081 -- Func_Id denotes a build-in-place function. Generate the following
2084 -- if BIPallocfrom > Secondary_Stack'Pos
2085 -- and then BIPfinalizationmaster /= null
2088 -- type Ptr_Typ is access Obj_Typ;
2089 -- for Ptr_Typ'Storage_Pool
2090 -- use Base_Pool (BIPfinalizationmaster);
2092 -- Free (Ptr_Typ (Temp));
2096 -- Obj_Typ is the type of the current object, Temp is the original
2097 -- allocation which Obj_Id renames.
2099 procedure Find_Last_Init
2100 (Last_Init : out Node_Id;
2101 Body_Insert : out Node_Id);
2102 -- Find the last initialization call related to object declaration
2103 -- Decl. Last_Init denotes the last initialization call which follows
2104 -- Decl. Body_Insert denotes a node where the finalizer body could be
2105 -- potentially inserted after (if blocks are involved).
2107 -----------------------------
2108 -- Build_BIP_Cleanup_Stmts --
2109 -----------------------------
2111 function Build_BIP_Cleanup_Stmts
2112 (Func_Id : Entity_Id) return Node_Id
2114 Decls : constant List_Id := New_List;
2115 Fin_Mas_Id : constant Entity_Id :=
2116 Build_In_Place_Formal
2117 (Func_Id, BIP_Finalization_Master);
2118 Func_Typ : constant Entity_Id := Etype (Func_Id);
2119 Temp_Id : constant Entity_Id :=
2120 Entity (Prefix (Name (Parent (Obj_Id))));
2124 Free_Stmt : Node_Id;
2125 Pool_Id : Entity_Id;
2126 Ptr_Typ : Entity_Id;
2130 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2132 Pool_Id := Make_Temporary (Loc, 'P');
2135 Make_Object_Renaming_Declaration (Loc,
2136 Defining_Identifier => Pool_Id,
2138 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2140 Make_Explicit_Dereference (Loc,
2142 Make_Function_Call (Loc,
2144 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2145 Parameter_Associations => New_List (
2146 Make_Explicit_Dereference (Loc,
2148 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2150 -- Create an access type which uses the storage pool of the
2151 -- caller's finalization master.
2154 -- type Ptr_Typ is access Func_Typ;
2156 Ptr_Typ := Make_Temporary (Loc, 'P');
2159 Make_Full_Type_Declaration (Loc,
2160 Defining_Identifier => Ptr_Typ,
2162 Make_Access_To_Object_Definition (Loc,
2163 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2165 -- Perform minor decoration in order to set the master and the
2166 -- storage pool attributes.
2168 Set_Ekind (Ptr_Typ, E_Access_Type);
2169 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2170 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2172 -- Create an explicit free statement. Note that the free uses the
2173 -- caller's pool expressed as a renaming.
2176 Make_Free_Statement (Loc,
2178 Unchecked_Convert_To (Ptr_Typ,
2179 New_Occurrence_Of (Temp_Id, Loc)));
2181 Set_Storage_Pool (Free_Stmt, Pool_Id);
2183 -- Create a block to house the dummy type and the instantiation as
2184 -- well as to perform the cleanup the temporary.
2190 -- Free (Ptr_Typ (Temp_Id));
2194 Make_Block_Statement (Loc,
2195 Declarations => Decls,
2196 Handled_Statement_Sequence =>
2197 Make_Handled_Sequence_Of_Statements (Loc,
2198 Statements => New_List (Free_Stmt)));
2201 -- if BIPfinalizationmaster /= null then
2205 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2206 Right_Opnd => Make_Null (Loc));
2208 -- For constrained or tagged results escalate the condition to
2209 -- include the allocation format. Generate:
2211 -- if BIPallocform > Secondary_Stack'Pos
2212 -- and then BIPfinalizationmaster /= null
2215 if not Is_Constrained (Func_Typ)
2216 or else Is_Tagged_Type (Func_Typ)
2219 Alloc : constant Entity_Id :=
2220 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2226 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2228 Make_Integer_Literal (Loc,
2230 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2232 Right_Opnd => Cond);
2242 Make_If_Statement (Loc,
2244 Then_Statements => New_List (Free_Blk));
2245 end Build_BIP_Cleanup_Stmts;
2247 --------------------
2248 -- Find_Last_Init --
2249 --------------------
2251 procedure Find_Last_Init
2252 (Last_Init : out Node_Id;
2253 Body_Insert : out Node_Id)
2255 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2256 -- Find the last initialization call within the statements of
2259 function Is_Init_Call (N : Node_Id) return Boolean;
2260 -- Determine whether node N denotes one of the initialization
2261 -- procedures of types Init_Typ or Obj_Typ.
2263 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2264 -- Given a statement which is part of a list, return the next
2265 -- statement while skipping over dynamic elab checks.
2267 -----------------------------
2268 -- Find_Last_Init_In_Block --
2269 -----------------------------
2271 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2272 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2276 -- Examine the individual statements of the block in reverse to
2277 -- locate the last initialization call.
2279 if Present (HSS) and then Present (Statements (HSS)) then
2280 Stmt := Last (Statements (HSS));
2281 while Present (Stmt) loop
2283 -- Peek inside nested blocks in case aborts are allowed
2285 if Nkind (Stmt) = N_Block_Statement then
2286 return Find_Last_Init_In_Block (Stmt);
2288 elsif Is_Init_Call (Stmt) then
2297 end Find_Last_Init_In_Block;
2303 function Is_Init_Call (N : Node_Id) return Boolean is
2304 function Is_Init_Proc_Of
2305 (Subp_Id : Entity_Id;
2306 Typ : Entity_Id) return Boolean;
2307 -- Determine whether subprogram Subp_Id is a valid init proc of
2310 ---------------------
2311 -- Is_Init_Proc_Of --
2312 ---------------------
2314 function Is_Init_Proc_Of
2315 (Subp_Id : Entity_Id;
2316 Typ : Entity_Id) return Boolean
2318 Deep_Init : Entity_Id := Empty;
2319 Prim_Init : Entity_Id := Empty;
2320 Type_Init : Entity_Id := Empty;
2323 -- Obtain all possible initialization routines of the
2324 -- related type and try to match the subprogram entity
2325 -- against one of them.
2329 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2331 -- Primitive Initialize
2333 if Is_Controlled (Typ) then
2334 Prim_Init := Find_Prim_Op (Typ, Name_Initialize);
2336 if Present (Prim_Init) then
2337 Prim_Init := Ultimate_Alias (Prim_Init);
2341 -- Type initialization routine
2343 if Has_Non_Null_Base_Init_Proc (Typ) then
2344 Type_Init := Base_Init_Proc (Typ);
2348 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2350 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2352 (Present (Type_Init) and then Subp_Id = Type_Init);
2353 end Is_Init_Proc_Of;
2357 Call_Id : Entity_Id;
2359 -- Start of processing for Is_Init_Call
2362 if Nkind (N) = N_Procedure_Call_Statement
2363 and then Nkind (Name (N)) = N_Identifier
2365 Call_Id := Entity (Name (N));
2367 -- Consider both the type of the object declaration and its
2368 -- related initialization type.
2371 Is_Init_Proc_Of (Call_Id, Init_Typ)
2373 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2379 -----------------------------
2380 -- Next_Suitable_Statement --
2381 -----------------------------
2383 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2384 Result : Node_Id := Next (Stmt);
2387 -- Skip over access-before-elaboration checks
2389 if Dynamic_Elaboration_Checks
2390 and then Nkind (Result) = N_Raise_Program_Error
2392 Result := Next (Result);
2396 end Next_Suitable_Statement;
2404 -- Start of processing for Find_Last_Init
2408 Body_Insert := Empty;
2410 -- Object renamings and objects associated with controlled
2411 -- function results do not require initialization.
2417 Stmt := Next_Suitable_Statement (Decl);
2419 -- A limited controlled object initialized by a function call uses
2420 -- the build-in-place machinery to obtain its value.
2422 -- Obj : Lim_Controlled_Type := Func_Call;
2426 -- Obj : Lim_Controlled_Type;
2427 -- type Ptr_Typ is access Lim_Controlled_Type;
2428 -- Temp : constant Ptr_Typ :=
2431 -- BIPaccess => Obj'Unrestricted_Access)'reference;
2433 -- In this scenario the declaration of the temporary acts as the
2434 -- last initialization statement.
2436 if Is_Limited_Type (Obj_Typ)
2437 and then Has_Init_Expression (Decl)
2438 and then No (Expression (Decl))
2440 while Present (Stmt) loop
2441 if Nkind (Stmt) = N_Object_Declaration
2442 and then Present (Expression (Stmt))
2443 and then Is_Object_Access_BIP_Func_Call
2444 (Expr => Expression (Stmt),
2454 -- In all other cases the initialization calls follow the related
2455 -- object. The general structure of object initialization built by
2456 -- routine Default_Initialize_Object is as follows:
2458 -- [begin -- aborts allowed
2460 -- Type_Init_Proc (Obj);
2461 -- [begin] -- exceptions allowed
2462 -- Deep_Initialize (Obj);
2463 -- [exception -- exceptions allowed
2465 -- Deep_Finalize (Obj, Self => False);
2468 -- [at end -- aborts allowed
2472 -- When aborts are allowed, the initialization calls are housed
2475 elsif Nkind (Stmt) = N_Block_Statement then
2476 Last_Init := Find_Last_Init_In_Block (Stmt);
2477 Body_Insert := Stmt;
2479 -- Otherwise the initialization calls follow the related object
2482 Stmt_2 := Next_Suitable_Statement (Stmt);
2484 -- Check for an optional call to Deep_Initialize which may
2485 -- appear within a block depending on whether the object has
2486 -- controlled components.
2488 if Present (Stmt_2) then
2489 if Nkind (Stmt_2) = N_Block_Statement then
2490 Call := Find_Last_Init_In_Block (Stmt_2);
2492 if Present (Call) then
2494 Body_Insert := Stmt_2;
2497 elsif Is_Init_Call (Stmt_2) then
2498 Last_Init := Stmt_2;
2499 Body_Insert := Last_Init;
2502 -- If the object lacks a call to Deep_Initialize, then it must
2503 -- have a call to its related type init proc.
2505 elsif Is_Init_Call (Stmt) then
2507 Body_Insert := Last_Init;
2515 Count_Ins : Node_Id;
2517 Fin_Stmts : List_Id;
2520 Label_Id : Entity_Id;
2523 -- Start of processing for Process_Object_Declaration
2526 -- Handle the object type and the reference to the object
2528 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2529 Obj_Typ := Base_Type (Etype (Obj_Id));
2532 if Is_Access_Type (Obj_Typ) then
2533 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2534 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2536 elsif Is_Concurrent_Type (Obj_Typ)
2537 and then Present (Corresponding_Record_Type (Obj_Typ))
2539 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2540 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2542 elsif Is_Private_Type (Obj_Typ)
2543 and then Present (Full_View (Obj_Typ))
2545 Obj_Typ := Full_View (Obj_Typ);
2546 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2548 elsif Obj_Typ /= Base_Type (Obj_Typ) then
2549 Obj_Typ := Base_Type (Obj_Typ);
2550 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2557 Set_Etype (Obj_Ref, Obj_Typ);
2559 -- Handle the initialization type of the object declaration
2561 Init_Typ := Obj_Typ;
2563 if Is_Private_Type (Init_Typ)
2564 and then Present (Full_View (Init_Typ))
2566 Init_Typ := Full_View (Init_Typ);
2568 elsif Is_Untagged_Derivation (Init_Typ) then
2569 Init_Typ := Root_Type (Init_Typ);
2576 -- Set a new value for the state counter and insert the statement
2577 -- after the object declaration. Generate:
2579 -- Counter := <value>;
2582 Make_Assignment_Statement (Loc,
2583 Name => New_Occurrence_Of (Counter_Id, Loc),
2584 Expression => Make_Integer_Literal (Loc, Counter_Val));
2586 -- Insert the counter after all initialization has been done. The
2587 -- place of insertion depends on the context. If an object is being
2588 -- initialized via an aggregate, then the counter must be inserted
2589 -- after the last aggregate assignment.
2591 if Ekind_In (Obj_Id, E_Constant, E_Variable)
2592 and then Present (Last_Aggregate_Assignment (Obj_Id))
2594 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
2597 -- In all other cases the counter is inserted after the last call to
2598 -- either [Deep_]Initialize or the type specific init proc.
2601 Find_Last_Init (Count_Ins, Body_Ins);
2604 Insert_After (Count_Ins, Inc_Decl);
2607 -- If the current declaration is the last in the list, the finalizer
2608 -- body needs to be inserted after the set counter statement for the
2609 -- current object declaration. This is complicated by the fact that
2610 -- the set counter statement may appear in abort deferred block. In
2611 -- that case, the proper insertion place is after the block.
2613 if No (Finalizer_Insert_Nod) then
2615 -- Insertion after an abort deffered block
2617 if Present (Body_Ins) then
2618 Finalizer_Insert_Nod := Body_Ins;
2620 Finalizer_Insert_Nod := Inc_Decl;
2624 -- Create the associated label with this object, generate:
2626 -- L<counter> : label;
2629 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2631 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2632 Label := Make_Label (Loc, Label_Id);
2634 Prepend_To (Finalizer_Decls,
2635 Make_Implicit_Label_Declaration (Loc,
2636 Defining_Identifier => Entity (Label_Id),
2637 Label_Construct => Label));
2639 -- Create the associated jump with this object, generate:
2641 -- when <counter> =>
2644 Prepend_To (Jump_Alts,
2645 Make_Case_Statement_Alternative (Loc,
2646 Discrete_Choices => New_List (
2647 Make_Integer_Literal (Loc, Counter_Val)),
2648 Statements => New_List (
2649 Make_Goto_Statement (Loc,
2650 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
2652 -- Insert the jump destination, generate:
2656 Append_To (Finalizer_Stmts, Label);
2658 -- Processing for simple protected objects. Such objects require
2659 -- manual finalization of their lock managers.
2661 if Is_Protected then
2662 Fin_Stmts := No_List;
2664 if Is_Simple_Protected_Type (Obj_Typ) then
2665 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2667 if Present (Fin_Call) then
2668 Fin_Stmts := New_List (Fin_Call);
2671 elsif Has_Simple_Protected_Object (Obj_Typ) then
2672 if Is_Record_Type (Obj_Typ) then
2673 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2674 elsif Is_Array_Type (Obj_Typ) then
2675 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2681 -- System.Tasking.Protected_Objects.Finalize_Protection
2689 if Present (Fin_Stmts) then
2690 Append_To (Finalizer_Stmts,
2691 Make_Block_Statement (Loc,
2692 Handled_Statement_Sequence =>
2693 Make_Handled_Sequence_Of_Statements (Loc,
2694 Statements => Fin_Stmts,
2696 Exception_Handlers => New_List (
2697 Make_Exception_Handler (Loc,
2698 Exception_Choices => New_List (
2699 Make_Others_Choice (Loc)),
2701 Statements => New_List (
2702 Make_Null_Statement (Loc)))))));
2705 -- Processing for regular controlled objects
2709 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2711 -- begin -- Exception handlers allowed
2712 -- [Deep_]Finalize (Obj);
2715 -- when Id : others =>
2716 -- if not Raised then
2718 -- Save_Occurrence (E, Id);
2727 -- For CodePeer, the exception handlers normally generated here
2728 -- generate complex flowgraphs which result in capacity problems.
2729 -- Omitting these handlers for CodePeer is justified as follows:
2731 -- If a handler is dead, then omitting it is surely ok
2733 -- If a handler is live, then CodePeer should flag the
2734 -- potentially-exception-raising construct that causes it
2735 -- to be live. That is what we are interested in, not what
2736 -- happens after the exception is raised.
2738 if Exceptions_OK and not CodePeer_Mode then
2739 Fin_Stmts := New_List (
2740 Make_Block_Statement (Loc,
2741 Handled_Statement_Sequence =>
2742 Make_Handled_Sequence_Of_Statements (Loc,
2743 Statements => New_List (Fin_Call),
2745 Exception_Handlers => New_List (
2746 Build_Exception_Handler
2747 (Finalizer_Data, For_Package)))));
2749 -- When exception handlers are prohibited, the finalization call
2750 -- appears unprotected. Any exception raised during finalization
2751 -- will bypass the circuitry which ensures the cleanup of all
2752 -- remaining objects.
2755 Fin_Stmts := New_List (Fin_Call);
2758 -- If we are dealing with a return object of a build-in-place
2759 -- function, generate the following cleanup statements:
2761 -- if BIPallocfrom > Secondary_Stack'Pos
2762 -- and then BIPfinalizationmaster /= null
2765 -- type Ptr_Typ is access Obj_Typ;
2766 -- for Ptr_Typ'Storage_Pool use
2767 -- Base_Pool (BIPfinalizationmaster.all).all;
2769 -- Free (Ptr_Typ (Temp));
2773 -- The generated code effectively detaches the temporary from the
2774 -- caller finalization master and deallocates the object. This is
2775 -- disabled on .NET/JVM because pools are not supported.
2777 if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2779 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2781 if Is_Build_In_Place_Function (Func_Id)
2782 and then Needs_BIP_Finalization_Master (Func_Id)
2784 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2789 if Ekind_In (Obj_Id, E_Constant, E_Variable)
2790 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2792 -- Temporaries created for the purpose of "exporting" a
2793 -- controlled transient out of an Expression_With_Actions (EWA)
2794 -- need guards. The following illustrates the usage of such
2797 -- Access_Typ : access [all] Obj_Typ;
2798 -- Temp : Access_Typ := null;
2799 -- <Counter> := ...;
2802 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2803 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2805 -- Temp := Ctrl_Trans'Unchecked_Access;
2808 -- The finalization machinery does not process EWA nodes as
2809 -- this may lead to premature finalization of expressions. Note
2810 -- that Temp is marked as being properly initialized regardless
2811 -- of whether the initialization of Ctrl_Trans succeeded. Since
2812 -- a failed initialization may leave Temp with a value of null,
2813 -- add a guard to handle this case:
2815 -- if Obj /= null then
2816 -- <object finalization statements>
2819 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2820 N_Object_Declaration
2822 Fin_Stmts := New_List (
2823 Make_If_Statement (Loc,
2826 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
2827 Right_Opnd => Make_Null (Loc)),
2828 Then_Statements => Fin_Stmts));
2830 -- Return objects use a flag to aid in processing their
2831 -- potential finalization when the enclosing function fails
2832 -- to return properly. Generate:
2835 -- <object finalization statements>
2839 Fin_Stmts := New_List (
2840 Make_If_Statement (Loc,
2845 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2847 Then_Statements => Fin_Stmts));
2852 Append_List_To (Finalizer_Stmts, Fin_Stmts);
2854 -- Since the declarations are examined in reverse, the state counter
2855 -- must be decremented in order to keep with the true position of
2858 Counter_Val := Counter_Val - 1;
2859 end Process_Object_Declaration;
2861 -------------------------------------
2862 -- Process_Tagged_Type_Declaration --
2863 -------------------------------------
2865 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2866 Typ : constant Entity_Id := Defining_Identifier (Decl);
2867 DT_Ptr : constant Entity_Id :=
2868 Node (First_Elmt (Access_Disp_Table (Typ)));
2871 -- Ada.Tags.Unregister_Tag (<Typ>P);
2873 Append_To (Tagged_Type_Stmts,
2874 Make_Procedure_Call_Statement (Loc,
2876 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
2877 Parameter_Associations => New_List (
2878 New_Occurrence_Of (DT_Ptr, Loc))));
2879 end Process_Tagged_Type_Declaration;
2881 -- Start of processing for Build_Finalizer
2886 -- Do not perform this expansion in SPARK mode because it is not
2889 if GNATprove_Mode then
2893 -- Step 1: Extract all lists which may contain controlled objects or
2894 -- library-level tagged types.
2896 if For_Package_Spec then
2897 Decls := Visible_Declarations (Specification (N));
2898 Priv_Decls := Private_Declarations (Specification (N));
2900 -- Retrieve the package spec id
2902 Spec_Id := Defining_Unit_Name (Specification (N));
2904 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2905 Spec_Id := Defining_Identifier (Spec_Id);
2908 -- Accept statement, block, entry body, package body, protected body,
2909 -- subprogram body or task body.
2912 Decls := Declarations (N);
2913 HSS := Handled_Statement_Sequence (N);
2915 if Present (HSS) then
2916 if Present (Statements (HSS)) then
2917 Stmts := Statements (HSS);
2920 if Present (At_End_Proc (HSS)) then
2921 Prev_At_End := At_End_Proc (HSS);
2925 -- Retrieve the package spec id for package bodies
2927 if For_Package_Body then
2928 Spec_Id := Corresponding_Spec (N);
2932 -- Do not process nested packages since those are handled by the
2933 -- enclosing scope's finalizer. Do not process non-expanded package
2934 -- instantiations since those will be re-analyzed and re-expanded.
2938 (not Is_Library_Level_Entity (Spec_Id)
2940 -- Nested packages are considered to be library level entities,
2941 -- but do not need to be processed separately. True library level
2942 -- packages have a scope value of 1.
2944 or else Scope_Depth_Value (Spec_Id) /= Uint_1
2945 or else (Is_Generic_Instance (Spec_Id)
2946 and then Package_Instantiation (Spec_Id) /= N))
2951 -- Step 2: Object [pre]processing
2955 -- Preprocess the visible declarations now in order to obtain the
2956 -- correct number of controlled object by the time the private
2957 -- declarations are processed.
2959 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2961 -- From all the possible contexts, only package specifications may
2962 -- have private declarations.
2964 if For_Package_Spec then
2965 Process_Declarations
2966 (Priv_Decls, Preprocess => True, Top_Level => True);
2969 -- The current context may lack controlled objects, but require some
2970 -- other form of completion (task termination for instance). In such
2971 -- cases, the finalizer must be created and carry the additional
2974 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2978 -- The preprocessing has determined that the context has controlled
2979 -- objects or library-level tagged types.
2981 if Has_Ctrl_Objs or Has_Tagged_Types then
2983 -- Private declarations are processed first in order to preserve
2984 -- possible dependencies between public and private objects.
2986 if For_Package_Spec then
2987 Process_Declarations (Priv_Decls);
2990 Process_Declarations (Decls);
2996 -- Preprocess both declarations and statements
2998 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2999 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3001 -- At this point it is known that N has controlled objects. Ensure
3002 -- that N has a declarative list since the finalizer spec will be
3005 if Has_Ctrl_Objs and then No (Decls) then
3006 Set_Declarations (N, New_List);
3007 Decls := Declarations (N);
3008 Spec_Decls := Decls;
3011 -- The current context may lack controlled objects, but require some
3012 -- other form of completion (task termination for instance). In such
3013 -- cases, the finalizer must be created and carry the additional
3016 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3020 if Has_Ctrl_Objs or Has_Tagged_Types then
3021 Process_Declarations (Stmts);
3022 Process_Declarations (Decls);
3026 -- Step 3: Finalizer creation
3028 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3031 end Build_Finalizer;
3033 --------------------------
3034 -- Build_Finalizer_Call --
3035 --------------------------
3037 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3038 Is_Prot_Body : constant Boolean :=
3039 Nkind (N) = N_Subprogram_Body
3040 and then Is_Protected_Subprogram_Body (N);
3041 -- Determine whether N denotes the protected version of a subprogram
3042 -- which belongs to a protected type.
3044 Loc : constant Source_Ptr := Sloc (N);
3048 -- Do not perform this expansion in SPARK mode because we do not create
3049 -- finalizers in the first place.
3051 if GNATprove_Mode then
3055 -- The At_End handler should have been assimilated by the finalizer
3057 HSS := Handled_Statement_Sequence (N);
3058 pragma Assert (No (At_End_Proc (HSS)));
3060 -- If the construct to be cleaned up is a protected subprogram body, the
3061 -- finalizer call needs to be associated with the block which wraps the
3062 -- unprotected version of the subprogram. The following illustrates this
3065 -- procedure Prot_SubpP is
3066 -- procedure finalizer is
3068 -- Service_Entries (Prot_Obj);
3075 -- Prot_SubpN (Prot_Obj);
3081 if Is_Prot_Body then
3082 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3084 -- An At_End handler and regular exception handlers cannot coexist in
3085 -- the same statement sequence. Wrap the original statements in a block.
3087 elsif Present (Exception_Handlers (HSS)) then
3089 End_Lab : constant Node_Id := End_Label (HSS);
3094 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3096 Set_Handled_Statement_Sequence (N,
3097 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3099 HSS := Handled_Statement_Sequence (N);
3100 Set_End_Label (HSS, End_Lab);
3104 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3106 Analyze (At_End_Proc (HSS));
3107 Expand_At_End_Handler (HSS, Empty);
3108 end Build_Finalizer_Call;
3110 ---------------------
3111 -- Build_Late_Proc --
3112 ---------------------
3114 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3116 for Final_Prim in Name_Of'Range loop
3117 if Name_Of (Final_Prim) = Nam then
3120 (Prim => Final_Prim,
3122 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3125 end Build_Late_Proc;
3127 -------------------------------
3128 -- Build_Object_Declarations --
3129 -------------------------------
3131 procedure Build_Object_Declarations
3132 (Data : out Finalization_Exception_Data;
3135 For_Package : Boolean := False)
3140 pragma Unreferenced (Dummy);
3141 -- This variable captures an unused dummy internal entity, see the
3142 -- comment associated with its use.
3145 pragma Assert (Decls /= No_List);
3147 -- Always set the proper location as it may be needed even when
3148 -- exception propagation is forbidden.
3152 if Restriction_Active (No_Exception_Propagation) then
3153 Data.Abort_Id := Empty;
3155 Data.Raised_Id := Empty;
3159 Data.Raised_Id := Make_Temporary (Loc, 'R');
3161 -- In certain scenarios, finalization can be triggered by an abort. If
3162 -- the finalization itself fails and raises an exception, the resulting
3163 -- Program_Error must be supressed and replaced by an abort signal. In
3164 -- order to detect this scenario, save the state of entry into the
3165 -- finalization code.
3167 -- No need to do this for VM case, since VM version of Ada.Exceptions
3168 -- does not include routine Raise_From_Controlled_Operation which is the
3169 -- the sole user of flag Abort.
3171 -- This is not needed for library-level finalizers as they are called by
3172 -- the environment task and cannot be aborted.
3174 if VM_Target = No_VM and then not For_Package then
3175 if Abort_Allowed then
3176 Data.Abort_Id := Make_Temporary (Loc, 'A');
3179 -- Abort_Id : constant Boolean := <A_Expr>;
3182 Make_Object_Declaration (Loc,
3183 Defining_Identifier => Data.Abort_Id,
3184 Constant_Present => True,
3185 Object_Definition =>
3186 New_Occurrence_Of (Standard_Boolean, Loc),
3188 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3190 -- Abort is not required
3193 -- Generate a dummy entity to ensure that the internal symbols are
3194 -- in sync when a unit is compiled with and without aborts.
3196 Dummy := Make_Temporary (Loc, 'A');
3197 Data.Abort_Id := Empty;
3200 -- .NET/JVM or library-level finalizers
3203 Data.Abort_Id := Empty;
3206 if Exception_Extra_Info then
3207 Data.E_Id := Make_Temporary (Loc, 'E');
3210 -- E_Id : Exception_Occurrence;
3213 Make_Object_Declaration (Loc,
3214 Defining_Identifier => Data.E_Id,
3215 Object_Definition =>
3216 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3217 Set_No_Initialization (Decl);
3219 Append_To (Decls, Decl);
3226 -- Raised_Id : Boolean := False;
3229 Make_Object_Declaration (Loc,
3230 Defining_Identifier => Data.Raised_Id,
3231 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3232 Expression => New_Occurrence_Of (Standard_False, Loc)));
3233 end Build_Object_Declarations;
3235 ---------------------------
3236 -- Build_Raise_Statement --
3237 ---------------------------
3239 function Build_Raise_Statement
3240 (Data : Finalization_Exception_Data) return Node_Id
3246 -- Standard run-time and .NET/JVM targets use the specialized routine
3247 -- Raise_From_Controlled_Operation.
3249 if Exception_Extra_Info
3250 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3253 Make_Procedure_Call_Statement (Data.Loc,
3256 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3257 Parameter_Associations =>
3258 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3260 -- Restricted run-time: exception messages are not supported and hence
3261 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3266 Make_Raise_Program_Error (Data.Loc,
3267 Reason => PE_Finalize_Raised_Exception);
3272 -- Raised_Id and then not Abort_Id
3276 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3278 if Present (Data.Abort_Id) then
3279 Expr := Make_And_Then (Data.Loc,
3282 Make_Op_Not (Data.Loc,
3283 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3288 -- if Raised_Id and then not Abort_Id then
3289 -- Raise_From_Controlled_Operation (E_Id);
3291 -- raise Program_Error; -- restricted runtime
3295 Make_If_Statement (Data.Loc,
3297 Then_Statements => New_List (Stmt));
3298 end Build_Raise_Statement;
3300 -----------------------------
3301 -- Build_Record_Deep_Procs --
3302 -----------------------------
3304 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3308 (Prim => Initialize_Case,
3310 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3312 if not Is_Limited_View (Typ) then
3315 (Prim => Adjust_Case,
3317 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3320 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3321 -- suppressed since these routine will not be used.
3323 if not Restriction_Active (No_Finalization) then
3326 (Prim => Finalize_Case,
3328 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3330 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3331 -- .NET do not support address arithmetic and unchecked conversions.
3333 if VM_Target = No_VM then
3336 (Prim => Address_Case,
3338 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3341 end Build_Record_Deep_Procs;
3347 function Cleanup_Array
3350 Typ : Entity_Id) return List_Id
3352 Loc : constant Source_Ptr := Sloc (N);
3353 Index_List : constant List_Id := New_List;
3355 function Free_Component return List_Id;
3356 -- Generate the code to finalize the task or protected subcomponents
3357 -- of a single component of the array.
3359 function Free_One_Dimension (Dim : Int) return List_Id;
3360 -- Generate a loop over one dimension of the array
3362 --------------------
3363 -- Free_Component --
3364 --------------------
3366 function Free_Component return List_Id is
3367 Stmts : List_Id := New_List;
3369 C_Typ : constant Entity_Id := Component_Type (Typ);
3372 -- Component type is known to contain tasks or protected objects
3375 Make_Indexed_Component (Loc,
3376 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3377 Expressions => Index_List);
3379 Set_Etype (Tsk, C_Typ);
3381 if Is_Task_Type (C_Typ) then
3382 Append_To (Stmts, Cleanup_Task (N, Tsk));
3384 elsif Is_Simple_Protected_Type (C_Typ) then
3385 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3387 elsif Is_Record_Type (C_Typ) then
3388 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3390 elsif Is_Array_Type (C_Typ) then
3391 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3397 ------------------------
3398 -- Free_One_Dimension --
3399 ------------------------
3401 function Free_One_Dimension (Dim : Int) return List_Id is
3405 if Dim > Number_Dimensions (Typ) then
3406 return Free_Component;
3408 -- Here we generate the required loop
3411 Index := Make_Temporary (Loc, 'J');
3412 Append (New_Occurrence_Of (Index, Loc), Index_List);
3415 Make_Implicit_Loop_Statement (N,
3416 Identifier => Empty,
3418 Make_Iteration_Scheme (Loc,
3419 Loop_Parameter_Specification =>
3420 Make_Loop_Parameter_Specification (Loc,
3421 Defining_Identifier => Index,
3422 Discrete_Subtype_Definition =>
3423 Make_Attribute_Reference (Loc,
3424 Prefix => Duplicate_Subexpr (Obj),
3425 Attribute_Name => Name_Range,
3426 Expressions => New_List (
3427 Make_Integer_Literal (Loc, Dim))))),
3428 Statements => Free_One_Dimension (Dim + 1)));
3430 end Free_One_Dimension;
3432 -- Start of processing for Cleanup_Array
3435 return Free_One_Dimension (1);
3438 --------------------
3439 -- Cleanup_Record --
3440 --------------------
3442 function Cleanup_Record
3445 Typ : Entity_Id) return List_Id
3447 Loc : constant Source_Ptr := Sloc (N);
3450 Stmts : constant List_Id := New_List;
3451 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3454 if Has_Discriminants (U_Typ)
3455 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3457 Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3460 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3462 -- For now, do not attempt to free a component that may appear in a
3463 -- variant, and instead issue a warning. Doing this "properly" would
3464 -- require building a case statement and would be quite a mess. Note
3465 -- that the RM only requires that free "work" for the case of a task
3466 -- access value, so already we go way beyond this in that we deal
3467 -- with the array case and non-discriminated record cases.
3470 ("task/protected object in variant record will not be freed??", N);
3471 return New_List (Make_Null_Statement (Loc));
3474 Comp := First_Component (Typ);
3475 while Present (Comp) loop
3476 if Has_Task (Etype (Comp))
3477 or else Has_Simple_Protected_Object (Etype (Comp))
3480 Make_Selected_Component (Loc,
3481 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3482 Selector_Name => New_Occurrence_Of (Comp, Loc));
3483 Set_Etype (Tsk, Etype (Comp));
3485 if Is_Task_Type (Etype (Comp)) then
3486 Append_To (Stmts, Cleanup_Task (N, Tsk));
3488 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3489 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3491 elsif Is_Record_Type (Etype (Comp)) then
3493 -- Recurse, by generating the prefix of the argument to
3494 -- the eventual cleanup call.
3496 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3498 elsif Is_Array_Type (Etype (Comp)) then
3499 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3503 Next_Component (Comp);
3509 ------------------------------
3510 -- Cleanup_Protected_Object --
3511 ------------------------------
3513 function Cleanup_Protected_Object
3515 Ref : Node_Id) return Node_Id
3517 Loc : constant Source_Ptr := Sloc (N);
3520 -- For restricted run-time libraries (Ravenscar), tasks are
3521 -- non-terminating, and protected objects can only appear at library
3522 -- level, so we do not want finalization of protected objects.
3524 if Restricted_Profile then
3529 Make_Procedure_Call_Statement (Loc,
3531 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
3532 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3534 end Cleanup_Protected_Object;
3540 function Cleanup_Task
3542 Ref : Node_Id) return Node_Id
3544 Loc : constant Source_Ptr := Sloc (N);
3547 -- For restricted run-time libraries (Ravenscar), tasks are
3548 -- non-terminating and they can only appear at library level, so we do
3549 -- not want finalization of task objects.
3551 if Restricted_Profile then
3556 Make_Procedure_Call_Statement (Loc,
3558 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
3559 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3563 ------------------------------
3564 -- Check_Visibly_Controlled --
3565 ------------------------------
3567 procedure Check_Visibly_Controlled
3568 (Prim : Final_Primitives;
3570 E : in out Entity_Id;
3571 Cref : in out Node_Id)
3573 Parent_Type : Entity_Id;
3577 if Is_Derived_Type (Typ)
3578 and then Comes_From_Source (E)
3579 and then not Present (Overridden_Operation (E))
3581 -- We know that the explicit operation on the type does not override
3582 -- the inherited operation of the parent, and that the derivation
3583 -- is from a private type that is not visibly controlled.
3585 Parent_Type := Etype (Typ);
3586 Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3588 if Present (Op) then
3591 -- Wrap the object to be initialized into the proper
3592 -- unchecked conversion, to be compatible with the operation
3595 if Nkind (Cref) = N_Unchecked_Type_Conversion then
3596 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3598 Cref := Unchecked_Convert_To (Parent_Type, Cref);
3602 end Check_Visibly_Controlled;
3604 -------------------------------
3605 -- CW_Or_Has_Controlled_Part --
3606 -------------------------------
3608 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3610 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3611 end CW_Or_Has_Controlled_Part;
3617 function Convert_View
3620 Ind : Pos := 1) return Node_Id
3622 Fent : Entity_Id := First_Entity (Proc);
3627 for J in 2 .. Ind loop
3631 Ftyp := Etype (Fent);
3633 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3634 Atyp := Entity (Subtype_Mark (Arg));
3636 Atyp := Etype (Arg);
3639 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3640 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3643 and then Present (Atyp)
3644 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3645 and then Base_Type (Underlying_Type (Atyp)) =
3646 Base_Type (Underlying_Type (Ftyp))
3648 return Unchecked_Convert_To (Ftyp, Arg);
3650 -- If the argument is already a conversion, as generated by
3651 -- Make_Init_Call, set the target type to the type of the formal
3652 -- directly, to avoid spurious typing problems.
3654 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3655 and then not Is_Class_Wide_Type (Atyp)
3657 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3658 Set_Etype (Arg, Ftyp);
3666 ------------------------
3667 -- Enclosing_Function --
3668 ------------------------
3670 function Enclosing_Function (E : Entity_Id) return Entity_Id is
3671 Func_Id : Entity_Id;
3675 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
3676 if Ekind (Func_Id) = E_Function then
3680 Func_Id := Scope (Func_Id);
3684 end Enclosing_Function;
3686 -------------------------------
3687 -- Establish_Transient_Scope --
3688 -------------------------------
3690 -- This procedure is called each time a transient block has to be inserted
3691 -- that is to say for each call to a function with unconstrained or tagged
3692 -- result. It creates a new scope on the stack scope in order to enclose
3693 -- all transient variables generated.
3695 procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3696 Loc : constant Source_Ptr := Sloc (N);
3697 Iter_Loop : Entity_Id;
3698 Wrap_Node : Node_Id;
3701 -- Do not create a transient scope if we are already inside one
3703 for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3704 if Scope_Stack.Table (S).Is_Transient then
3706 Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3711 -- If we encounter Standard there are no enclosing transient scopes
3713 elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3718 Wrap_Node := Find_Node_To_Be_Wrapped (N);
3720 -- The context does not contain a node that requires a transient scope,
3723 if No (Wrap_Node) then
3726 -- If the node to wrap is an iteration_scheme, the expression is one of
3727 -- the bounds, and the expansion will make an explicit declaration for
3728 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3729 -- transformations here. Same for an Ada 2012 iterator specification,
3730 -- where a block is created for the expression that build the container.
3732 elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
3733 N_Iterator_Specification)
3737 -- In formal verification mode, if the node to wrap is a pragma check,
3738 -- this node and enclosed expression are not expanded, so do not apply
3739 -- any transformations here.
3741 elsif GNATprove_Mode
3742 and then Nkind (Wrap_Node) = N_Pragma
3743 and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
3747 -- Create a block entity to act as a transient scope. Note that when the
3748 -- node to be wrapped is an expression or a statement, a real physical
3749 -- block is constructed (see routines Wrap_Transient_Expression and
3750 -- Wrap_Transient_Statement) and inserted into the tree.
3753 Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3754 Set_Scope_Is_Transient;
3756 -- The transient scope must also take care of the secondary stack
3760 Set_Uses_Sec_Stack (Current_Scope);
3761 Check_Restriction (No_Secondary_Stack, N);
3763 -- The expansion of iterator loops generates references to objects
3764 -- in order to extract elements from a container:
3766 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3767 -- Obj : <object type> renames Ref.all.Element.all;
3769 -- These references are controlled and returned on the secondary
3770 -- stack. A new reference is created at each iteration of the loop
3771 -- and as a result it must be finalized and the space occupied by
3772 -- it on the secondary stack reclaimed at the end of the current
3775 -- When the context that requires a transient scope is a call to
3776 -- routine Reference, the node to be wrapped is the source object:
3778 -- for Obj of Container loop
3780 -- Routine Wrap_Transient_Declaration however does not generate a
3781 -- physical block as wrapping a declaration will kill it too ealy.
3782 -- To handle this peculiar case, mark the related iterator loop as
3783 -- requiring the secondary stack. This signals the finalization
3784 -- machinery to manage the secondary stack (see routine
3785 -- Process_Statements_For_Controlled_Objects).
3787 Iter_Loop := Find_Enclosing_Iterator_Loop (Current_Scope);
3789 if Present (Iter_Loop) then
3790 Set_Uses_Sec_Stack (Iter_Loop);
3794 Set_Etype (Current_Scope, Standard_Void_Type);
3795 Set_Node_To_Be_Wrapped (Wrap_Node);
3797 if Debug_Flag_W then
3798 Write_Str (" <Transient>");
3802 end Establish_Transient_Scope;
3804 ----------------------------
3805 -- Expand_Cleanup_Actions --
3806 ----------------------------
3808 procedure Expand_Cleanup_Actions (N : Node_Id) is
3809 Scop : constant Entity_Id := Current_Scope;
3811 Is_Asynchronous_Call : constant Boolean :=
3812 Nkind (N) = N_Block_Statement
3813 and then Is_Asynchronous_Call_Block (N);
3814 Is_Master : constant Boolean :=
3815 Nkind (N) /= N_Entry_Body
3816 and then Is_Task_Master (N);
3817 Is_Protected_Body : constant Boolean :=
3818 Nkind (N) = N_Subprogram_Body
3819 and then Is_Protected_Subprogram_Body (N);
3820 Is_Task_Allocation : constant Boolean :=
3821 Nkind (N) = N_Block_Statement
3822 and then Is_Task_Allocation_Block (N);
3823 Is_Task_Body : constant Boolean :=
3824 Nkind (Original_Node (N)) = N_Task_Body;
3825 Needs_Sec_Stack_Mark : constant Boolean :=
3826 Uses_Sec_Stack (Scop)
3828 not Sec_Stack_Needed_For_Return (Scop)
3829 and then VM_Target = No_VM;
3830 Needs_Custom_Cleanup : constant Boolean :=
3831 Nkind (N) = N_Block_Statement
3832 and then Present (Cleanup_Actions (N));
3834 Actions_Required : constant Boolean :=
3835 Requires_Cleanup_Actions (N, True)
3836 or else Is_Asynchronous_Call
3838 or else Is_Protected_Body
3839 or else Is_Task_Allocation
3840 or else Is_Task_Body
3841 or else Needs_Sec_Stack_Mark
3842 or else Needs_Custom_Cleanup;
3844 HSS : Node_Id := Handled_Statement_Sequence (N);
3848 procedure Wrap_HSS_In_Block;
3849 -- Move HSS inside a new block along with the original exception
3850 -- handlers. Make the newly generated block the sole statement of HSS.
3852 -----------------------
3853 -- Wrap_HSS_In_Block --
3854 -----------------------
3856 procedure Wrap_HSS_In_Block is
3861 -- Preserve end label to provide proper cross-reference information
3863 End_Lab := End_Label (HSS);
3865 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3867 -- Signal the finalization machinery that this particular block
3868 -- contains the original context.
3870 Set_Is_Finalization_Wrapper (Block);
3872 Set_Handled_Statement_Sequence (N,
3873 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3874 HSS := Handled_Statement_Sequence (N);
3876 Set_First_Real_Statement (HSS, Block);
3877 Set_End_Label (HSS, End_Lab);
3879 -- Comment needed here, see RH for 1.306 ???
3881 if Nkind (N) = N_Subprogram_Body then
3882 Set_Has_Nested_Block_With_Handler (Scop);
3884 end Wrap_HSS_In_Block;
3886 -- Start of processing for Expand_Cleanup_Actions
3889 -- The current construct does not need any form of servicing
3891 if not Actions_Required then
3894 -- If the current node is a rewritten task body and the descriptors have
3895 -- not been delayed (due to some nested instantiations), do not generate
3896 -- redundant cleanup actions.
3899 and then Nkind (N) = N_Subprogram_Body
3900 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3905 if Needs_Custom_Cleanup then
3906 Cln := Cleanup_Actions (N);
3912 Decls : List_Id := Declarations (N);
3914 Mark : Entity_Id := Empty;
3915 New_Decls : List_Id;
3919 -- If we are generating expanded code for debugging purposes, use the
3920 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3921 -- be updated subsequently to reference the proper line in .dg files.
3922 -- If we are not debugging generated code, use No_Location instead,
3923 -- so that no debug information is generated for the cleanup code.
3924 -- This makes the behavior of the NEXT command in GDB monotonic, and
3925 -- makes the placement of breakpoints more accurate.
3927 if Debug_Generated_Code then
3933 -- Set polling off. The finalization and cleanup code is executed
3934 -- with aborts deferred.
3936 Old_Poll := Polling_Required;
3937 Polling_Required := False;
3939 -- A task activation call has already been built for a task
3940 -- allocation block.
3942 if not Is_Task_Allocation then
3943 Build_Task_Activation_Call (N);
3947 Establish_Task_Master (N);
3950 New_Decls := New_List;
3952 -- If secondary stack is in use, generate:
3954 -- Mnn : constant Mark_Id := SS_Mark;
3956 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3957 -- secondary stack is never used on a VM.
3959 if Needs_Sec_Stack_Mark then
3960 Mark := Make_Temporary (Loc, 'M');
3962 Append_To (New_Decls,
3963 Make_Object_Declaration (Loc,
3964 Defining_Identifier => Mark,
3965 Object_Definition =>
3966 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3968 Make_Function_Call (Loc,
3969 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc))));
3971 Set_Uses_Sec_Stack (Scop, False);
3974 -- If exception handlers are present, wrap the sequence of statements
3975 -- in a block since it is not possible to have exception handlers and
3976 -- an At_End handler in the same construct.
3978 if Present (Exception_Handlers (HSS)) then
3981 -- Ensure that the First_Real_Statement field is set
3983 elsif No (First_Real_Statement (HSS)) then
3984 Set_First_Real_Statement (HSS, First (Statements (HSS)));
3987 -- Do not move the Activation_Chain declaration in the context of
3988 -- task allocation blocks. Task allocation blocks use _chain in their
3989 -- cleanup handlers and gigi complains if it is declared in the
3990 -- sequence of statements of the scope that declares the handler.
3992 if Is_Task_Allocation then
3994 Chain : constant Entity_Id := Activation_Chain_Entity (N);
3998 Decl := First (Decls);
3999 while Nkind (Decl) /= N_Object_Declaration
4000 or else Defining_Identifier (Decl) /= Chain
4004 -- A task allocation block should always include a _chain
4007 pragma Assert (Present (Decl));
4011 Prepend_To (New_Decls, Decl);
4015 -- Ensure the presence of a declaration list in order to successfully
4016 -- append all original statements to it.
4019 Set_Declarations (N, New_List);
4020 Decls := Declarations (N);
4023 -- Move the declarations into the sequence of statements in order to
4024 -- have them protected by the At_End handler. It may seem weird to
4025 -- put declarations in the sequence of statement but in fact nothing
4026 -- forbids that at the tree level.
4028 Append_List_To (Decls, Statements (HSS));
4029 Set_Statements (HSS, Decls);
4031 -- Reset the Sloc of the handled statement sequence to properly
4032 -- reflect the new initial "statement" in the sequence.
4034 Set_Sloc (HSS, Sloc (First (Decls)));
4036 -- The declarations of finalizer spec and auxiliary variables replace
4037 -- the old declarations that have been moved inward.
4039 Set_Declarations (N, New_Decls);
4040 Analyze_Declarations (New_Decls);
4042 -- Generate finalization calls for all controlled objects appearing
4043 -- in the statements of N. Add context specific cleanup for various
4048 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
4050 Top_Decls => New_Decls,
4051 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
4055 if Present (Fin_Id) then
4056 Build_Finalizer_Call (N, Fin_Id);
4059 -- Restore saved polling mode
4061 Polling_Required := Old_Poll;
4063 end Expand_Cleanup_Actions;
4065 ---------------------------
4066 -- Expand_N_Package_Body --
4067 ---------------------------
4069 -- Add call to Activate_Tasks if body is an activator (actual processing
4070 -- is in chapter 9).
4072 -- Generate subprogram descriptor for elaboration routine
4074 -- Encode entity names in package body
4076 procedure Expand_N_Package_Body (N : Node_Id) is
4077 Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
4081 -- This is done only for non-generic packages
4083 if Ekind (Spec_Ent) = E_Package then
4084 Push_Scope (Corresponding_Spec (N));
4086 -- Build dispatch tables of library level tagged types
4088 if Tagged_Type_Expansion
4089 and then Is_Library_Level_Entity (Spec_Ent)
4091 Build_Static_Dispatch_Tables (N);
4094 Build_Task_Activation_Call (N);
4096 -- When the package is subject to pragma Initial_Condition, the
4097 -- assertion expression must be verified at the end of the body
4100 if Present (Get_Pragma (Spec_Ent, Pragma_Initial_Condition)) then
4101 Expand_Pragma_Initial_Condition (N);
4107 Set_Elaboration_Flag (N, Corresponding_Spec (N));
4108 Set_In_Package_Body (Spec_Ent, False);
4110 -- Set to encode entity names in package body before gigi is called
4112 Qualify_Entity_Names (N);
4114 if Ekind (Spec_Ent) /= E_Generic_Package then
4117 Clean_Stmts => No_List,
4119 Top_Decls => No_List,
4120 Defer_Abort => False,
4123 if Present (Fin_Id) then
4125 Body_Ent : Node_Id := Defining_Unit_Name (N);
4128 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
4129 Body_Ent := Defining_Identifier (Body_Ent);
4132 Set_Finalizer (Body_Ent, Fin_Id);
4136 end Expand_N_Package_Body;
4138 ----------------------------------
4139 -- Expand_N_Package_Declaration --
4140 ----------------------------------
4142 -- Add call to Activate_Tasks if there are tasks declared and the package
4143 -- has no body. Note that in Ada 83 this may result in premature activation
4144 -- of some tasks, given that we cannot tell whether a body will eventually
4147 procedure Expand_N_Package_Declaration (N : Node_Id) is
4148 Id : constant Entity_Id := Defining_Entity (N);
4149 Spec : constant Node_Id := Specification (N);
4153 No_Body : Boolean := False;
4154 -- True in the case of a package declaration that is a compilation
4155 -- unit and for which no associated body will be compiled in this
4159 -- Case of a package declaration other than a compilation unit
4161 if Nkind (Parent (N)) /= N_Compilation_Unit then
4164 -- Case of a compilation unit that does not require a body
4166 elsif not Body_Required (Parent (N))
4167 and then not Unit_Requires_Body (Id)
4171 -- Special case of generating calling stubs for a remote call interface
4172 -- package: even though the package declaration requires one, the body
4173 -- won't be processed in this compilation (so any stubs for RACWs
4174 -- declared in the package must be generated here, along with the spec).
4176 elsif Parent (N) = Cunit (Main_Unit)
4177 and then Is_Remote_Call_Interface (Id)
4178 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
4183 -- For a nested instance, delay processing until freeze point
4185 if Has_Delayed_Freeze (Id)
4186 and then Nkind (Parent (N)) /= N_Compilation_Unit
4191 -- For a package declaration that implies no associated body, generate
4192 -- task activation call and RACW supporting bodies now (since we won't
4193 -- have a specific separate compilation unit for that).
4198 -- Generate RACW subprogram bodies
4200 if Has_RACW (Id) then
4201 Decls := Private_Declarations (Spec);
4204 Decls := Visible_Declarations (Spec);
4209 Set_Visible_Declarations (Spec, Decls);
4212 Append_RACW_Bodies (Decls, Id);
4213 Analyze_List (Decls);
4216 -- Generate task activation call as last step of elaboration
4218 if Present (Activation_Chain_Entity (N)) then
4219 Build_Task_Activation_Call (N);
4222 -- When the package is subject to pragma Initial_Condition and lacks
4223 -- a body, the assertion expression must be verified at the end of
4224 -- the visible declarations. Otherwise the check is performed at the
4225 -- end of the body statements (see Expand_N_Package_Body).
4227 if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
4228 Expand_Pragma_Initial_Condition (N);
4234 -- Build dispatch tables of library level tagged types
4236 if Tagged_Type_Expansion
4237 and then (Is_Compilation_Unit (Id)
4238 or else (Is_Generic_Instance (Id)
4239 and then Is_Library_Level_Entity (Id)))
4241 Build_Static_Dispatch_Tables (N);
4244 -- Note: it is not necessary to worry about generating a subprogram
4245 -- descriptor, since the only way to get exception handlers into a
4246 -- package spec is to include instantiations, and that would cause
4247 -- generation of subprogram descriptors to be delayed in any case.
4249 -- Set to encode entity names in package spec before gigi is called
4251 Qualify_Entity_Names (N);
4253 if Ekind (Id) /= E_Generic_Package then
4256 Clean_Stmts => No_List,
4258 Top_Decls => No_List,
4259 Defer_Abort => False,
4262 Set_Finalizer (Id, Fin_Id);
4264 end Expand_N_Package_Declaration;
4266 -------------------------------------
4267 -- Expand_Pragma_Initial_Condition --
4268 -------------------------------------
4270 procedure Expand_Pragma_Initial_Condition (N : Node_Id) is
4271 Loc : constant Source_Ptr := Sloc (N);
4274 Init_Cond : Node_Id;
4276 Pack_Id : Entity_Id;
4279 if Nkind (N) = N_Package_Body then
4280 Pack_Id := Corresponding_Spec (N);
4282 if Present (Handled_Statement_Sequence (N)) then
4283 List := Statements (Handled_Statement_Sequence (N));
4285 -- The package body lacks statements, create an empty list
4290 Set_Handled_Statement_Sequence (N,
4291 Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
4294 elsif Nkind (N) = N_Package_Declaration then
4295 Pack_Id := Defining_Entity (N);
4297 if Present (Visible_Declarations (Specification (N))) then
4298 List := Visible_Declarations (Specification (N));
4300 -- The package lacks visible declarations, create an empty list
4305 Set_Visible_Declarations (Specification (N), List);
4308 -- This routine should not be used on anything other than packages
4311 raise Program_Error;
4314 Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
4316 -- The caller should check whether the package is subject to pragma
4317 -- Initial_Condition.
4319 pragma Assert (Present (Init_Cond));
4322 Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
4324 -- The assertion expression was found to be illegal, do not generate the
4325 -- runtime check as it will repeat the illegality.
4327 if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
4332 -- pragma Check (Initial_Condition, <Expr>);
4336 Chars => Name_Check,
4337 Pragma_Argument_Associations => New_List (
4338 Make_Pragma_Argument_Association (Loc,
4339 Expression => Make_Identifier (Loc, Name_Initial_Condition)),
4341 Make_Pragma_Argument_Association (Loc,
4342 Expression => New_Copy_Tree (Expr))));
4344 Append_To (List, Check);
4346 end Expand_Pragma_Initial_Condition;
4348 -----------------------------
4349 -- Find_Node_To_Be_Wrapped --
4350 -----------------------------
4352 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
4354 The_Parent : Node_Id;
4360 case Nkind (The_Parent) is
4362 -- Simple statement can be wrapped
4367 -- Usually assignments are good candidate for wrapping except
4368 -- when they have been generated as part of a controlled aggregate
4369 -- where the wrapping should take place more globally. Note that
4370 -- No_Ctrl_Actions may be set also for non-controlled assignements
4371 -- in order to disable the use of dispatching _assign, so we need
4372 -- to test explicitly for a controlled type here.
4374 when N_Assignment_Statement =>
4375 if No_Ctrl_Actions (The_Parent)
4376 and then Needs_Finalization (Etype (Name (The_Parent)))
4383 -- An entry call statement is a special case if it occurs in the
4384 -- context of a Timed_Entry_Call. In this case we wrap the entire
4385 -- timed entry call.
4387 when N_Entry_Call_Statement |
4388 N_Procedure_Call_Statement =>
4389 if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
4390 and then Nkind_In (Parent (Parent (The_Parent)),
4392 N_Conditional_Entry_Call)
4394 return Parent (Parent (The_Parent));
4399 -- Object declarations are also a boundary for the transient scope
4400 -- even if they are not really wrapped. For further details, see
4401 -- Wrap_Transient_Declaration.
4403 when N_Object_Declaration |
4404 N_Object_Renaming_Declaration |
4405 N_Subtype_Declaration =>
4408 -- The expression itself is to be wrapped if its parent is a
4409 -- compound statement or any other statement where the expression
4410 -- is known to be scalar.
4412 when N_Accept_Alternative |
4413 N_Attribute_Definition_Clause |
4416 N_Delay_Alternative |
4417 N_Delay_Until_Statement |
4418 N_Delay_Relative_Statement |
4419 N_Discriminant_Association |
4421 N_Entry_Body_Formal_Part |
4424 N_Iteration_Scheme |
4425 N_Terminate_Alternative =>
4426 pragma Assert (Present (P));
4429 when N_Attribute_Reference =>
4431 if Is_Procedure_Attribute_Name
4432 (Attribute_Name (The_Parent))
4437 -- A raise statement can be wrapped. This will arise when the
4438 -- expression in a raise_with_expression uses the secondary
4439 -- stack, for example.
4441 when N_Raise_Statement =>
4444 -- If the expression is within the iteration scheme of a loop,
4445 -- we must create a declaration for it, followed by an assignment
4446 -- in order to have a usable statement to wrap.
4448 when N_Loop_Parameter_Specification =>
4449 return Parent (The_Parent);
4451 -- The following nodes contains "dummy calls" which don't need to
4454 when N_Parameter_Specification |
4455 N_Discriminant_Specification |
4456 N_Component_Declaration =>
4459 -- The return statement is not to be wrapped when the function
4460 -- itself needs wrapping at the outer-level
4462 when N_Simple_Return_Statement =>
4464 Applies_To : constant Entity_Id :=
4466 (Return_Statement_Entity (The_Parent));
4467 Return_Type : constant Entity_Id := Etype (Applies_To);
4469 if Requires_Transient_Scope (Return_Type) then
4476 -- If we leave a scope without having been able to find a node to
4477 -- wrap, something is going wrong but this can happen in error
4478 -- situation that are not detected yet (such as a dynamic string
4479 -- in a pragma export)
4481 when N_Subprogram_Body |
4482 N_Package_Declaration |
4484 N_Block_Statement =>
4487 -- Otherwise continue the search
4494 The_Parent := Parent (P);
4496 end Find_Node_To_Be_Wrapped;
4498 -------------------------------------
4499 -- Get_Global_Pool_For_Access_Type --
4500 -------------------------------------
4502 function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
4504 -- Access types whose size is smaller than System.Address size can exist
4505 -- only on VMS. We can't use the usual global pool which returns an
4506 -- object of type Address as truncation will make it invalid. To handle
4507 -- this case, VMS has a dedicated global pool that returns addresses
4508 -- that fit into 32 bit accesses.
4510 if Opt.True_VMS_Target and then Esize (T) = 32 then
4511 return RTE (RE_Global_Pool_32_Object);
4513 return RTE (RE_Global_Pool_Object);
4515 end Get_Global_Pool_For_Access_Type;
4517 ----------------------------------
4518 -- Has_New_Controlled_Component --
4519 ----------------------------------
4521 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4525 if not Is_Tagged_Type (E) then
4526 return Has_Controlled_Component (E);
4527 elsif not Is_Derived_Type (E) then
4528 return Has_Controlled_Component (E);
4531 Comp := First_Component (E);
4532 while Present (Comp) loop
4533 if Chars (Comp) = Name_uParent then
4536 elsif Scope (Original_Record_Component (Comp)) = E
4537 and then Needs_Finalization (Etype (Comp))
4542 Next_Component (Comp);
4546 end Has_New_Controlled_Component;
4548 ---------------------------------
4549 -- Has_Simple_Protected_Object --
4550 ---------------------------------
4552 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
4554 if Has_Task (T) then
4557 elsif Is_Simple_Protected_Type (T) then
4560 elsif Is_Array_Type (T) then
4561 return Has_Simple_Protected_Object (Component_Type (T));
4563 elsif Is_Record_Type (T) then
4568 Comp := First_Component (T);
4569 while Present (Comp) loop
4570 if Has_Simple_Protected_Object (Etype (Comp)) then
4574 Next_Component (Comp);
4583 end Has_Simple_Protected_Object;
4585 ------------------------------------
4586 -- Insert_Actions_In_Scope_Around --
4587 ------------------------------------
4589 procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
4590 Act_After : constant List_Id :=
4591 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
4592 Act_Before : constant List_Id :=
4593 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
4594 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4595 -- Last), but this was incorrect as Process_Transient_Object may
4596 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4598 procedure Process_Transient_Objects
4599 (First_Object : Node_Id;
4600 Last_Object : Node_Id;
4601 Related_Node : Node_Id);
4602 -- First_Object and Last_Object define a list which contains potential
4603 -- controlled transient objects. Finalization flags are inserted before
4604 -- First_Object and finalization calls are inserted after Last_Object.
4605 -- Related_Node is the node for which transient objects have been
4608 -------------------------------
4609 -- Process_Transient_Objects --
4610 -------------------------------
4612 procedure Process_Transient_Objects
4613 (First_Object : Node_Id;
4614 Last_Object : Node_Id;
4615 Related_Node : Node_Id)
4617 Must_Hook : Boolean := False;
4618 -- Flag denoting whether the context requires transient variable
4619 -- export to the outer finalizer.
4621 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
4622 -- Determine whether an arbitrary node denotes a subprogram call
4624 procedure Detect_Subprogram_Call is
4625 new Traverse_Proc (Is_Subprogram_Call);
4627 ------------------------
4628 -- Is_Subprogram_Call --
4629 ------------------------
4631 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
4633 -- Complex constructs are factored out by the expander and their
4634 -- occurrences are replaced with references to temporaries. Due to
4635 -- this expansion activity, inspect the original tree to detect
4636 -- subprogram calls.
4638 if Nkind (N) = N_Identifier and then Original_Node (N) /= N then
4639 Detect_Subprogram_Call (Original_Node (N));
4641 -- The original construct contains a subprogram call, there is
4642 -- no point in continuing the tree traversal.
4650 -- The original construct contains a subprogram call, there is no
4651 -- point in continuing the tree traversal.
4653 elsif Nkind (N) = N_Object_Declaration
4654 and then Present (Expression (N))
4655 and then Nkind (Original_Node (Expression (N))) = N_Function_Call
4660 -- A regular procedure or function call
4662 elsif Nkind (N) in N_Subprogram_Call then
4671 end Is_Subprogram_Call;
4675 Built : Boolean := False;
4676 Desig_Typ : Entity_Id;
4678 Fin_Block : Node_Id;
4679 Fin_Data : Finalization_Exception_Data;
4680 Fin_Decls : List_Id;
4681 Fin_Insrt : Node_Id;
4682 Last_Fin : Node_Id := Empty;
4686 Obj_Typ : Entity_Id;
4687 Prev_Fin : Node_Id := Empty;
4691 Temp_Id : Entity_Id;
4694 -- Start of processing for Process_Transient_Objects
4697 -- Recognize a scenario where the transient context is an object
4698 -- declaration initialized by a build-in-place function call:
4700 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4702 -- The rough expansion of the above is:
4704 -- Temp : ... := Ctrl_Func_Call;
4706 -- Res : ... := BIP_Func_Call (..., Obj, ...);
4708 -- The finalization of any controlled transient must happen after
4709 -- the build-in-place function call is executed.
4711 if Nkind (N) = N_Object_Declaration
4712 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
4715 Fin_Insrt := BIP_Initialization_Call (Defining_Identifier (N));
4717 -- Search the context for at least one subprogram call. If found, the
4718 -- machinery exports all transient objects to the enclosing finalizer
4719 -- due to the possibility of abnormal call termination.
4722 Detect_Subprogram_Call (N);
4723 Fin_Insrt := Last_Object;
4726 -- Examine all objects in the list First_Object .. Last_Object
4728 Stmt := First_Object;
4729 while Present (Stmt) loop
4730 if Nkind (Stmt) = N_Object_Declaration
4731 and then Analyzed (Stmt)
4732 and then Is_Finalizable_Transient (Stmt, N)
4734 -- Do not process the node to be wrapped since it will be
4735 -- handled by the enclosing finalizer.
4737 and then Stmt /= Related_Node
4740 Obj_Id := Defining_Identifier (Stmt);
4741 Obj_Typ := Base_Type (Etype (Obj_Id));
4742 Desig_Typ := Obj_Typ;
4744 Set_Is_Processed_Transient (Obj_Id);
4746 -- Handle access types
4748 if Is_Access_Type (Desig_Typ) then
4749 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4752 -- Create the necessary entities and declarations the first
4757 Fin_Decls := New_List;
4759 Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
4762 -- Transient variables associated with subprogram calls need
4763 -- extra processing. These variables are usually created right
4764 -- before the call and finalized immediately after the call.
4765 -- If an exception occurs during the call, the clean up code
4766 -- is skipped due to the sudden change in control and the
4767 -- transient is never finalized.
4769 -- To handle this case, such variables are "exported" to the
4770 -- enclosing sequence of statements where their corresponding
4771 -- "hooks" are picked up by the finalization machinery.
4775 -- Step 1: Create an access type which provides a reference
4776 -- to the transient object. Generate:
4778 -- Ann : access [all] <Desig_Typ>;
4780 Ptr_Id := Make_Temporary (Loc, 'A');
4782 Insert_Action (Stmt,
4783 Make_Full_Type_Declaration (Loc,
4784 Defining_Identifier => Ptr_Id,
4786 Make_Access_To_Object_Definition (Loc,
4788 Ekind (Obj_Typ) = E_General_Access_Type,
4789 Subtype_Indication =>
4790 New_Occurrence_Of (Desig_Typ, Loc))));
4792 -- Step 2: Create a temporary which acts as a hook to the
4793 -- transient object. Generate:
4795 -- Temp : Ptr_Id := null;
4797 Temp_Id := Make_Temporary (Loc, 'T');
4799 Insert_Action (Stmt,
4800 Make_Object_Declaration (Loc,
4801 Defining_Identifier => Temp_Id,
4802 Object_Definition =>
4803 New_Occurrence_Of (Ptr_Id, Loc)));
4805 -- Mark the temporary as a transient hook. This signals the
4806 -- machinery in Build_Finalizer to recognize this special
4809 Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
4811 -- Step 3: Hook the transient object to the temporary
4813 if Is_Access_Type (Obj_Typ) then
4815 Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc));
4818 Make_Attribute_Reference (Loc,
4819 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4820 Attribute_Name => Name_Unrestricted_Access);
4824 -- Temp := Ptr_Id (Obj_Id);
4826 -- Temp := Obj_Id'Unrestricted_Access;
4828 -- When the transient object is initialized by an aggregate,
4829 -- the hook must capture the object after the last component
4830 -- assignment takes place. Only then is the object fully
4833 if Ekind (Obj_Id) = E_Variable
4834 and then Present (Last_Aggregate_Assignment (Obj_Id))
4836 Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
4838 -- Otherwise the hook seizes the related object immediately
4844 Insert_After_And_Analyze (Temp_Ins,
4845 Make_Assignment_Statement (Loc,
4846 Name => New_Occurrence_Of (Temp_Id, Loc),
4847 Expression => Expr));
4852 -- The transient object is about to be finalized by the clean
4853 -- up code following the subprogram call. In order to avoid
4854 -- double finalization, clear the hook.
4861 Make_Assignment_Statement (Loc,
4862 Name => New_Occurrence_Of (Temp_Id, Loc),
4863 Expression => Make_Null (Loc)));
4867 -- [Deep_]Finalize (Obj_Ref);
4869 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4871 if Is_Access_Type (Obj_Typ) then
4872 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4876 Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));
4881 -- [Deep_]Finalize (Obj_Ref);
4885 -- if not Raised then
4888 -- (Enn, Get_Current_Excep.all.all);
4893 Make_Block_Statement (Loc,
4894 Handled_Statement_Sequence =>
4895 Make_Handled_Sequence_Of_Statements (Loc,
4896 Statements => Stmts,
4897 Exception_Handlers => New_List (
4898 Build_Exception_Handler (Fin_Data))));
4900 -- The single raise statement must be inserted after all the
4901 -- finalization blocks, and we put everything into a wrapper
4902 -- block to clearly expose the construct to the back-end.
4904 if Present (Prev_Fin) then
4905 Insert_Before_And_Analyze (Prev_Fin, Fin_Block);
4907 Insert_After_And_Analyze (Fin_Insrt,
4908 Make_Block_Statement (Loc,
4909 Declarations => Fin_Decls,
4910 Handled_Statement_Sequence =>
4911 Make_Handled_Sequence_Of_Statements (Loc,
4912 Statements => New_List (Fin_Block))));
4914 Last_Fin := Fin_Block;
4917 Prev_Fin := Fin_Block;
4920 -- Terminate the scan after the last object has been processed to
4921 -- avoid touching unrelated code.
4923 if Stmt = Last_Object then
4931 -- if Raised and then not Abort then
4932 -- Raise_From_Controlled_Operation (E);
4935 if Built and then Present (Last_Fin) then
4936 Insert_After_And_Analyze (Last_Fin,
4937 Build_Raise_Statement (Fin_Data));
4939 end Process_Transient_Objects;
4941 -- Start of processing for Insert_Actions_In_Scope_Around
4944 if No (Act_Before) and then No (Act_After) then
4949 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
4950 First_Obj : Node_Id;
4955 -- If the node to be wrapped is the trigger of an asynchronous
4956 -- select, it is not part of a statement list. The actions must be
4957 -- inserted before the select itself, which is part of some list of
4958 -- statements. Note that the triggering alternative includes the
4959 -- triggering statement and an optional statement list. If the node
4960 -- to be wrapped is part of that list, the normal insertion applies.
4962 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
4963 and then not Is_List_Member (Node_To_Wrap)
4965 Target := Parent (Parent (Node_To_Wrap));
4970 First_Obj := Target;
4973 -- Add all actions associated with a transient scope into the main
4974 -- tree. There are several scenarios here:
4976 -- +--- Before ----+ +----- After ---+
4977 -- 1) First_Obj ....... Target ........ Last_Obj
4979 -- 2) First_Obj ....... Target
4981 -- 3) Target ........ Last_Obj
4983 if Present (Act_Before) then
4985 -- Flag declarations are inserted before the first object
4987 First_Obj := First (Act_Before);
4989 Insert_List_Before (Target, Act_Before);
4992 if Present (Act_After) then
4994 -- Finalization calls are inserted after the last object
4996 Last_Obj := Last (Act_After);
4998 Insert_List_After (Target, Act_After);
5001 -- Check for transient controlled objects associated with Target and
5002 -- generate the appropriate finalization actions for them.
5004 Process_Transient_Objects
5005 (First_Object => First_Obj,
5006 Last_Object => Last_Obj,
5007 Related_Node => Target);
5009 -- Reset the action lists
5011 if Present (Act_Before) then
5012 Scope_Stack.Table (Scope_Stack.Last).
5013 Actions_To_Be_Wrapped (Before) := No_List;
5016 if Present (Act_After) then
5017 Scope_Stack.Table (Scope_Stack.Last).
5018 Actions_To_Be_Wrapped (After) := No_List;
5021 end Insert_Actions_In_Scope_Around;
5023 ------------------------------
5024 -- Is_Simple_Protected_Type --
5025 ------------------------------
5027 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5030 Is_Protected_Type (T)
5031 and then not Uses_Lock_Free (T)
5032 and then not Has_Entries (T)
5033 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5034 end Is_Simple_Protected_Type;
5036 -----------------------
5037 -- Make_Adjust_Call --
5038 -----------------------
5040 function Make_Adjust_Call
5043 Skip_Self : Boolean := False) return Node_Id
5045 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5046 Adj_Id : Entity_Id := Empty;
5047 Ref : Node_Id := Obj_Ref;
5051 -- Recover the proper type which contains Deep_Adjust
5053 if Is_Class_Wide_Type (Typ) then
5054 Utyp := Root_Type (Typ);
5059 Utyp := Underlying_Type (Base_Type (Utyp));
5060 Set_Assignment_OK (Ref);
5062 -- Deal with non-tagged derivation of private views
5064 if Is_Untagged_Derivation (Typ) then
5065 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5066 Ref := Unchecked_Convert_To (Utyp, Ref);
5067 Set_Assignment_OK (Ref);
5070 -- When dealing with the completion of a private type, use the base
5073 if Utyp /= Base_Type (Utyp) then
5074 pragma Assert (Is_Private_Type (Typ));
5076 Utyp := Base_Type (Utyp);
5077 Ref := Unchecked_Convert_To (Utyp, Ref);
5081 if Has_Controlled_Component (Utyp) then
5082 if Is_Tagged_Type (Utyp) then
5083 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5085 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5089 -- Class-wide types, interfaces and types with controlled components
5091 elsif Is_Class_Wide_Type (Typ)
5092 or else Is_Interface (Typ)
5093 or else Has_Controlled_Component (Utyp)
5095 if Is_Tagged_Type (Utyp) then
5096 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5098 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5101 -- Derivations from [Limited_]Controlled
5103 elsif Is_Controlled (Utyp) then
5104 if Has_Controlled_Component (Utyp) then
5105 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5107 Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
5112 elsif Is_Tagged_Type (Utyp) then
5113 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5116 raise Program_Error;
5119 if Present (Adj_Id) then
5121 -- If the object is unanalyzed, set its expected type for use in
5122 -- Convert_View in case an additional conversion is needed.
5125 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
5127 Set_Etype (Ref, Typ);
5130 -- The object reference may need another conversion depending on the
5131 -- type of the formal and that of the actual.
5133 if not Is_Class_Wide_Type (Typ) then
5134 Ref := Convert_View (Adj_Id, Ref);
5140 Param => New_Copy_Tree (Ref),
5141 Skip_Self => Skip_Self);
5145 end Make_Adjust_Call;
5147 ----------------------
5148 -- Make_Attach_Call --
5149 ----------------------
5151 function Make_Attach_Call
5153 Ptr_Typ : Entity_Id) return Node_Id
5155 pragma Assert (VM_Target /= No_VM);
5157 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5160 Make_Procedure_Call_Statement (Loc,
5162 New_Occurrence_Of (RTE (RE_Attach), Loc),
5163 Parameter_Associations => New_List (
5164 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
5165 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
5166 end Make_Attach_Call;
5168 ----------------------
5169 -- Make_Detach_Call --
5170 ----------------------
5172 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
5173 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5177 Make_Procedure_Call_Statement (Loc,
5179 New_Occurrence_Of (RTE (RE_Detach), Loc),
5180 Parameter_Associations => New_List (
5181 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
5182 end Make_Detach_Call;
5190 Proc_Id : Entity_Id;
5192 Skip_Self : Boolean := False) return Node_Id
5194 Params : constant List_Id := New_List (Param);
5197 -- Do not apply the controlled action to the object itself by signaling
5198 -- the related routine to avoid self.
5201 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
5205 Make_Procedure_Call_Statement (Loc,
5206 Name => New_Occurrence_Of (Proc_Id, Loc),
5207 Parameter_Associations => Params);
5210 --------------------------
5211 -- Make_Deep_Array_Body --
5212 --------------------------
5214 function Make_Deep_Array_Body
5215 (Prim : Final_Primitives;
5216 Typ : Entity_Id) return List_Id
5218 function Build_Adjust_Or_Finalize_Statements
5219 (Typ : Entity_Id) return List_Id;
5220 -- Create the statements necessary to adjust or finalize an array of
5221 -- controlled elements. Generate:
5224 -- Abort : constant Boolean := Triggered_By_Abort;
5226 -- Abort : constant Boolean := False; -- no abort
5228 -- E : Exception_Occurrence;
5229 -- Raised : Boolean := False;
5232 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5233 -- ^-- in the finalization case
5235 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5237 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5241 -- if not Raised then
5243 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5250 -- if Raised and then not Abort then
5251 -- Raise_From_Controlled_Operation (E);
5255 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
5256 -- Create the statements necessary to initialize an array of controlled
5257 -- elements. Include a mechanism to carry out partial finalization if an
5258 -- exception occurs. Generate:
5261 -- Counter : Integer := 0;
5264 -- for J1 in V'Range (1) loop
5266 -- for JN in V'Range (N) loop
5268 -- [Deep_]Initialize (V (J1, ..., JN));
5270 -- Counter := Counter + 1;
5275 -- Abort : constant Boolean := Triggered_By_Abort;
5277 -- Abort : constant Boolean := False; -- no abort
5278 -- E : Exception_Occurence;
5279 -- Raised : Boolean := False;
5286 -- V'Length (N) - Counter;
5288 -- for F1 in reverse V'Range (1) loop
5290 -- for FN in reverse V'Range (N) loop
5291 -- if Counter > 0 then
5292 -- Counter := Counter - 1;
5295 -- [Deep_]Finalize (V (F1, ..., FN));
5299 -- if not Raised then
5301 -- Save_Occurrence (E,
5302 -- Get_Current_Excep.all.all);
5311 -- if Raised and then not Abort then
5312 -- Raise_From_Controlled_Operation (E);
5321 function New_References_To
5323 Loc : Source_Ptr) return List_Id;
5324 -- Given a list of defining identifiers, return a list of references to
5325 -- the original identifiers, in the same order as they appear.
5327 -----------------------------------------
5328 -- Build_Adjust_Or_Finalize_Statements --
5329 -----------------------------------------
5331 function Build_Adjust_Or_Finalize_Statements
5332 (Typ : Entity_Id) return List_Id
5334 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5335 Index_List : constant List_Id := New_List;
5336 Loc : constant Source_Ptr := Sloc (Typ);
5337 Num_Dims : constant Int := Number_Dimensions (Typ);
5338 Finalizer_Decls : List_Id := No_List;
5339 Finalizer_Data : Finalization_Exception_Data;
5342 Core_Loop : Node_Id;
5345 Loop_Id : Entity_Id;
5348 Exceptions_OK : constant Boolean :=
5349 not Restriction_Active (No_Exception_Propagation);
5351 procedure Build_Indexes;
5352 -- Generate the indexes used in the dimension loops
5358 procedure Build_Indexes is
5360 -- Generate the following identifiers:
5361 -- Jnn - for initialization
5363 for Dim in 1 .. Num_Dims loop
5364 Append_To (Index_List,
5365 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5369 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5372 Finalizer_Decls := New_List;
5375 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5378 Make_Indexed_Component (Loc,
5379 Prefix => Make_Identifier (Loc, Name_V),
5380 Expressions => New_References_To (Index_List, Loc));
5381 Set_Etype (Comp_Ref, Comp_Typ);
5384 -- [Deep_]Adjust (V (J1, ..., JN))
5386 if Prim = Adjust_Case then
5387 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5390 -- [Deep_]Finalize (V (J1, ..., JN))
5392 else pragma Assert (Prim = Finalize_Case);
5393 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5396 -- Generate the block which houses the adjust or finalize call:
5398 -- <adjust or finalize call>; -- No_Exception_Propagation
5400 -- begin -- Exception handlers allowed
5401 -- <adjust or finalize call>
5405 -- if not Raised then
5407 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5411 if Exceptions_OK then
5413 Make_Block_Statement (Loc,
5414 Handled_Statement_Sequence =>
5415 Make_Handled_Sequence_Of_Statements (Loc,
5416 Statements => New_List (Call),
5417 Exception_Handlers => New_List (
5418 Build_Exception_Handler (Finalizer_Data))));
5423 -- Generate the dimension loops starting from the innermost one
5425 -- for Jnn in [reverse] V'Range (Dim) loop
5429 J := Last (Index_List);
5431 while Present (J) and then Dim > 0 loop
5437 Make_Loop_Statement (Loc,
5439 Make_Iteration_Scheme (Loc,
5440 Loop_Parameter_Specification =>
5441 Make_Loop_Parameter_Specification (Loc,
5442 Defining_Identifier => Loop_Id,
5443 Discrete_Subtype_Definition =>
5444 Make_Attribute_Reference (Loc,
5445 Prefix => Make_Identifier (Loc, Name_V),
5446 Attribute_Name => Name_Range,
5447 Expressions => New_List (
5448 Make_Integer_Literal (Loc, Dim))),
5450 Reverse_Present => Prim = Finalize_Case)),
5452 Statements => New_List (Core_Loop),
5453 End_Label => Empty);
5458 -- Generate the block which contains the core loop, the declarations
5459 -- of the abort flag, the exception occurrence, the raised flag and
5460 -- the conditional raise:
5463 -- Abort : constant Boolean := Triggered_By_Abort;
5465 -- Abort : constant Boolean := False; -- no abort
5467 -- E : Exception_Occurrence;
5468 -- Raised : Boolean := False;
5473 -- if Raised and then not Abort then -- Expection handlers OK
5474 -- Raise_From_Controlled_Operation (E);
5478 Stmts := New_List (Core_Loop);
5480 if Exceptions_OK then
5482 Build_Raise_Statement (Finalizer_Data));
5487 Make_Block_Statement (Loc,
5490 Handled_Statement_Sequence =>
5491 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5492 end Build_Adjust_Or_Finalize_Statements;
5494 ---------------------------------
5495 -- Build_Initialize_Statements --
5496 ---------------------------------
5498 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
5499 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5500 Final_List : constant List_Id := New_List;
5501 Index_List : constant List_Id := New_List;
5502 Loc : constant Source_Ptr := Sloc (Typ);
5503 Num_Dims : constant Int := Number_Dimensions (Typ);
5504 Counter_Id : Entity_Id;
5508 Final_Block : Node_Id;
5509 Final_Loop : Node_Id;
5510 Finalizer_Data : Finalization_Exception_Data;
5511 Finalizer_Decls : List_Id := No_List;
5512 Init_Loop : Node_Id;
5517 Exceptions_OK : constant Boolean :=
5518 not Restriction_Active (No_Exception_Propagation);
5520 function Build_Counter_Assignment return Node_Id;
5521 -- Generate the following assignment:
5522 -- Counter := V'Length (1) *
5524 -- V'Length (N) - Counter;
5526 function Build_Finalization_Call return Node_Id;
5527 -- Generate a deep finalization call for an array element
5529 procedure Build_Indexes;
5530 -- Generate the initialization and finalization indexes used in the
5533 function Build_Initialization_Call return Node_Id;
5534 -- Generate a deep initialization call for an array element
5536 ------------------------------
5537 -- Build_Counter_Assignment --
5538 ------------------------------
5540 function Build_Counter_Assignment return Node_Id is
5545 -- Start from the first dimension and generate:
5550 Make_Attribute_Reference (Loc,
5551 Prefix => Make_Identifier (Loc, Name_V),
5552 Attribute_Name => Name_Length,
5553 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
5555 -- Process the rest of the dimensions, generate:
5556 -- Expr * V'Length (N)
5559 while Dim <= Num_Dims loop
5561 Make_Op_Multiply (Loc,
5564 Make_Attribute_Reference (Loc,
5565 Prefix => Make_Identifier (Loc, Name_V),
5566 Attribute_Name => Name_Length,
5567 Expressions => New_List (
5568 Make_Integer_Literal (Loc, Dim))));
5574 -- Counter := Expr - Counter;
5577 Make_Assignment_Statement (Loc,
5578 Name => New_Occurrence_Of (Counter_Id, Loc),
5580 Make_Op_Subtract (Loc,
5582 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
5583 end Build_Counter_Assignment;
5585 -----------------------------
5586 -- Build_Finalization_Call --
5587 -----------------------------
5589 function Build_Finalization_Call return Node_Id is
5590 Comp_Ref : constant Node_Id :=
5591 Make_Indexed_Component (Loc,
5592 Prefix => Make_Identifier (Loc, Name_V),
5593 Expressions => New_References_To (Final_List, Loc));
5596 Set_Etype (Comp_Ref, Comp_Typ);
5599 -- [Deep_]Finalize (V);
5601 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5602 end Build_Finalization_Call;
5608 procedure Build_Indexes is
5610 -- Generate the following identifiers:
5611 -- Jnn - for initialization
5612 -- Fnn - for finalization
5614 for Dim in 1 .. Num_Dims loop
5615 Append_To (Index_List,
5616 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5618 Append_To (Final_List,
5619 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
5623 -------------------------------
5624 -- Build_Initialization_Call --
5625 -------------------------------
5627 function Build_Initialization_Call return Node_Id is
5628 Comp_Ref : constant Node_Id :=
5629 Make_Indexed_Component (Loc,
5630 Prefix => Make_Identifier (Loc, Name_V),
5631 Expressions => New_References_To (Index_List, Loc));
5634 Set_Etype (Comp_Ref, Comp_Typ);
5637 -- [Deep_]Initialize (V (J1, ..., JN));
5639 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5640 end Build_Initialization_Call;
5642 -- Start of processing for Build_Initialize_Statements
5645 Counter_Id := Make_Temporary (Loc, 'C');
5646 Finalizer_Decls := New_List;
5649 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5651 -- Generate the block which houses the finalization call, the index
5652 -- guard and the handler which triggers Program_Error later on.
5654 -- if Counter > 0 then
5655 -- Counter := Counter - 1;
5657 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5659 -- begin -- Exceptions allowed
5660 -- [Deep_]Finalize (V (F1, ..., FN));
5663 -- if not Raised then
5665 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5670 if Exceptions_OK then
5672 Make_Block_Statement (Loc,
5673 Handled_Statement_Sequence =>
5674 Make_Handled_Sequence_Of_Statements (Loc,
5675 Statements => New_List (Build_Finalization_Call),
5676 Exception_Handlers => New_List (
5677 Build_Exception_Handler (Finalizer_Data))));
5679 Fin_Stmt := Build_Finalization_Call;
5682 -- This is the core of the loop, the dimension iterators are added
5683 -- one by one in reverse.
5686 Make_If_Statement (Loc,
5689 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
5690 Right_Opnd => Make_Integer_Literal (Loc, 0)),
5692 Then_Statements => New_List (
5693 Make_Assignment_Statement (Loc,
5694 Name => New_Occurrence_Of (Counter_Id, Loc),
5696 Make_Op_Subtract (Loc,
5697 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
5698 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
5700 Else_Statements => New_List (Fin_Stmt));
5702 -- Generate all finalization loops starting from the innermost
5705 -- for Fnn in reverse V'Range (Dim) loop
5709 F := Last (Final_List);
5711 while Present (F) and then Dim > 0 loop
5717 Make_Loop_Statement (Loc,
5719 Make_Iteration_Scheme (Loc,
5720 Loop_Parameter_Specification =>
5721 Make_Loop_Parameter_Specification (Loc,
5722 Defining_Identifier => Loop_Id,
5723 Discrete_Subtype_Definition =>
5724 Make_Attribute_Reference (Loc,
5725 Prefix => Make_Identifier (Loc, Name_V),
5726 Attribute_Name => Name_Range,
5727 Expressions => New_List (
5728 Make_Integer_Literal (Loc, Dim))),
5730 Reverse_Present => True)),
5732 Statements => New_List (Final_Loop),
5733 End_Label => Empty);
5738 -- Generate the block which contains the finalization loops, the
5739 -- declarations of the abort flag, the exception occurrence, the
5740 -- raised flag and the conditional raise.
5743 -- Abort : constant Boolean := Triggered_By_Abort;
5745 -- Abort : constant Boolean := False; -- no abort
5747 -- E : Exception_Occurrence;
5748 -- Raised : Boolean := False;
5754 -- V'Length (N) - Counter;
5758 -- if Raised and then not Abort then -- Exception handlers OK
5759 -- Raise_From_Controlled_Operation (E);
5762 -- raise; -- Exception handlers OK
5765 Stmts := New_List (Build_Counter_Assignment, Final_Loop);
5767 if Exceptions_OK then
5769 Build_Raise_Statement (Finalizer_Data));
5770 Append_To (Stmts, Make_Raise_Statement (Loc));
5774 Make_Block_Statement (Loc,
5777 Handled_Statement_Sequence =>
5778 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
5780 -- Generate the block which contains the initialization call and
5781 -- the partial finalization code.
5784 -- [Deep_]Initialize (V (J1, ..., JN));
5786 -- Counter := Counter + 1;
5790 -- <finalization code>
5794 Make_Block_Statement (Loc,
5795 Handled_Statement_Sequence =>
5796 Make_Handled_Sequence_Of_Statements (Loc,
5797 Statements => New_List (Build_Initialization_Call),
5798 Exception_Handlers => New_List (
5799 Make_Exception_Handler (Loc,
5800 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5801 Statements => New_List (Final_Block)))));
5803 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
5804 Make_Assignment_Statement (Loc,
5805 Name => New_Occurrence_Of (Counter_Id, Loc),
5808 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
5809 Right_Opnd => Make_Integer_Literal (Loc, 1))));
5811 -- Generate all initialization loops starting from the innermost
5814 -- for Jnn in V'Range (Dim) loop
5818 J := Last (Index_List);
5820 while Present (J) and then Dim > 0 loop
5826 Make_Loop_Statement (Loc,
5828 Make_Iteration_Scheme (Loc,
5829 Loop_Parameter_Specification =>
5830 Make_Loop_Parameter_Specification (Loc,
5831 Defining_Identifier => Loop_Id,
5832 Discrete_Subtype_Definition =>
5833 Make_Attribute_Reference (Loc,
5834 Prefix => Make_Identifier (Loc, Name_V),
5835 Attribute_Name => Name_Range,
5836 Expressions => New_List (
5837 Make_Integer_Literal (Loc, Dim))))),
5839 Statements => New_List (Init_Loop),
5840 End_Label => Empty);
5845 -- Generate the block which contains the counter variable and the
5846 -- initialization loops.
5849 -- Counter : Integer := 0;
5856 Make_Block_Statement (Loc,
5857 Declarations => New_List (
5858 Make_Object_Declaration (Loc,
5859 Defining_Identifier => Counter_Id,
5860 Object_Definition =>
5861 New_Occurrence_Of (Standard_Integer, Loc),
5862 Expression => Make_Integer_Literal (Loc, 0))),
5864 Handled_Statement_Sequence =>
5865 Make_Handled_Sequence_Of_Statements (Loc,
5866 Statements => New_List (Init_Loop))));
5867 end Build_Initialize_Statements;
5869 -----------------------
5870 -- New_References_To --
5871 -----------------------
5873 function New_References_To
5875 Loc : Source_Ptr) return List_Id
5877 Refs : constant List_Id := New_List;
5882 while Present (Id) loop
5883 Append_To (Refs, New_Occurrence_Of (Id, Loc));
5888 end New_References_To;
5890 -- Start of processing for Make_Deep_Array_Body
5894 when Address_Case =>
5895 return Make_Finalize_Address_Stmts (Typ);
5899 return Build_Adjust_Or_Finalize_Statements (Typ);
5901 when Initialize_Case =>
5902 return Build_Initialize_Statements (Typ);
5904 end Make_Deep_Array_Body;
5906 --------------------
5907 -- Make_Deep_Proc --
5908 --------------------
5910 function Make_Deep_Proc
5911 (Prim : Final_Primitives;
5913 Stmts : List_Id) return Entity_Id
5915 Loc : constant Source_Ptr := Sloc (Typ);
5917 Proc_Id : Entity_Id;
5920 -- Create the object formal, generate:
5921 -- V : System.Address
5923 if Prim = Address_Case then
5924 Formals := New_List (
5925 Make_Parameter_Specification (Loc,
5926 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5928 New_Occurrence_Of (RTE (RE_Address), Loc)));
5935 Formals := New_List (
5936 Make_Parameter_Specification (Loc,
5937 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5939 Out_Present => True,
5940 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
5942 -- F : Boolean := True
5944 if Prim = Adjust_Case
5945 or else Prim = Finalize_Case
5948 Make_Parameter_Specification (Loc,
5949 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
5951 New_Occurrence_Of (Standard_Boolean, Loc),
5953 New_Occurrence_Of (Standard_True, Loc)));
5958 Make_Defining_Identifier (Loc,
5959 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
5962 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5965 -- exception -- Finalize and Adjust cases only
5966 -- raise Program_Error;
5967 -- end Deep_Initialize / Adjust / Finalize;
5971 -- procedure Finalize_Address (V : System.Address) is
5974 -- end Finalize_Address;
5977 Make_Subprogram_Body (Loc,
5979 Make_Procedure_Specification (Loc,
5980 Defining_Unit_Name => Proc_Id,
5981 Parameter_Specifications => Formals),
5983 Declarations => Empty_List,
5985 Handled_Statement_Sequence =>
5986 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
5991 ---------------------------
5992 -- Make_Deep_Record_Body --
5993 ---------------------------
5995 function Make_Deep_Record_Body
5996 (Prim : Final_Primitives;
5998 Is_Local : Boolean := False) return List_Id
6000 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
6001 -- Build the statements necessary to adjust a record type. The type may
6002 -- have discriminants and contain variant parts. Generate:
6006 -- [Deep_]Adjust (V.Comp_1);
6008 -- when Id : others =>
6009 -- if not Raised then
6011 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6016 -- [Deep_]Adjust (V.Comp_N);
6018 -- when Id : others =>
6019 -- if not Raised then
6021 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6026 -- Deep_Adjust (V._parent, False); -- If applicable
6028 -- when Id : others =>
6029 -- if not Raised then
6031 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6037 -- Adjust (V); -- If applicable
6040 -- if not Raised then
6042 -- Save_Occurence (E, Get_Current_Excep.all.all);
6047 -- if Raised and then not Abort then
6048 -- Raise_From_Controlled_Operation (E);
6052 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
6053 -- Build the statements necessary to finalize a record type. The type
6054 -- may have discriminants and contain variant parts. Generate:
6057 -- Abort : constant Boolean := Triggered_By_Abort;
6059 -- Abort : constant Boolean := False; -- no abort
6060 -- E : Exception_Occurence;
6061 -- Raised : Boolean := False;
6066 -- Finalize (V); -- If applicable
6069 -- if not Raised then
6071 -- Save_Occurence (E, Get_Current_Excep.all.all);
6076 -- case Variant_1 is
6078 -- case State_Counter_N => -- If Is_Local is enabled
6088 -- <<LN>> -- If Is_Local is enabled
6090 -- [Deep_]Finalize (V.Comp_N);
6093 -- if not Raised then
6095 -- Save_Occurence (E, Get_Current_Excep.all.all);
6101 -- [Deep_]Finalize (V.Comp_1);
6104 -- if not Raised then
6106 -- Save_Occurence (E, Get_Current_Excep.all.all);
6112 -- case State_Counter_1 => -- If Is_Local is enabled
6118 -- Deep_Finalize (V._parent, False); -- If applicable
6120 -- when Id : others =>
6121 -- if not Raised then
6123 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6127 -- if Raised and then not Abort then
6128 -- Raise_From_Controlled_Operation (E);
6132 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
6133 -- Given a derived tagged type Typ, traverse all components, find field
6134 -- _parent and return its type.
6136 procedure Preprocess_Components
6138 Num_Comps : out Int;
6139 Has_POC : out Boolean);
6140 -- Examine all components in component list Comps, count all controlled
6141 -- components and determine whether at least one of them is per-object
6142 -- constrained. Component _parent is always skipped.
6144 -----------------------------
6145 -- Build_Adjust_Statements --
6146 -----------------------------
6148 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
6149 Loc : constant Source_Ptr := Sloc (Typ);
6150 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
6151 Bod_Stmts : List_Id;
6152 Finalizer_Data : Finalization_Exception_Data;
6153 Finalizer_Decls : List_Id := No_List;
6157 Exceptions_OK : constant Boolean :=
6158 not Restriction_Active (No_Exception_Propagation);
6160 function Process_Component_List_For_Adjust
6161 (Comps : Node_Id) return List_Id;
6162 -- Build all necessary adjust statements for a single component list
6164 ---------------------------------------
6165 -- Process_Component_List_For_Adjust --
6166 ---------------------------------------
6168 function Process_Component_List_For_Adjust
6169 (Comps : Node_Id) return List_Id
6171 Stmts : constant List_Id := New_List;
6173 Decl_Id : Entity_Id;
6174 Decl_Typ : Entity_Id;
6178 procedure Process_Component_For_Adjust (Decl : Node_Id);
6179 -- Process the declaration of a single controlled component
6181 ----------------------------------
6182 -- Process_Component_For_Adjust --
6183 ----------------------------------
6185 procedure Process_Component_For_Adjust (Decl : Node_Id) is
6186 Id : constant Entity_Id := Defining_Identifier (Decl);
6187 Typ : constant Entity_Id := Etype (Id);
6192 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
6194 -- begin -- Exception handlers allowed
6195 -- [Deep_]Adjust (V.Id);
6198 -- if not Raised then
6200 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6207 Make_Selected_Component (Loc,
6208 Prefix => Make_Identifier (Loc, Name_V),
6209 Selector_Name => Make_Identifier (Loc, Chars (Id))),
6212 if Exceptions_OK then
6214 Make_Block_Statement (Loc,
6215 Handled_Statement_Sequence =>
6216 Make_Handled_Sequence_Of_Statements (Loc,
6217 Statements => New_List (Adj_Stmt),
6218 Exception_Handlers => New_List (
6219 Build_Exception_Handler (Finalizer_Data))));
6222 Append_To (Stmts, Adj_Stmt);
6223 end Process_Component_For_Adjust;
6225 -- Start of processing for Process_Component_List_For_Adjust
6228 -- Perform an initial check, determine the number of controlled
6229 -- components in the current list and whether at least one of them
6230 -- is per-object constrained.
6232 Preprocess_Components (Comps, Num_Comps, Has_POC);
6234 -- The processing in this routine is done in the following order:
6235 -- 1) Regular components
6236 -- 2) Per-object constrained components
6239 if Num_Comps > 0 then
6241 -- Process all regular components in order of declarations
6243 Decl := First_Non_Pragma (Component_Items (Comps));
6244 while Present (Decl) loop
6245 Decl_Id := Defining_Identifier (Decl);
6246 Decl_Typ := Etype (Decl_Id);
6248 -- Skip _parent as well as per-object constrained components
6250 if Chars (Decl_Id) /= Name_uParent
6251 and then Needs_Finalization (Decl_Typ)
6253 if Has_Access_Constraint (Decl_Id)
6254 and then No (Expression (Decl))
6258 Process_Component_For_Adjust (Decl);
6262 Next_Non_Pragma (Decl);
6265 -- Process all per-object constrained components in order of
6269 Decl := First_Non_Pragma (Component_Items (Comps));
6270 while Present (Decl) loop
6271 Decl_Id := Defining_Identifier (Decl);
6272 Decl_Typ := Etype (Decl_Id);
6276 if Chars (Decl_Id) /= Name_uParent
6277 and then Needs_Finalization (Decl_Typ)
6278 and then Has_Access_Constraint (Decl_Id)
6279 and then No (Expression (Decl))
6281 Process_Component_For_Adjust (Decl);
6284 Next_Non_Pragma (Decl);
6289 -- Process all variants, if any
6292 if Present (Variant_Part (Comps)) then
6294 Var_Alts : constant List_Id := New_List;
6298 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6299 while Present (Var) loop
6302 -- when <discrete choices> =>
6303 -- <adjust statements>
6305 Append_To (Var_Alts,
6306 Make_Case_Statement_Alternative (Loc,
6308 New_Copy_List (Discrete_Choices (Var)),
6310 Process_Component_List_For_Adjust (
6311 Component_List (Var))));
6313 Next_Non_Pragma (Var);
6317 -- case V.<discriminant> is
6318 -- when <discrete choices 1> =>
6319 -- <adjust statements 1>
6321 -- when <discrete choices N> =>
6322 -- <adjust statements N>
6326 Make_Case_Statement (Loc,
6328 Make_Selected_Component (Loc,
6329 Prefix => Make_Identifier (Loc, Name_V),
6331 Make_Identifier (Loc,
6332 Chars => Chars (Name (Variant_Part (Comps))))),
6333 Alternatives => Var_Alts);
6337 -- Add the variant case statement to the list of statements
6339 if Present (Var_Case) then
6340 Append_To (Stmts, Var_Case);
6343 -- If the component list did not have any controlled components
6344 -- nor variants, return null.
6346 if Is_Empty_List (Stmts) then
6347 Append_To (Stmts, Make_Null_Statement (Loc));
6351 end Process_Component_List_For_Adjust;
6353 -- Start of processing for Build_Adjust_Statements
6356 Finalizer_Decls := New_List;
6357 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6359 if Nkind (Typ_Def) = N_Derived_Type_Definition then
6360 Rec_Def := Record_Extension_Part (Typ_Def);
6365 -- Create an adjust sequence for all record components
6367 if Present (Component_List (Rec_Def)) then
6369 Process_Component_List_For_Adjust (Component_List (Rec_Def));
6372 -- A derived record type must adjust all inherited components. This
6373 -- action poses the following problem:
6375 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6380 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6382 -- Deep_Adjust (Obj._parent);
6387 -- Adjusting the derived type will invoke Adjust of the parent and
6388 -- then that of the derived type. This is undesirable because both
6389 -- routines may modify shared components. Only the Adjust of the
6390 -- derived type should be invoked.
6392 -- To prevent this double adjustment of shared components,
6393 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6395 -- procedure Deep_Adjust
6396 -- (Obj : in out Some_Type;
6397 -- Flag : Boolean := True)
6405 -- When Deep_Adjust is invokes for field _parent, a value of False is
6406 -- provided for the flag:
6408 -- Deep_Adjust (Obj._parent, False);
6410 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
6412 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
6417 if Needs_Finalization (Par_Typ) then
6421 Make_Selected_Component (Loc,
6422 Prefix => Make_Identifier (Loc, Name_V),
6424 Make_Identifier (Loc, Name_uParent)),
6429 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
6431 -- begin -- Exceptions OK
6432 -- Deep_Adjust (V._parent, False);
6434 -- when Id : others =>
6435 -- if not Raised then
6437 -- Save_Occurrence (E,
6438 -- Get_Current_Excep.all.all);
6442 if Present (Call) then
6445 if Exceptions_OK then
6447 Make_Block_Statement (Loc,
6448 Handled_Statement_Sequence =>
6449 Make_Handled_Sequence_Of_Statements (Loc,
6450 Statements => New_List (Adj_Stmt),
6451 Exception_Handlers => New_List (
6452 Build_Exception_Handler (Finalizer_Data))));
6455 Prepend_To (Bod_Stmts, Adj_Stmt);
6461 -- Adjust the object. This action must be performed last after all
6462 -- components have been adjusted.
6464 if Is_Controlled (Typ) then
6470 Proc := Find_Prim_Op (Typ, Name_Adjust);
6474 -- Adjust (V); -- No_Exception_Propagation
6476 -- begin -- Exception handlers allowed
6480 -- if not Raised then
6482 -- Save_Occurrence (E,
6483 -- Get_Current_Excep.all.all);
6488 if Present (Proc) then
6490 Make_Procedure_Call_Statement (Loc,
6491 Name => New_Occurrence_Of (Proc, Loc),
6492 Parameter_Associations => New_List (
6493 Make_Identifier (Loc, Name_V)));
6495 if Exceptions_OK then
6497 Make_Block_Statement (Loc,
6498 Handled_Statement_Sequence =>
6499 Make_Handled_Sequence_Of_Statements (Loc,
6500 Statements => New_List (Adj_Stmt),
6501 Exception_Handlers => New_List (
6502 Build_Exception_Handler
6503 (Finalizer_Data))));
6506 Append_To (Bod_Stmts,
6507 Make_If_Statement (Loc,
6508 Condition => Make_Identifier (Loc, Name_F),
6509 Then_Statements => New_List (Adj_Stmt)));
6514 -- At this point either all adjustment statements have been generated
6515 -- or the type is not controlled.
6517 if Is_Empty_List (Bod_Stmts) then
6518 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
6524 -- Abort : constant Boolean := Triggered_By_Abort;
6526 -- Abort : constant Boolean := False; -- no abort
6528 -- E : Exception_Occurence;
6529 -- Raised : Boolean := False;
6532 -- <adjust statements>
6534 -- if Raised and then not Abort then
6535 -- Raise_From_Controlled_Operation (E);
6540 if Exceptions_OK then
6541 Append_To (Bod_Stmts,
6542 Build_Raise_Statement (Finalizer_Data));
6547 Make_Block_Statement (Loc,
6550 Handled_Statement_Sequence =>
6551 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6553 end Build_Adjust_Statements;
6555 -------------------------------
6556 -- Build_Finalize_Statements --
6557 -------------------------------
6559 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
6560 Loc : constant Source_Ptr := Sloc (Typ);
6561 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
6562 Bod_Stmts : List_Id;
6564 Finalizer_Data : Finalization_Exception_Data;
6565 Finalizer_Decls : List_Id := No_List;
6569 Exceptions_OK : constant Boolean :=
6570 not Restriction_Active (No_Exception_Propagation);
6572 function Process_Component_List_For_Finalize
6573 (Comps : Node_Id) return List_Id;
6574 -- Build all necessary finalization statements for a single component
6575 -- list. The statements may include a jump circuitry if flag Is_Local
6578 -----------------------------------------
6579 -- Process_Component_List_For_Finalize --
6580 -----------------------------------------
6582 function Process_Component_List_For_Finalize
6583 (Comps : Node_Id) return List_Id
6586 Counter_Id : Entity_Id;
6588 Decl_Id : Entity_Id;
6589 Decl_Typ : Entity_Id;
6592 Jump_Block : Node_Id;
6594 Label_Id : Entity_Id;
6598 procedure Process_Component_For_Finalize
6603 -- Process the declaration of a single controlled component. If
6604 -- flag Is_Local is enabled, create the corresponding label and
6605 -- jump circuitry. Alts is the list of case alternatives, Decls
6606 -- is the top level declaration list where labels are declared
6607 -- and Stmts is the list of finalization actions.
6609 ------------------------------------
6610 -- Process_Component_For_Finalize --
6611 ------------------------------------
6613 procedure Process_Component_For_Finalize
6619 Id : constant Entity_Id := Defining_Identifier (Decl);
6620 Typ : constant Entity_Id := Etype (Id);
6627 Label_Id : Entity_Id;
6634 Make_Identifier (Loc,
6635 Chars => New_External_Name ('L', Num_Comps));
6636 Set_Entity (Label_Id,
6637 Make_Defining_Identifier (Loc, Chars (Label_Id)));
6638 Label := Make_Label (Loc, Label_Id);
6641 Make_Implicit_Label_Declaration (Loc,
6642 Defining_Identifier => Entity (Label_Id),
6643 Label_Construct => Label));
6650 Make_Case_Statement_Alternative (Loc,
6651 Discrete_Choices => New_List (
6652 Make_Integer_Literal (Loc, Num_Comps)),
6654 Statements => New_List (
6655 Make_Goto_Statement (Loc,
6657 New_Occurrence_Of (Entity (Label_Id), Loc)))));
6662 Append_To (Stmts, Label);
6664 -- Decrease the number of components to be processed.
6665 -- This action yields a new Label_Id in future calls.
6667 Num_Comps := Num_Comps - 1;
6672 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6674 -- begin -- Exception handlers allowed
6675 -- [Deep_]Finalize (V.Id);
6678 -- if not Raised then
6680 -- Save_Occurrence (E,
6681 -- Get_Current_Excep.all.all);
6688 Make_Selected_Component (Loc,
6689 Prefix => Make_Identifier (Loc, Name_V),
6690 Selector_Name => Make_Identifier (Loc, Chars (Id))),
6693 if not Restriction_Active (No_Exception_Propagation) then
6695 Make_Block_Statement (Loc,
6696 Handled_Statement_Sequence =>
6697 Make_Handled_Sequence_Of_Statements (Loc,
6698 Statements => New_List (Fin_Stmt),
6699 Exception_Handlers => New_List (
6700 Build_Exception_Handler (Finalizer_Data))));
6703 Append_To (Stmts, Fin_Stmt);
6704 end Process_Component_For_Finalize;
6706 -- Start of processing for Process_Component_List_For_Finalize
6709 -- Perform an initial check, look for controlled and per-object
6710 -- constrained components.
6712 Preprocess_Components (Comps, Num_Comps, Has_POC);
6714 -- Create a state counter to service the current component list.
6715 -- This step is performed before the variants are inspected in
6716 -- order to generate the same state counter names as those from
6717 -- Build_Initialize_Statements.
6719 if Num_Comps > 0 and then Is_Local then
6720 Counter := Counter + 1;
6723 Make_Defining_Identifier (Loc,
6724 Chars => New_External_Name ('C', Counter));
6727 -- Process the component in the following order:
6729 -- 2) Per-object constrained components
6730 -- 3) Regular components
6732 -- Start with the variant parts
6735 if Present (Variant_Part (Comps)) then
6737 Var_Alts : constant List_Id := New_List;
6741 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6742 while Present (Var) loop
6745 -- when <discrete choices> =>
6746 -- <finalize statements>
6748 Append_To (Var_Alts,
6749 Make_Case_Statement_Alternative (Loc,
6751 New_Copy_List (Discrete_Choices (Var)),
6753 Process_Component_List_For_Finalize (
6754 Component_List (Var))));
6756 Next_Non_Pragma (Var);
6760 -- case V.<discriminant> is
6761 -- when <discrete choices 1> =>
6762 -- <finalize statements 1>
6764 -- when <discrete choices N> =>
6765 -- <finalize statements N>
6769 Make_Case_Statement (Loc,
6771 Make_Selected_Component (Loc,
6772 Prefix => Make_Identifier (Loc, Name_V),
6774 Make_Identifier (Loc,
6775 Chars => Chars (Name (Variant_Part (Comps))))),
6776 Alternatives => Var_Alts);
6780 -- The current component list does not have a single controlled
6781 -- component, however it may contain variants. Return the case
6782 -- statement for the variants or nothing.
6784 if Num_Comps = 0 then
6785 if Present (Var_Case) then
6786 return New_List (Var_Case);
6788 return New_List (Make_Null_Statement (Loc));
6792 -- Prepare all lists
6798 -- Process all per-object constrained components in reverse order
6801 Decl := Last_Non_Pragma (Component_Items (Comps));
6802 while Present (Decl) loop
6803 Decl_Id := Defining_Identifier (Decl);
6804 Decl_Typ := Etype (Decl_Id);
6808 if Chars (Decl_Id) /= Name_uParent
6809 and then Needs_Finalization (Decl_Typ)
6810 and then Has_Access_Constraint (Decl_Id)
6811 and then No (Expression (Decl))
6813 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6816 Prev_Non_Pragma (Decl);
6820 -- Process the rest of the components in reverse order
6822 Decl := Last_Non_Pragma (Component_Items (Comps));
6823 while Present (Decl) loop
6824 Decl_Id := Defining_Identifier (Decl);
6825 Decl_Typ := Etype (Decl_Id);
6829 if Chars (Decl_Id) /= Name_uParent
6830 and then Needs_Finalization (Decl_Typ)
6832 -- Skip per-object constrained components since they were
6833 -- handled in the above step.
6835 if Has_Access_Constraint (Decl_Id)
6836 and then No (Expression (Decl))
6840 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6844 Prev_Non_Pragma (Decl);
6849 -- LN : label; -- If Is_Local is enabled
6854 -- case CounterX is .
6864 -- <<LN>> -- If Is_Local is enabled
6866 -- [Deep_]Finalize (V.CompY);
6868 -- when Id : others =>
6869 -- if not Raised then
6871 -- Save_Occurrence (E,
6872 -- Get_Current_Excep.all.all);
6876 -- <<L0>> -- If Is_Local is enabled
6881 -- Add the declaration of default jump location L0, its
6882 -- corresponding alternative and its place in the statements.
6884 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
6885 Set_Entity (Label_Id,
6886 Make_Defining_Identifier (Loc, Chars (Label_Id)));
6887 Label := Make_Label (Loc, Label_Id);
6889 Append_To (Decls, -- declaration
6890 Make_Implicit_Label_Declaration (Loc,
6891 Defining_Identifier => Entity (Label_Id),
6892 Label_Construct => Label));
6894 Append_To (Alts, -- alternative
6895 Make_Case_Statement_Alternative (Loc,
6896 Discrete_Choices => New_List (
6897 Make_Others_Choice (Loc)),
6899 Statements => New_List (
6900 Make_Goto_Statement (Loc,
6901 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
6903 Append_To (Stmts, Label); -- statement
6905 -- Create the jump block
6908 Make_Case_Statement (Loc,
6909 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
6910 Alternatives => Alts));
6914 Make_Block_Statement (Loc,
6915 Declarations => Decls,
6916 Handled_Statement_Sequence =>
6917 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6919 if Present (Var_Case) then
6920 return New_List (Var_Case, Jump_Block);
6922 return New_List (Jump_Block);
6924 end Process_Component_List_For_Finalize;
6926 -- Start of processing for Build_Finalize_Statements
6929 Finalizer_Decls := New_List;
6930 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6932 if Nkind (Typ_Def) = N_Derived_Type_Definition then
6933 Rec_Def := Record_Extension_Part (Typ_Def);
6938 -- Create a finalization sequence for all record components
6940 if Present (Component_List (Rec_Def)) then
6942 Process_Component_List_For_Finalize (Component_List (Rec_Def));
6945 -- A derived record type must finalize all inherited components. This
6946 -- action poses the following problem:
6948 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6953 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6955 -- Deep_Finalize (Obj._parent);
6960 -- Finalizing the derived type will invoke Finalize of the parent and
6961 -- then that of the derived type. This is undesirable because both
6962 -- routines may modify shared components. Only the Finalize of the
6963 -- derived type should be invoked.
6965 -- To prevent this double adjustment of shared components,
6966 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6968 -- procedure Deep_Finalize
6969 -- (Obj : in out Some_Type;
6970 -- Flag : Boolean := True)
6978 -- When Deep_Finalize is invokes for field _parent, a value of False
6979 -- is provided for the flag:
6981 -- Deep_Finalize (Obj._parent, False);
6983 if Is_Tagged_Type (Typ)
6984 and then Is_Derived_Type (Typ)
6987 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
6992 if Needs_Finalization (Par_Typ) then
6996 Make_Selected_Component (Loc,
6997 Prefix => Make_Identifier (Loc, Name_V),
6999 Make_Identifier (Loc, Name_uParent)),
7004 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
7006 -- begin -- Exceptions OK
7007 -- Deep_Finalize (V._parent, False);
7009 -- when Id : others =>
7010 -- if not Raised then
7012 -- Save_Occurrence (E,
7013 -- Get_Current_Excep.all.all);
7017 if Present (Call) then
7020 if Exceptions_OK then
7022 Make_Block_Statement (Loc,
7023 Handled_Statement_Sequence =>
7024 Make_Handled_Sequence_Of_Statements (Loc,
7025 Statements => New_List (Fin_Stmt),
7026 Exception_Handlers => New_List (
7027 Build_Exception_Handler
7028 (Finalizer_Data))));
7031 Append_To (Bod_Stmts, Fin_Stmt);
7037 -- Finalize the object. This action must be performed first before
7038 -- all components have been finalized.
7040 if Is_Controlled (Typ)
7041 and then not Is_Local
7048 Proc := Find_Prim_Op (Typ, Name_Finalize);
7052 -- Finalize (V); -- No_Exception_Propagation
7058 -- if not Raised then
7060 -- Save_Occurrence (E,
7061 -- Get_Current_Excep.all.all);
7066 if Present (Proc) then
7068 Make_Procedure_Call_Statement (Loc,
7069 Name => New_Occurrence_Of (Proc, Loc),
7070 Parameter_Associations => New_List (
7071 Make_Identifier (Loc, Name_V)));
7073 if Exceptions_OK then
7075 Make_Block_Statement (Loc,
7076 Handled_Statement_Sequence =>
7077 Make_Handled_Sequence_Of_Statements (Loc,
7078 Statements => New_List (Fin_Stmt),
7079 Exception_Handlers => New_List (
7080 Build_Exception_Handler
7081 (Finalizer_Data))));
7084 Prepend_To (Bod_Stmts,
7085 Make_If_Statement (Loc,
7086 Condition => Make_Identifier (Loc, Name_F),
7087 Then_Statements => New_List (Fin_Stmt)));
7092 -- At this point either all finalization statements have been
7093 -- generated or the type is not controlled.
7095 if No (Bod_Stmts) then
7096 return New_List (Make_Null_Statement (Loc));
7100 -- Abort : constant Boolean := Triggered_By_Abort;
7102 -- Abort : constant Boolean := False; -- no abort
7104 -- E : Exception_Occurence;
7105 -- Raised : Boolean := False;
7108 -- <finalize statements>
7110 -- if Raised and then not Abort then
7111 -- Raise_From_Controlled_Operation (E);
7116 if Exceptions_OK then
7117 Append_To (Bod_Stmts,
7118 Build_Raise_Statement (Finalizer_Data));
7123 Make_Block_Statement (Loc,
7126 Handled_Statement_Sequence =>
7127 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7129 end Build_Finalize_Statements;
7131 -----------------------
7132 -- Parent_Field_Type --
7133 -----------------------
7135 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
7139 Field := First_Entity (Typ);
7140 while Present (Field) loop
7141 if Chars (Field) = Name_uParent then
7142 return Etype (Field);
7145 Next_Entity (Field);
7148 -- A derived tagged type should always have a parent field
7150 raise Program_Error;
7151 end Parent_Field_Type;
7153 ---------------------------
7154 -- Preprocess_Components --
7155 ---------------------------
7157 procedure Preprocess_Components
7159 Num_Comps : out Int;
7160 Has_POC : out Boolean)
7170 Decl := First_Non_Pragma (Component_Items (Comps));
7171 while Present (Decl) loop
7172 Id := Defining_Identifier (Decl);
7175 -- Skip field _parent
7177 if Chars (Id) /= Name_uParent
7178 and then Needs_Finalization (Typ)
7180 Num_Comps := Num_Comps + 1;
7182 if Has_Access_Constraint (Id)
7183 and then No (Expression (Decl))
7189 Next_Non_Pragma (Decl);
7191 end Preprocess_Components;
7193 -- Start of processing for Make_Deep_Record_Body
7197 when Address_Case =>
7198 return Make_Finalize_Address_Stmts (Typ);
7201 return Build_Adjust_Statements (Typ);
7203 when Finalize_Case =>
7204 return Build_Finalize_Statements (Typ);
7206 when Initialize_Case =>
7208 Loc : constant Source_Ptr := Sloc (Typ);
7211 if Is_Controlled (Typ) then
7213 Make_Procedure_Call_Statement (Loc,
7216 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
7217 Parameter_Associations => New_List (
7218 Make_Identifier (Loc, Name_V))));
7224 end Make_Deep_Record_Body;
7226 ----------------------
7227 -- Make_Final_Call --
7228 ----------------------
7230 function Make_Final_Call
7233 Skip_Self : Boolean := False) return Node_Id
7235 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7237 Fin_Id : Entity_Id := Empty;
7242 -- Recover the proper type which contains [Deep_]Finalize
7244 if Is_Class_Wide_Type (Typ) then
7245 Utyp := Root_Type (Typ);
7249 elsif Is_Concurrent_Type (Typ) then
7250 Utyp := Corresponding_Record_Type (Typ);
7252 Ref := Convert_Concurrent (Obj_Ref, Typ);
7254 elsif Is_Private_Type (Typ)
7255 and then Present (Full_View (Typ))
7256 and then Is_Concurrent_Type (Full_View (Typ))
7258 Utyp := Corresponding_Record_Type (Full_View (Typ));
7260 Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
7268 Utyp := Underlying_Type (Base_Type (Utyp));
7269 Set_Assignment_OK (Ref);
7271 -- Deal with non-tagged derivation of private views. If the parent type
7272 -- is a protected type, Deep_Finalize is found on the corresponding
7273 -- record of the ancestor.
7275 if Is_Untagged_Derivation (Typ) then
7276 if Is_Protected_Type (Typ) then
7277 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7279 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7281 if Is_Protected_Type (Utyp) then
7282 Utyp := Corresponding_Record_Type (Utyp);
7286 Ref := Unchecked_Convert_To (Utyp, Ref);
7287 Set_Assignment_OK (Ref);
7290 -- Deal with derived private types which do not inherit primitives from
7291 -- their parents. In this case, [Deep_]Finalize can be found in the full
7292 -- view of the parent type.
7294 if Is_Tagged_Type (Utyp)
7295 and then Is_Derived_Type (Utyp)
7296 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
7297 and then Is_Private_Type (Etype (Utyp))
7298 and then Present (Full_View (Etype (Utyp)))
7300 Utyp := Full_View (Etype (Utyp));
7301 Ref := Unchecked_Convert_To (Utyp, Ref);
7302 Set_Assignment_OK (Ref);
7305 -- When dealing with the completion of a private type, use the base type
7308 if Utyp /= Base_Type (Utyp) then
7309 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
7311 Utyp := Base_Type (Utyp);
7312 Ref := Unchecked_Convert_To (Utyp, Ref);
7313 Set_Assignment_OK (Ref);
7317 if Has_Controlled_Component (Utyp) then
7318 if Is_Tagged_Type (Utyp) then
7319 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7321 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7325 -- Class-wide types, interfaces and types with controlled components
7327 elsif Is_Class_Wide_Type (Typ)
7328 or else Is_Interface (Typ)
7329 or else Has_Controlled_Component (Utyp)
7331 if Is_Tagged_Type (Utyp) then
7332 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7334 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7337 -- Derivations from [Limited_]Controlled
7339 elsif Is_Controlled (Utyp) then
7340 if Has_Controlled_Component (Utyp) then
7341 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7343 Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
7348 elsif Is_Tagged_Type (Utyp) then
7349 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7352 raise Program_Error;
7355 if Present (Fin_Id) then
7357 -- When finalizing a class-wide object, do not convert to the root
7358 -- type in order to produce a dispatching call.
7360 if Is_Class_Wide_Type (Typ) then
7363 -- Ensure that a finalization routine is at least decorated in order
7364 -- to inspect the object parameter.
7366 elsif Analyzed (Fin_Id)
7367 or else Ekind (Fin_Id) = E_Procedure
7369 -- In certain cases, such as the creation of Stream_Read, the
7370 -- visible entity of the type is its full view. Since Stream_Read
7371 -- will have to create an object of type Typ, the local object
7372 -- will be finalzed by the scope finalizer generated later on. The
7373 -- object parameter of Deep_Finalize will always use the private
7374 -- view of the type. To avoid such a clash between a private and a
7375 -- full view, perform an unchecked conversion of the object
7376 -- reference to the private view.
7379 Formal_Typ : constant Entity_Id :=
7380 Etype (First_Formal (Fin_Id));
7382 if Is_Private_Type (Formal_Typ)
7383 and then Present (Full_View (Formal_Typ))
7384 and then Full_View (Formal_Typ) = Utyp
7386 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
7390 Ref := Convert_View (Fin_Id, Ref);
7396 Param => New_Copy_Tree (Ref),
7397 Skip_Self => Skip_Self);
7401 end Make_Final_Call;
7403 --------------------------------
7404 -- Make_Finalize_Address_Body --
7405 --------------------------------
7407 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
7408 Is_Task : constant Boolean :=
7409 Ekind (Typ) = E_Record_Type
7410 and then Is_Concurrent_Record_Type (Typ)
7411 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
7413 Loc : constant Source_Ptr := Sloc (Typ);
7414 Proc_Id : Entity_Id;
7418 -- The corresponding records of task types are not controlled by design.
7419 -- For the sake of completeness, create an empty Finalize_Address to be
7420 -- used in task class-wide allocations.
7425 -- Nothing to do if the type is not controlled or it already has a
7426 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7427 -- come from source. These are usually generated for completeness and
7428 -- do not need the Finalize_Address primitive.
7430 elsif not Needs_Finalization (Typ)
7431 or else Is_Abstract_Type (Typ)
7432 or else Present (TSS (Typ, TSS_Finalize_Address))
7434 (Is_Class_Wide_Type (Typ)
7435 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
7436 and then not Comes_From_Source (Root_Type (Typ)))
7442 Make_Defining_Identifier (Loc,
7443 Make_TSS_Name (Typ, TSS_Finalize_Address));
7447 -- procedure <Typ>FD (V : System.Address) is
7449 -- null; -- for tasks
7451 -- declare -- for all other types
7452 -- type Pnn is access all Typ;
7453 -- for Pnn'Storage_Size use 0;
7455 -- [Deep_]Finalize (Pnn (V).all);
7460 Stmts := New_List (Make_Null_Statement (Loc));
7462 Stmts := Make_Finalize_Address_Stmts (Typ);
7466 Make_Subprogram_Body (Loc,
7468 Make_Procedure_Specification (Loc,
7469 Defining_Unit_Name => Proc_Id,
7471 Parameter_Specifications => New_List (
7472 Make_Parameter_Specification (Loc,
7473 Defining_Identifier =>
7474 Make_Defining_Identifier (Loc, Name_V),
7476 New_Occurrence_Of (RTE (RE_Address), Loc)))),
7478 Declarations => No_List,
7480 Handled_Statement_Sequence =>
7481 Make_Handled_Sequence_Of_Statements (Loc,
7482 Statements => Stmts)));
7484 Set_TSS (Typ, Proc_Id);
7485 end Make_Finalize_Address_Body;
7487 ---------------------------------
7488 -- Make_Finalize_Address_Stmts --
7489 ---------------------------------
7491 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
7492 Loc : constant Source_Ptr := Sloc (Typ);
7493 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
7495 Desg_Typ : Entity_Id;
7499 if Is_Array_Type (Typ) then
7500 if Is_Constrained (First_Subtype (Typ)) then
7501 Desg_Typ := First_Subtype (Typ);
7503 Desg_Typ := Base_Type (Typ);
7506 -- Class-wide types of constrained root types
7508 elsif Is_Class_Wide_Type (Typ)
7509 and then Has_Discriminants (Root_Type (Typ))
7511 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
7514 Parent_Typ : Entity_Id;
7517 -- Climb the parent type chain looking for a non-constrained type
7519 Parent_Typ := Root_Type (Typ);
7520 while Parent_Typ /= Etype (Parent_Typ)
7521 and then Has_Discriminants (Parent_Typ)
7523 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
7525 Parent_Typ := Etype (Parent_Typ);
7528 -- Handle views created for tagged types with unknown
7531 if Is_Underlying_Record_View (Parent_Typ) then
7532 Parent_Typ := Underlying_Record_View (Parent_Typ);
7535 Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
7545 -- type Ptr_Typ is access all Typ;
7546 -- for Ptr_Typ'Storage_Size use 0;
7549 Make_Full_Type_Declaration (Loc,
7550 Defining_Identifier => Ptr_Typ,
7552 Make_Access_To_Object_Definition (Loc,
7553 All_Present => True,
7554 Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))),
7556 Make_Attribute_Definition_Clause (Loc,
7557 Name => New_Occurrence_Of (Ptr_Typ, Loc),
7558 Chars => Name_Storage_Size,
7559 Expression => Make_Integer_Literal (Loc, 0)));
7561 Obj_Expr := Make_Identifier (Loc, Name_V);
7563 -- Unconstrained arrays require special processing in order to retrieve
7564 -- the elements. To achieve this, we have to skip the dope vector which
7565 -- lays in front of the elements and then use a thin pointer to perform
7566 -- the address-to-access conversion.
7568 if Is_Array_Type (Typ)
7569 and then not Is_Constrained (First_Subtype (Typ))
7572 Dope_Id : Entity_Id;
7575 -- Ensure that Ptr_Typ a thin pointer, generate:
7576 -- for Ptr_Typ'Size use System.Address'Size;
7579 Make_Attribute_Definition_Clause (Loc,
7580 Name => New_Occurrence_Of (Ptr_Typ, Loc),
7583 Make_Integer_Literal (Loc, System_Address_Size)));
7586 -- Dnn : constant Storage_Offset :=
7587 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7589 Dope_Id := Make_Temporary (Loc, 'D');
7592 Make_Object_Declaration (Loc,
7593 Defining_Identifier => Dope_Id,
7594 Constant_Present => True,
7595 Object_Definition =>
7596 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
7598 Make_Op_Divide (Loc,
7600 Make_Attribute_Reference (Loc,
7601 Prefix => New_Occurrence_Of (Desg_Typ, Loc),
7602 Attribute_Name => Name_Descriptor_Size),
7604 Make_Integer_Literal (Loc, System_Storage_Unit))));
7606 -- Shift the address from the start of the dope vector to the
7607 -- start of the elements:
7611 -- Note that this is done through a wrapper routine since RTSfind
7612 -- cannot retrieve operations with string names of the form "+".
7615 Make_Function_Call (Loc,
7617 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
7618 Parameter_Associations => New_List (
7620 New_Occurrence_Of (Dope_Id, Loc)));
7624 -- Create the block and the finalization call
7627 Make_Block_Statement (Loc,
7628 Declarations => Decls,
7630 Handled_Statement_Sequence =>
7631 Make_Handled_Sequence_Of_Statements (Loc,
7632 Statements => New_List (
7635 Make_Explicit_Dereference (Loc,
7636 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
7637 Typ => Desg_Typ)))));
7638 end Make_Finalize_Address_Stmts;
7640 -------------------------------------
7641 -- Make_Handler_For_Ctrl_Operation --
7642 -------------------------------------
7646 -- when E : others =>
7647 -- Raise_From_Controlled_Operation (E);
7652 -- raise Program_Error [finalize raised exception];
7654 -- depending on whether Raise_From_Controlled_Operation is available
7656 function Make_Handler_For_Ctrl_Operation
7657 (Loc : Source_Ptr) return Node_Id
7660 -- Choice parameter (for the first case above)
7662 Raise_Node : Node_Id;
7663 -- Procedure call or raise statement
7666 -- Standard run-time, .NET/JVM targets: add choice parameter E and pass
7667 -- it to Raise_From_Controlled_Operation so that the original exception
7668 -- name and message can be recorded in the exception message for
7671 if RTE_Available (RE_Raise_From_Controlled_Operation) then
7672 E_Occ := Make_Defining_Identifier (Loc, Name_E);
7674 Make_Procedure_Call_Statement (Loc,
7677 (RTE (RE_Raise_From_Controlled_Operation), Loc),
7678 Parameter_Associations => New_List (
7679 New_Occurrence_Of (E_Occ, Loc)));
7681 -- Restricted run-time: exception messages are not supported
7686 Make_Raise_Program_Error (Loc,
7687 Reason => PE_Finalize_Raised_Exception);
7691 Make_Implicit_Exception_Handler (Loc,
7692 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7693 Choice_Parameter => E_Occ,
7694 Statements => New_List (Raise_Node));
7695 end Make_Handler_For_Ctrl_Operation;
7697 --------------------
7698 -- Make_Init_Call --
7699 --------------------
7701 function Make_Init_Call
7703 Typ : Entity_Id) return Node_Id
7705 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7712 -- Deal with the type and object reference. Depending on the context, an
7713 -- object reference may need several conversions.
7715 if Is_Concurrent_Type (Typ) then
7717 Utyp := Corresponding_Record_Type (Typ);
7718 Ref := Convert_Concurrent (Obj_Ref, Typ);
7720 elsif Is_Private_Type (Typ)
7721 and then Present (Full_View (Typ))
7722 and then Is_Concurrent_Type (Underlying_Type (Typ))
7725 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
7726 Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
7734 Set_Assignment_OK (Ref);
7736 Utyp := Underlying_Type (Base_Type (Utyp));
7738 -- Deal with non-tagged derivation of private views
7740 if Is_Untagged_Derivation (Typ)
7741 and then not Is_Conc
7743 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7744 Ref := Unchecked_Convert_To (Utyp, Ref);
7746 -- The following is to prevent problems with UC see 1.156 RH ???
7748 Set_Assignment_OK (Ref);
7751 -- If the underlying_type is a subtype, then we are dealing with the
7752 -- completion of a private type. We need to access the base type and
7753 -- generate a conversion to it.
7755 if Utyp /= Base_Type (Utyp) then
7756 pragma Assert (Is_Private_Type (Typ));
7757 Utyp := Base_Type (Utyp);
7758 Ref := Unchecked_Convert_To (Utyp, Ref);
7761 -- Select the appropriate version of initialize
7763 if Has_Controlled_Component (Utyp) then
7764 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
7766 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
7767 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
7770 -- The object reference may need another conversion depending on the
7771 -- type of the formal and that of the actual.
7773 Ref := Convert_View (Proc, Ref);
7776 -- [Deep_]Initialize (Ref);
7779 Make_Procedure_Call_Statement (Loc,
7781 New_Occurrence_Of (Proc, Loc),
7782 Parameter_Associations => New_List (Ref));
7785 ------------------------------
7786 -- Make_Local_Deep_Finalize --
7787 ------------------------------
7789 function Make_Local_Deep_Finalize
7791 Nam : Entity_Id) return Node_Id
7793 Loc : constant Source_Ptr := Sloc (Typ);
7797 Formals := New_List (
7801 Make_Parameter_Specification (Loc,
7802 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7804 Out_Present => True,
7805 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
7807 -- F : Boolean := True
7809 Make_Parameter_Specification (Loc,
7810 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7811 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
7812 Expression => New_Occurrence_Of (Standard_True, Loc)));
7814 -- Add the necessary number of counters to represent the initialization
7815 -- state of an object.
7818 Make_Subprogram_Body (Loc,
7820 Make_Procedure_Specification (Loc,
7821 Defining_Unit_Name => Nam,
7822 Parameter_Specifications => Formals),
7824 Declarations => No_List,
7826 Handled_Statement_Sequence =>
7827 Make_Handled_Sequence_Of_Statements (Loc,
7828 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
7829 end Make_Local_Deep_Finalize;
7831 ------------------------------------
7832 -- Make_Set_Finalize_Address_Call --
7833 ------------------------------------
7835 function Make_Set_Finalize_Address_Call
7838 Ptr_Typ : Entity_Id) return Node_Id
7840 Desig_Typ : constant Entity_Id :=
7841 Available_View (Designated_Type (Ptr_Typ));
7842 Fin_Mas_Id : constant Entity_Id := Finalization_Master (Ptr_Typ);
7843 Fin_Mas_Ref : Node_Id;
7847 -- If the context is a class-wide allocator, we use the class-wide type
7848 -- to obtain the proper Finalize_Address routine.
7850 if Is_Class_Wide_Type (Desig_Typ) then
7856 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
7857 Utyp := Full_View (Utyp);
7860 if Is_Concurrent_Type (Utyp) then
7861 Utyp := Corresponding_Record_Type (Utyp);
7865 Utyp := Underlying_Type (Base_Type (Utyp));
7867 -- Deal with non-tagged derivation of private views. If the parent is
7868 -- now known to be protected, the finalization routine is the one
7869 -- defined on the corresponding record of the ancestor (corresponding
7870 -- records do not automatically inherit operations, but maybe they
7873 if Is_Untagged_Derivation (Typ) then
7874 if Is_Protected_Type (Typ) then
7875 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7877 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7879 if Is_Protected_Type (Utyp) then
7880 Utyp := Corresponding_Record_Type (Utyp);
7885 -- If the underlying_type is a subtype, we are dealing with the
7886 -- completion of a private type. We need to access the base type and
7887 -- generate a conversion to it.
7889 if Utyp /= Base_Type (Utyp) then
7890 pragma Assert (Is_Private_Type (Typ));
7892 Utyp := Base_Type (Utyp);
7895 Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);
7897 -- If the call is from a build-in-place function, the Master parameter
7898 -- is actually a pointer. Dereference it for the call.
7900 if Is_Access_Type (Etype (Fin_Mas_Id)) then
7901 Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
7905 -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7908 Make_Procedure_Call_Statement (Loc,
7910 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
7911 Parameter_Associations => New_List (
7913 Make_Attribute_Reference (Loc,
7915 New_Occurrence_Of (TSS (Utyp, TSS_Finalize_Address), Loc),
7916 Attribute_Name => Name_Unrestricted_Access)));
7917 end Make_Set_Finalize_Address_Call;
7919 --------------------------
7920 -- Make_Transient_Block --
7921 --------------------------
7923 function Make_Transient_Block
7926 Par : Node_Id) return Node_Id
7928 Decls : constant List_Id := New_List;
7929 Instrs : constant List_Id := New_List (Action);
7934 -- Case where only secondary stack use is involved
7936 if VM_Target = No_VM
7937 and then Uses_Sec_Stack (Current_Scope)
7938 and then Nkind (Action) /= N_Simple_Return_Statement
7939 and then Nkind (Par) /= N_Exception_Handler
7945 S := Scope (Current_Scope);
7947 -- At the outer level, no need to release the sec stack
7949 if S = Standard_Standard then
7950 Set_Uses_Sec_Stack (Current_Scope, False);
7953 -- In a function, only release the sec stack if the function
7954 -- does not return on the sec stack otherwise the result may
7955 -- be lost. The caller is responsible for releasing.
7957 elsif Ekind (S) = E_Function then
7958 Set_Uses_Sec_Stack (Current_Scope, False);
7960 if not Requires_Transient_Scope (Etype (S)) then
7961 Set_Uses_Sec_Stack (S, True);
7962 Check_Restriction (No_Secondary_Stack, Action);
7967 -- In a loop or entry we should install a block encompassing
7968 -- all the construct. For now just release right away.
7970 elsif Ekind_In (S, E_Entry, E_Loop) then
7973 -- In a procedure or a block, we release on exit of the
7974 -- procedure or block. ??? memory leak can be created by
7977 elsif Ekind_In (S, E_Block, E_Procedure) then
7978 Set_Uses_Sec_Stack (S, True);
7979 Check_Restriction (No_Secondary_Stack, Action);
7980 Set_Uses_Sec_Stack (Current_Scope, False);
7990 -- Create the transient block. Set the parent now since the block itself
7991 -- is not part of the tree. The current scope is the E_Block entity
7992 -- that has been pushed by Establish_Transient_Scope.
7994 pragma Assert (Ekind (Current_Scope) = E_Block);
7996 Make_Block_Statement (Loc,
7997 Identifier => New_Occurrence_Of (Current_Scope, Loc),
7998 Declarations => Decls,
7999 Handled_Statement_Sequence =>
8000 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
8001 Has_Created_Identifier => True);
8002 Set_Parent (Block, Par);
8004 -- Insert actions stuck in the transient scopes as well as all freezing
8005 -- nodes needed by those actions.
8007 Insert_Actions_In_Scope_Around (Action);
8009 Insert := Prev (Action);
8010 if Present (Insert) then
8011 Freeze_All (First_Entity (Current_Scope), Insert);
8014 -- Transfer cleanup actions to the newly created block
8017 Cleanup_Actions : List_Id
8018 renames Scope_Stack.Table (Scope_Stack.Last).
8019 Actions_To_Be_Wrapped (Cleanup);
8021 Set_Cleanup_Actions (Block, Cleanup_Actions);
8022 Cleanup_Actions := No_List;
8025 -- When the transient scope was established, we pushed the entry for the
8026 -- transient scope onto the scope stack, so that the scope was active
8027 -- for the installation of finalizable entities etc. Now we must remove
8028 -- this entry, since we have constructed a proper block.
8033 end Make_Transient_Block;
8035 ------------------------
8036 -- Node_To_Be_Wrapped --
8037 ------------------------
8039 function Node_To_Be_Wrapped return Node_Id is
8041 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
8042 end Node_To_Be_Wrapped;
8044 ----------------------------
8045 -- Set_Node_To_Be_Wrapped --
8046 ----------------------------
8048 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
8050 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
8051 end Set_Node_To_Be_Wrapped;
8053 ----------------------------
8054 -- Store_Actions_In_Scope --
8055 ----------------------------
8057 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
8058 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
8059 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
8062 if No (Actions) then
8065 if Is_List_Member (SE.Node_To_Be_Wrapped) then
8066 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
8068 Set_Parent (L, SE.Node_To_Be_Wrapped);
8073 elsif AK = Before then
8074 Insert_List_After_And_Analyze (Last (Actions), L);
8077 Insert_List_Before_And_Analyze (First (Actions), L);
8079 end Store_Actions_In_Scope;
8081 ----------------------------------
8082 -- Store_After_Actions_In_Scope --
8083 ----------------------------------
8085 procedure Store_After_Actions_In_Scope (L : List_Id) is
8087 Store_Actions_In_Scope (After, L);
8088 end Store_After_Actions_In_Scope;
8090 -----------------------------------
8091 -- Store_Before_Actions_In_Scope --
8092 -----------------------------------
8094 procedure Store_Before_Actions_In_Scope (L : List_Id) is
8096 Store_Actions_In_Scope (Before, L);
8097 end Store_Before_Actions_In_Scope;
8099 -----------------------------------
8100 -- Store_Cleanup_Actions_In_Scope --
8101 -----------------------------------
8103 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
8105 Store_Actions_In_Scope (Cleanup, L);
8106 end Store_Cleanup_Actions_In_Scope;
8108 --------------------------------
8109 -- Wrap_Transient_Declaration --
8110 --------------------------------
8112 -- If a transient scope has been established during the processing of the
8113 -- Expression of an Object_Declaration, it is not possible to wrap the
8114 -- declaration into a transient block as usual case, otherwise the object
8115 -- would be itself declared in the wrong scope. Therefore, all entities (if
8116 -- any) defined in the transient block are moved to the proper enclosing
8117 -- scope, furthermore, if they are controlled variables they are finalized
8118 -- right after the declaration. The finalization list of the transient
8119 -- scope is defined as a renaming of the enclosing one so during their
8120 -- initialization they will be attached to the proper finalization list.
8121 -- For instance, the following declaration :
8123 -- X : Typ := F (G (A), G (B));
8125 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8126 -- is expanded into :
8128 -- X : Typ := [ complex Expression-Action ];
8129 -- [Deep_]Finalize (_v1);
8130 -- [Deep_]Finalize (_v2);
8132 procedure Wrap_Transient_Declaration (N : Node_Id) is
8139 Encl_S := Scope (S);
8141 -- Insert Actions kept in the Scope stack
8143 Insert_Actions_In_Scope_Around (N);
8145 -- If the declaration is consuming some secondary stack, mark the
8146 -- enclosing scope appropriately.
8148 Uses_SS := Uses_Sec_Stack (S);
8151 -- Put the local entities back in the enclosing scope, and set the
8152 -- Is_Public flag appropriately.
8154 Transfer_Entities (S, Encl_S);
8156 -- Mark the enclosing dynamic scope so that the sec stack will be
8157 -- released upon its exit unless this is a function that returns on
8158 -- the sec stack in which case this will be done by the caller.
8160 if VM_Target = No_VM and then Uses_SS then
8161 S := Enclosing_Dynamic_Scope (S);
8163 if Ekind (S) = E_Function
8164 and then Requires_Transient_Scope (Etype (S))
8168 Set_Uses_Sec_Stack (S);
8169 Check_Restriction (No_Secondary_Stack, N);
8172 end Wrap_Transient_Declaration;
8174 -------------------------------
8175 -- Wrap_Transient_Expression --
8176 -------------------------------
8178 procedure Wrap_Transient_Expression (N : Node_Id) is
8179 Loc : constant Source_Ptr := Sloc (N);
8180 Expr : Node_Id := Relocate_Node (N);
8181 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
8182 Typ : constant Entity_Id := Etype (N);
8189 -- M : constant Mark_Id := SS_Mark;
8190 -- procedure Finalizer is ... (See Build_Finalizer)
8193 -- Temp := <Expr>; -- general case
8194 -- Temp := (if <Expr> then True else False); -- boolean case
8200 -- A special case is made for Boolean expressions so that the back-end
8201 -- knows to generate a conditional branch instruction, if running with
8202 -- -fpreserve-control-flow. This ensures that a control flow change
8203 -- signalling the decision outcome occurs before the cleanup actions.
8205 if Opt.Suppress_Control_Flow_Optimizations
8206 and then Is_Boolean_Type (Typ)
8209 Make_If_Expression (Loc,
8210 Expressions => New_List (
8212 New_Occurrence_Of (Standard_True, Loc),
8213 New_Occurrence_Of (Standard_False, Loc)));
8216 Insert_Actions (N, New_List (
8217 Make_Object_Declaration (Loc,
8218 Defining_Identifier => Temp,
8219 Object_Definition => New_Occurrence_Of (Typ, Loc)),
8221 Make_Transient_Block (Loc,
8223 Make_Assignment_Statement (Loc,
8224 Name => New_Occurrence_Of (Temp, Loc),
8225 Expression => Expr),
8226 Par => Parent (N))));
8228 Rewrite (N, New_Occurrence_Of (Temp, Loc));
8229 Analyze_And_Resolve (N, Typ);
8230 end Wrap_Transient_Expression;
8232 ------------------------------
8233 -- Wrap_Transient_Statement --
8234 ------------------------------
8236 procedure Wrap_Transient_Statement (N : Node_Id) is
8237 Loc : constant Source_Ptr := Sloc (N);
8238 New_Stmt : constant Node_Id := Relocate_Node (N);
8243 -- M : constant Mark_Id := SS_Mark;
8244 -- procedure Finalizer is ... (See Build_Finalizer)
8254 Make_Transient_Block (Loc,
8256 Par => Parent (N)));
8258 -- With the scope stack back to normal, we can call analyze on the
8259 -- resulting block. At this point, the transient scope is being
8260 -- treated like a perfectly normal scope, so there is nothing
8261 -- special about it.
8263 -- Note: Wrap_Transient_Statement is called with the node already
8264 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8265 -- otherwise we would get a recursive processing of the node when
8266 -- we do this Analyze call.
8269 end Wrap_Transient_Statement;