1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree; use Atree;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Dbug; use Exp_Dbug;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Disp; use Exp_Disp;
41 with Exp_Tss; use Exp_Tss;
42 with Exp_Util; use Exp_Util;
43 with Freeze; use Freeze;
45 with Nlists; use Nlists;
46 with Nmake; use Nmake;
48 with Output; use Output;
49 with Restrict; use Restrict;
50 with Rident; use Rident;
51 with Rtsfind; use Rtsfind;
52 with Sinfo; use Sinfo;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Ch3; use Sem_Ch3;
56 with Sem_Ch7; use Sem_Ch7;
57 with Sem_Ch8; use Sem_Ch8;
58 with Sem_Res; use Sem_Res;
59 with Sem_Util; use Sem_Util;
60 with Snames; use Snames;
61 with Stand; use Stand;
62 with Targparm; use Targparm;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Uintp; use Uintp;
67 package body Exp_Ch7 is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In
84 -- this case the instruction is wrapped into a transient block.
85 -- (See 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, ...).
89 -- (See Wrap_Transient_Expression for details)
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope (see Wrap_Transient_Declaration for details)
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
129 -- N is a node which may generate a transient scope. Loop over the parent
130 -- pointers of N until it find the appropriate node to wrap. If it returns
131 -- Empty, it means that no transient scope is needed in this context.
133 procedure Insert_Actions_In_Scope_Around (N : Node_Id);
134 -- Insert the before-actions kept in the scope stack before N, and the
135 -- after-actions after N, which must be a member of a list.
137 function Make_Transient_Block
140 Par : Node_Id) return Node_Id;
141 -- Action is a single statement or object declaration. Par is the proper
142 -- parent of the generated block. Create a transient block whose name is
143 -- the current scope and the only handled statement is Action. If Action
144 -- involves controlled objects or secondary stack usage, the corresponding
145 -- cleanup actions are performed at the end of the block.
147 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
148 -- Set the field Node_To_Be_Wrapped of the current scope
150 -- ??? The entire comment needs to be rewritten
152 -----------------------------
153 -- Finalization Management --
154 -----------------------------
156 -- This part describe how Initialization/Adjustment/Finalization procedures
157 -- are generated and called. Two cases must be considered, types that are
158 -- Controlled (Is_Controlled flag set) and composite types that contain
159 -- controlled components (Has_Controlled_Component flag set). In the first
160 -- case the procedures to call are the user-defined primitive operations
161 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
162 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
163 -- of calling the former procedures on the controlled components.
165 -- For records with Has_Controlled_Component set, a hidden "controller"
166 -- component is inserted. This controller component contains its own
167 -- finalization list on which all controlled components are attached
168 -- creating an indirection on the upper-level Finalization list. This
169 -- technique facilitates the management of objects whose number of
170 -- controlled components changes during execution. This controller
171 -- component is itself controlled and is attached to the upper-level
172 -- finalization chain. Its adjust primitive is in charge of calling adjust
173 -- on the components and adjusting the finalization pointer to match their
174 -- new location (see a-finali.adb).
176 -- It is not possible to use a similar technique for arrays that have
177 -- Has_Controlled_Component set. In this case, deep procedures are
178 -- generated that call initialize/adjust/finalize + attachment or
179 -- detachment on the finalization list for all component.
181 -- Initialize calls: they are generated for declarations or dynamic
182 -- allocations of Controlled objects with no initial value. They are always
183 -- followed by an attachment to the current Finalization Chain. For the
184 -- dynamic allocation case this the chain attached to the scope of the
185 -- access type definition otherwise, this is the chain of the current
188 -- Adjust Calls: They are generated on 2 occasions: (1) for
189 -- declarations or dynamic allocations of Controlled objects with an
190 -- initial value. (2) after an assignment. In the first case they are
191 -- followed by an attachment to the final chain, in the second case
194 -- Finalization Calls: They are generated on (1) scope exit, (2)
195 -- assignments, (3) unchecked deallocations. In case (3) they have to
196 -- be detached from the final chain, in case (2) they must not and in
197 -- case (1) this is not important since we are exiting the scope anyway.
201 -- Type extensions will have a new record controller at each derivation
202 -- level containing controlled components. The record controller for
203 -- the parent/ancestor is attached to the finalization list of the
204 -- extension's record controller (i.e. the parent is like a component
205 -- of the extension).
207 -- For types that are both Is_Controlled and Has_Controlled_Components,
208 -- the record controller and the object itself are handled separately.
209 -- It could seem simpler to attach the object at the end of its record
210 -- controller but this would not tackle view conversions properly.
212 -- A classwide type can always potentially have controlled components
213 -- but the record controller of the corresponding actual type may not
214 -- be known at compile time so the dispatch table contains a special
215 -- field that allows to compute the offset of the record controller
216 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
218 -- Here is a simple example of the expansion of a controlled block :
222 -- Y : Controlled := Init;
228 -- Z : R := (C => X);
237 -- _L : System.FI.Finalizable_Ptr;
239 -- procedure _Clean is
242 -- System.FI.Finalize_List (_L);
250 -- Attach_To_Final_List (_L, Finalizable (X), 1);
251 -- at end: Abort_Undefer;
252 -- Y : Controlled := Init;
254 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
262 -- Deep_Initialize (W, _L, 1);
263 -- at end: Abort_Under;
264 -- Z : R := (C => X);
265 -- Deep_Adjust (Z, _L, 1);
269 -- Deep_Finalize (W, False);
270 -- <save W's final pointers>
272 -- <restore W's final pointers>
273 -- Deep_Adjust (W, _L, 0);
278 type Final_Primitives is
279 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
280 -- This enumeration type is defined in order to ease sharing code for
281 -- building finalization procedures for composite types.
283 Name_Of : constant array (Final_Primitives) of Name_Id :=
284 (Initialize_Case => Name_Initialize,
285 Adjust_Case => Name_Adjust,
286 Finalize_Case => Name_Finalize,
287 Address_Case => Name_Finalize_Address);
288 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
289 (Initialize_Case => TSS_Deep_Initialize,
290 Adjust_Case => TSS_Deep_Adjust,
291 Finalize_Case => TSS_Deep_Finalize,
292 Address_Case => TSS_Finalize_Address);
294 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
295 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
296 -- Has_Controlled_Component set and store them using the TSS mechanism.
298 function Build_Cleanup_Statements (N : Node_Id) return List_Id;
299 -- Create the clean up calls for an asynchronous call block, task master,
300 -- protected subprogram body, task allocation block or task body. Generate
301 -- code to unregister the external tags of all library-level tagged types
302 -- found in the declarations and/or statements of N. If the context does
303 -- not contain the above constructs or types, the routine returns an empty
306 function Build_Exception_Handler
309 Raised_Id : Entity_Id;
310 For_Library : Boolean := False) return Node_Id;
311 -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record
312 -- _Body. Create an exception handler of the following form:
315 -- if not Raised_Id then
316 -- Raised_Id := True;
317 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
320 -- If flag For_Library is set (and not in restricted profile):
323 -- if not Raised_Id then
324 -- Raised_Id := True;
325 -- Save_Library_Occurrence (Get_Current_Excep.all.all);
328 -- E_Id denotes the defining identifier of a local exception occurrence.
329 -- Raised_Id is the entity of a local boolean flag. Flag For_Library is
330 -- used when operating at the library level, when enabled the current
331 -- exception will be saved to a global location.
333 procedure Build_Finalizer
335 Clean_Stmts : List_Id;
338 Defer_Abort : Boolean;
339 Fin_Id : out Entity_Id);
340 -- N may denote an accept statement, block, entry body, package body,
341 -- package spec, protected body, subprogram body, and a task body. Create
342 -- a procedure which contains finalization calls for all controlled objects
343 -- declared in the declarative or statement region of N. The calls are
344 -- built in reverse order relative to the original declarations. In the
345 -- case of a tack body, the routine delays the creation of the finalizer
346 -- until all statements have been moved to the task body procedure.
347 -- Clean_Stmts may contain additional context-dependent code used to abort
348 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
349 -- Mark_Id is the secondary stack used in the current context or Empty if
350 -- missing. Top_Decls is the list on which the declaration of the finalizer
351 -- is attached in the non-package case. Defer_Abort indicates that the
352 -- statements passed in perform actions that require abort to be deferred,
353 -- such as for task termination. Fin_Id is the finalizer declaration
356 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
357 -- N is a construct which contains a handled sequence of statements, Fin_Id
358 -- is the entity of a finalizer. Create an At_End handler which covers the
359 -- statements of N and calls Fin_Id. If the handled statement sequence has
360 -- an exception handler, the statements will be wrapped in a block to avoid
361 -- unwanted interaction with the new At_End handler.
363 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
364 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
365 -- Has_Component_Component set and store them using the TSS mechanism.
367 procedure Check_Visibly_Controlled
368 (Prim : Final_Primitives;
370 E : in out Entity_Id;
371 Cref : in out Node_Id);
372 -- The controlled operation declared for a derived type may not be
373 -- overriding, if the controlled operations of the parent type are hidden,
374 -- for example when the parent is a private type whose full view is
375 -- controlled. For other primitive operations we modify the name of the
376 -- operation to indicate that it is not overriding, but this is not
377 -- possible for Initialize, etc. because they have to be retrievable by
378 -- name. Before generating the proper call to one of these operations we
379 -- check whether Typ is known to be controlled at the point of definition.
380 -- If it is not then we must retrieve the hidden operation of the parent
381 -- and use it instead. This is one case that might be solved more cleanly
382 -- once Overriding pragmas or declarations are in place.
384 function Convert_View
387 Ind : Pos := 1) return Node_Id;
388 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
389 -- argument being passed to it. Ind indicates which formal of procedure
390 -- Proc we are trying to match. This function will, if necessary, generate
391 -- a conversion between the partial and full view of Arg to match the type
392 -- of the formal of Proc, or force a conversion to the class-wide type in
393 -- the case where the operation is abstract.
395 function Enclosing_Function (E : Entity_Id) return Entity_Id;
396 -- Given an arbitrary entity, traverse the scope chain looking for the
397 -- first enclosing function. Return Empty if no function was found.
403 For_Parent : Boolean := False) return Node_Id;
404 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
405 -- routine [Deep_]Adjust / Finalize and an object parameter, create an
406 -- adjust / finalization call. Flag For_Parent should be set when field
407 -- _parent is being processed.
409 function Make_Deep_Proc
410 (Prim : Final_Primitives;
412 Stmts : List_Id) return Node_Id;
413 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
414 -- Deep_Finalize procedures according to the first parameter, these
415 -- procedures operate on the type Typ. The Stmts parameter gives the body
418 function Make_Deep_Array_Body
419 (Prim : Final_Primitives;
420 Typ : Entity_Id) return List_Id;
421 -- This function generates the list of statements for implementing
422 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
423 -- the first parameter, these procedures operate on the array type Typ.
425 function Make_Deep_Record_Body
426 (Prim : Final_Primitives;
428 Is_Local : Boolean := False) return List_Id;
429 -- This function generates the list of statements for implementing
430 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
431 -- the first parameter, these procedures operate on the record type Typ.
432 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
433 -- whether the inner logic should be dictated by state counters.
435 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
436 -- Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body.
437 -- Generate the following statements:
440 -- type Acc_Typ is access all Typ;
441 -- for Acc_Typ'Storage_Size use 0;
443 -- [Deep_]Finalize (Acc_Typ (V).all);
446 ----------------------------
447 -- Build_Array_Deep_Procs --
448 ----------------------------
450 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
454 (Prim => Initialize_Case,
456 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
458 if not Is_Immutably_Limited_Type (Typ) then
461 (Prim => Adjust_Case,
463 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
468 (Prim => Finalize_Case,
470 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
472 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
473 -- .NET do not support address arithmetic and unchecked conversions.
475 if VM_Target = No_VM then
478 (Prim => Address_Case,
480 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
482 end Build_Array_Deep_Procs;
484 ------------------------------
485 -- Build_Cleanup_Statements --
486 ------------------------------
488 function Build_Cleanup_Statements (N : Node_Id) return List_Id is
489 Is_Asynchronous_Call : constant Boolean :=
490 Nkind (N) = N_Block_Statement
491 and then Is_Asynchronous_Call_Block (N);
493 Is_Master : constant Boolean :=
494 not Nkind_In (N, N_Entry_Body,
496 N_Package_Declaration)
497 and then Is_Task_Master (N);
498 Is_Protected_Body : constant Boolean :=
499 Nkind (N) = N_Subprogram_Body
500 and then Is_Protected_Subprogram_Body (N);
501 Is_Task_Allocation : constant Boolean :=
502 Nkind (N) = N_Block_Statement
503 and then Is_Task_Allocation_Block (N);
504 Is_Task_Body : constant Boolean :=
505 Nkind (Original_Node (N)) = N_Task_Body;
507 Loc : constant Source_Ptr := Sloc (N);
508 Stmts : constant List_Id := New_List;
510 procedure Unregister_Tagged_Types (Decls : List_Id);
511 -- Unregister the external tag of each tagged type found in the list
512 -- Decls. The generated statements are added to list Stmts.
514 -----------------------------
515 -- Unregister_Tagged_Types --
516 -----------------------------
518 procedure Unregister_Tagged_Types (Decls : List_Id) is
524 if No (Decls) or else Is_Empty_List (Decls) then
528 -- Process all declarations or statements in reverse order
530 Decl := Last_Non_Pragma (Decls);
531 while Present (Decl) loop
532 if Nkind (Decl) = N_Full_Type_Declaration then
533 Typ := Defining_Identifier (Decl);
535 if Is_Tagged_Type (Typ)
536 and then Is_Library_Level_Entity (Typ)
537 and then Convention (Typ) = Convention_Ada
538 and then Present (Access_Disp_Table (Typ))
539 and then RTE_Available (RE_Unregister_Tag)
540 and then not No_Run_Time_Mode
541 and then not Is_Abstract_Type (Typ)
543 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
546 -- Ada.Tags.Unregister_Tag (<Typ>P);
549 Make_Procedure_Call_Statement (Loc,
551 New_Reference_To (RTE (RE_Unregister_Tag), Loc),
552 Parameter_Associations => New_List (
553 New_Reference_To (DT_Ptr, Loc))));
557 Prev_Non_Pragma (Decl);
559 end Unregister_Tagged_Types;
561 -- Start of processing for Build_Cleanup_Statements
565 if Restricted_Profile then
567 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
569 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
573 if Restriction_Active (No_Task_Hierarchy) = False then
574 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
577 -- Add statements to unlock the protected object parameter and to
578 -- undefer abort. If the context is a protected procedure and the object
579 -- has entries, call the entry service routine.
581 -- NOTE: The generated code references _object, a parameter to the
584 elsif Is_Protected_Body then
586 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
587 Conc_Typ : Entity_Id;
590 Param_Typ : Entity_Id;
593 -- Find the _object parameter representing the protected object
595 Param := First (Parameter_Specifications (Spec));
597 Param_Typ := Etype (Parameter_Type (Param));
599 if Ekind (Param_Typ) = E_Record_Type then
600 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
603 exit when No (Param) or else Present (Conc_Typ);
607 pragma Assert (Present (Param));
609 -- If the associated protected object has entries, a protected
610 -- procedure has to service entry queues. In this case generate:
612 -- Service_Entries (_object._object'Access);
614 if Nkind (Specification (N)) = N_Procedure_Specification
615 and then Has_Entries (Conc_Typ)
617 case Corresponding_Runtime_Package (Conc_Typ) is
618 when System_Tasking_Protected_Objects_Entries =>
619 Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
621 when System_Tasking_Protected_Objects_Single_Entry =>
622 Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
629 Make_Procedure_Call_Statement (Loc,
631 Parameter_Associations => New_List (
632 Make_Attribute_Reference (Loc,
634 Make_Selected_Component (Loc,
635 Prefix => New_Reference_To (
636 Defining_Identifier (Param), Loc),
638 Make_Identifier (Loc, Name_uObject)),
639 Attribute_Name => Name_Unchecked_Access))));
643 -- Unlock (_object._object'Access);
645 case Corresponding_Runtime_Package (Conc_Typ) is
646 when System_Tasking_Protected_Objects_Entries =>
647 Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
649 when System_Tasking_Protected_Objects_Single_Entry =>
650 Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
652 when System_Tasking_Protected_Objects =>
653 Nam := New_Reference_To (RTE (RE_Unlock), Loc);
660 Make_Procedure_Call_Statement (Loc,
662 Parameter_Associations => New_List (
663 Make_Attribute_Reference (Loc,
665 Make_Selected_Component (Loc,
668 (Defining_Identifier (Param), Loc),
670 Make_Identifier (Loc, Name_uObject)),
671 Attribute_Name => Name_Unchecked_Access))));
677 if Abort_Allowed then
679 Make_Procedure_Call_Statement (Loc,
681 New_Reference_To (RTE (RE_Abort_Undefer), Loc),
682 Parameter_Associations => Empty_List));
686 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
687 -- tasks. Other unactivated tasks are completed by Complete_Task or
690 -- NOTE: The generated code references _chain, a local object
692 elsif Is_Task_Allocation then
695 -- Expunge_Unactivated_Tasks (_chain);
697 -- where _chain is the list of tasks created by the allocator but not
698 -- yet activated. This list will be empty unless the block completes
702 Make_Procedure_Call_Statement (Loc,
705 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
706 Parameter_Associations => New_List (
707 New_Reference_To (Activation_Chain_Entity (N), Loc))));
709 -- Attempt to cancel an asynchronous entry call whenever the block which
710 -- contains the abortable part is exited.
712 -- NOTE: The generated code references Cnn, a local object
714 elsif Is_Asynchronous_Call then
716 Cancel_Param : constant Entity_Id :=
717 Entry_Cancel_Parameter (Entity (Identifier (N)));
720 -- If it is of type Communication_Block, this must be a protected
721 -- entry call. Generate:
723 -- if Enqueued (Cancel_Param) then
724 -- Cancel_Protected_Entry_Call (Cancel_Param);
727 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
729 Make_If_Statement (Loc,
731 Make_Function_Call (Loc,
733 New_Reference_To (RTE (RE_Enqueued), Loc),
734 Parameter_Associations => New_List (
735 New_Reference_To (Cancel_Param, Loc))),
737 Then_Statements => New_List (
738 Make_Procedure_Call_Statement (Loc,
741 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
742 Parameter_Associations => New_List (
743 New_Reference_To (Cancel_Param, Loc))))));
745 -- Asynchronous delay, generate:
746 -- Cancel_Async_Delay (Cancel_Param);
748 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
750 Make_Procedure_Call_Statement (Loc,
752 New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
753 Parameter_Associations => New_List (
754 Make_Attribute_Reference (Loc,
756 New_Reference_To (Cancel_Param, Loc),
757 Attribute_Name => Name_Unchecked_Access))));
759 -- Task entry call, generate:
760 -- Cancel_Task_Entry_Call (Cancel_Param);
764 Make_Procedure_Call_Statement (Loc,
766 New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
767 Parameter_Associations => New_List (
768 New_Reference_To (Cancel_Param, Loc))));
773 -- Inspect all declaration and/or statement lists of N for library-level
774 -- tagged types. Generate code to unregister the external tag of such a
777 if Nkind (N) = N_Package_Declaration then
778 Unregister_Tagged_Types (Private_Declarations (Specification (N)));
779 Unregister_Tagged_Types (Visible_Declarations (Specification (N)));
781 -- Accept statement, block, entry body, package body, protected body,
782 -- subprogram body or task body.
785 if Present (Handled_Statement_Sequence (N)) then
786 Unregister_Tagged_Types
787 (Statements (Handled_Statement_Sequence (N)));
790 Unregister_Tagged_Types (Declarations (N));
794 end Build_Cleanup_Statements;
796 -----------------------------
797 -- Build_Controlling_Procs --
798 -----------------------------
800 procedure Build_Controlling_Procs (Typ : Entity_Id) is
802 if Is_Array_Type (Typ) then
803 Build_Array_Deep_Procs (Typ);
804 else pragma Assert (Is_Record_Type (Typ));
805 Build_Record_Deep_Procs (Typ);
807 end Build_Controlling_Procs;
809 -----------------------------
810 -- Build_Exception_Handler --
811 -----------------------------
813 function Build_Exception_Handler
816 Raised_Id : Entity_Id;
817 For_Library : Boolean := False) return Node_Id
820 Proc_To_Call : Entity_Id;
823 pragma Assert (Present (E_Id));
824 pragma Assert (Present (Raised_Id));
827 -- Get_Current_Excep.all.all
829 Actuals := New_List (
830 Make_Explicit_Dereference (Loc,
832 Make_Function_Call (Loc,
834 Make_Explicit_Dereference (Loc,
836 New_Reference_To (RTE (RE_Get_Current_Excep), Loc)))));
838 if For_Library and then not Restricted_Profile then
839 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
842 Proc_To_Call := RTE (RE_Save_Occurrence);
843 Prepend_To (Actuals, New_Reference_To (E_Id, Loc));
848 -- if not Raised_Id then
849 -- Raised_Id := True;
851 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
853 -- Save_Library_Occurrence (Get_Current_Excep.all.all);
857 Make_Exception_Handler (Loc,
858 Exception_Choices => New_List (
859 Make_Others_Choice (Loc)),
861 Statements => New_List (
862 Make_If_Statement (Loc,
865 Right_Opnd => New_Reference_To (Raised_Id, Loc)),
867 Then_Statements => New_List (
868 Make_Assignment_Statement (Loc,
869 Name => New_Reference_To (Raised_Id, Loc),
870 Expression => New_Reference_To (Standard_True, Loc)),
872 Make_Procedure_Call_Statement (Loc,
874 New_Reference_To (Proc_To_Call, Loc),
875 Parameter_Associations => Actuals)))));
876 end Build_Exception_Handler;
878 -----------------------------------
879 -- Build_Finalization_Collection --
880 -----------------------------------
882 procedure Build_Finalization_Collection
884 Ins_Node : Node_Id := Empty;
885 Encl_Scope : Entity_Id := Empty)
887 Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
889 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
890 -- Determine whether entity E is inside a wrapper package created for
891 -- an instance of Ada.Unchecked_Deallocation.
893 ------------------------------
894 -- In_Deallocation_Instance --
895 ------------------------------
897 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
898 Pkg : constant Entity_Id := Scope (E);
899 Par : Node_Id := Empty;
902 if Ekind (Pkg) = E_Package
903 and then Present (Related_Instance (Pkg))
904 and then Ekind (Related_Instance (Pkg)) = E_Procedure
906 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
910 and then Chars (Par) = Name_Unchecked_Deallocation
911 and then Chars (Scope (Par)) = Name_Ada
912 and then Scope (Scope (Par)) = Standard_Standard;
916 end In_Deallocation_Instance;
918 -- Start of processing for Build_Finalization_Collection
921 -- Certain run-time configurations and targets do not provide support
922 -- for controlled types.
924 if Restriction_Active (No_Finalization) then
927 -- Various machinery such as freezing may have already created a
930 elsif Present (Associated_Collection (Typ)) then
933 -- Do not process types that return on the secondary stack
935 -- ??? The need for a secondary stack should be revisited and perhaps
938 elsif Present (Associated_Storage_Pool (Typ))
939 and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
943 -- Do not process types which may never allocate an object
945 elsif No_Pool_Assigned (Typ) then
948 -- Do not process access types coming from Ada.Unchecked_Deallocation
949 -- instances. Even though the designated type may be controlled, the
950 -- access type will never participate in allocation.
952 elsif In_Deallocation_Instance (Typ) then
955 -- Ignore the general use of anonymous access types unless the context
956 -- requires a collection.
958 elsif Ekind (Typ) = E_Anonymous_Access_Type
959 and then No (Ins_Node)
963 -- Do not process non-library access types when restriction No_Nested_
964 -- Finalization is in effect since collections are controlled objects.
966 elsif Restriction_Active (No_Nested_Finalization)
967 and then not Is_Library_Level_Entity (Typ)
971 -- For .NET/JVM targets, allow the processing of access-to-controlled
972 -- types where the designated type is explicitly derived from [Limited_]
975 elsif VM_Target /= No_VM
976 and then not Is_Controlled (Desig_Typ)
982 Loc : constant Source_Ptr := Sloc (Typ);
983 Actions : constant List_Id := New_List;
989 -- Fnn : Finalization_Collection;
991 -- Source access types use fixed names for their collections since
992 -- the collection is inserted only once in the same source unit and
993 -- there is no possible name overlap. Internally-generated access
994 -- types on the other hand use temporaries as collection names due
995 -- to possible name collisions.
997 if Comes_From_Source (Typ) then
999 Make_Defining_Identifier (Loc,
1000 Chars => New_External_Name (Chars (Typ), "FC"));
1002 Coll_Id := Make_Temporary (Loc, 'F');
1006 Make_Object_Declaration (Loc,
1007 Defining_Identifier => Coll_Id,
1008 Object_Definition =>
1009 New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
1011 -- Storage pool selection and attribute decoration of the generated
1012 -- collection. Since .NET/JVM compilers do not support pools, this
1015 if VM_Target = No_VM then
1017 -- If the access type has a user-defined pool, use it as the base
1018 -- storage medium for the finalization pool.
1020 if Present (Associated_Storage_Pool (Typ)) then
1021 Pool_Id := Associated_Storage_Pool (Typ);
1023 -- Access subtypes must use the storage pool of their base type
1025 elsif Ekind (Typ) = E_Access_Subtype then
1027 Base_Typ : constant Entity_Id := Base_Type (Typ);
1030 if No (Associated_Storage_Pool (Base_Typ)) then
1031 Pool_Id := Get_Global_Pool_For_Access_Type (Base_Typ);
1032 Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
1034 Pool_Id := Associated_Storage_Pool (Base_Typ);
1038 -- The default choice is the global pool
1041 Pool_Id := Get_Global_Pool_For_Access_Type (Typ);
1042 Set_Associated_Storage_Pool (Typ, Pool_Id);
1046 -- Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
1049 Make_Procedure_Call_Statement (Loc,
1051 New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
1052 Parameter_Associations => New_List (
1053 New_Reference_To (Coll_Id, Loc),
1054 Make_Attribute_Reference (Loc,
1055 Prefix => New_Reference_To (Pool_Id, Loc),
1056 Attribute_Name => Name_Unrestricted_Access))));
1059 Set_Associated_Collection (Typ, Coll_Id);
1061 -- A finalization collection created for an anonymous access type
1062 -- must be inserted before a context-dependent node.
1064 if Present (Ins_Node) then
1065 Push_Scope (Encl_Scope);
1067 -- Treat use clauses as declarations and insert directly in front
1070 if Nkind_In (Ins_Node, N_Use_Package_Clause,
1073 Insert_List_Before_And_Analyze (Ins_Node, Actions);
1075 Insert_Actions (Ins_Node, Actions);
1080 elsif Ekind (Typ) = E_Access_Subtype
1081 or else (Ekind (Desig_Typ) = E_Incomplete_Type
1082 and then Has_Completion_In_Body (Desig_Typ))
1084 Insert_Actions (Parent (Typ), Actions);
1086 -- If the designated type is not yet frozen, then append the actions
1087 -- to that type's freeze actions. The actions need to be appended to
1088 -- whichever type is frozen later, similarly to what Freeze_Type does
1089 -- for appending the storage pool declaration for an access type.
1090 -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
1091 -- pool object before it's declared. However, it's not clear that
1092 -- this is exactly the right test to accomplish that here. ???
1094 elsif Present (Freeze_Node (Desig_Typ))
1095 and then not Analyzed (Freeze_Node (Desig_Typ))
1097 Append_Freeze_Actions (Desig_Typ, Actions);
1099 elsif Present (Freeze_Node (Typ))
1100 and then not Analyzed (Freeze_Node (Typ))
1102 Append_Freeze_Actions (Typ, Actions);
1104 -- If there's a pool created locally for the access type, then we
1105 -- need to ensure that the collection gets created after the pool
1106 -- object, because otherwise we can have a forward reference, so
1107 -- we force the collection actions to be inserted and analyzed after
1108 -- the pool entity. Note that both the access type and its designated
1109 -- type may have already been frozen and had their freezing actions
1110 -- analyzed at this point. (This seems a little unclean.???)
1112 elsif VM_Target = No_VM
1113 and then Scope (Pool_Id) = Scope (Typ)
1115 Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
1118 Insert_Actions (Parent (Typ), Actions);
1121 end Build_Finalization_Collection;
1123 ---------------------
1124 -- Build_Finalizer --
1125 ---------------------
1127 procedure Build_Finalizer
1129 Clean_Stmts : List_Id;
1130 Mark_Id : Entity_Id;
1131 Top_Decls : List_Id;
1132 Defer_Abort : Boolean;
1133 Fin_Id : out Entity_Id)
1135 Acts_As_Clean : constant Boolean :=
1138 (Present (Clean_Stmts)
1139 and then Is_Non_Empty_List (Clean_Stmts));
1140 Exceptions_OK : constant Boolean :=
1141 not Restriction_Active (No_Exception_Propagation);
1142 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1143 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1144 For_Package : constant Boolean :=
1145 For_Package_Body or else For_Package_Spec;
1146 Loc : constant Source_Ptr := Sloc (N);
1148 -- NOTE: Local variable declarations are conservative and do not create
1149 -- structures right from the start. Entities and lists are created once
1150 -- it has been established that N has at least one controlled object.
1152 Abort_Id : Entity_Id := Empty;
1153 -- Entity of local flag. The flag is set when finalization is triggered
1156 Components_Built : Boolean := False;
1157 -- A flag used to avoid double initialization of entities and lists. If
1158 -- the flag is set then the following variables have been initialized:
1168 Counter_Id : Entity_Id := Empty;
1169 Counter_Val : Int := 0;
1170 -- Name and value of the state counter
1172 Decls : List_Id := No_List;
1173 -- Declarative region of N (if available). If N is a package declaration
1174 -- Decls denotes the visible declarations.
1176 E_Id : Entity_Id := Empty;
1177 -- Entity of the local exception occurence. The first exception which
1178 -- occurred during finalization is stored in E_Id and later reraised.
1180 Finalizer_Decls : List_Id := No_List;
1181 -- Local variable declarations. This list holds the label declarations
1182 -- of all jump block alternatives as well as the declaration of the
1183 -- local exception occurence and the raised flag.
1185 -- E : Exception_Occurrence;
1186 -- Raised : Boolean := False;
1187 -- L<counter value> : label;
1189 Finalizer_Insert_Nod : Node_Id := Empty;
1190 -- Insertion point for the finalizer body. Depending on the context
1191 -- (Nkind of N) and the individual grouping of controlled objects, this
1192 -- node may denote a package declaration or body, package instantiation,
1193 -- block statement or a counter update statement.
1195 Finalizer_Stmts : List_Id := No_List;
1196 -- The statement list of the finalizer body. It contains the following:
1198 -- Abort_Defer; -- Added if abort is allowed
1199 -- <call to Prev_At_End> -- Added if exists
1200 -- <cleanup statements> -- Added if Acts_As_Clean
1201 -- <jump block> -- Added if Has_Ctrl_Objs
1202 -- <finalization statements> -- Added if Has_Ctrl_Objs
1203 -- <stack release> -- Added if Mark_Id exists
1204 -- Abort_Undefer; -- Added if abort is allowed
1206 Has_Ctrl_Objs : Boolean := False;
1207 -- A general flag which denotes whether N has at least one controlled
1210 HSS : Node_Id := Empty;
1211 -- The sequence of statements of N (if available)
1213 Jump_Alts : List_Id := No_List;
1214 -- Jump block alternatives. Depending on the value of the state counter,
1215 -- the control flow jumps to a sequence of finalization statments. This
1216 -- list contains the following:
1218 -- when <counter value> =>
1219 -- goto L<counter value>;
1221 Jump_Block_Insert_Nod : Node_Id := Empty;
1222 -- Specific point in the finalizer statements where the jump block is
1225 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1226 -- The last controlled construct encountered when processing the top
1227 -- level lists of N. This can be a nested package, an instantiation or
1228 -- an object declaration.
1230 Prev_At_End : Entity_Id := Empty;
1231 -- The previous at end procedure of the handled statements block of N
1233 Priv_Decls : List_Id := No_List;
1234 -- The private declarations of N if N is a package declaration
1236 Raised_Id : Entity_Id := Empty;
1237 -- Entity for the raised flag. Along with E_Id, the flag is used in the
1238 -- propagation of exceptions which occur during finalization.
1240 Spec_Id : Entity_Id := Empty;
1241 Spec_Decls : List_Id := Top_Decls;
1242 Stmts : List_Id := No_List;
1244 -----------------------
1245 -- Local subprograms --
1246 -----------------------
1248 procedure Build_Components;
1249 -- Create all entites and initialize all lists used in the creation of
1252 procedure Create_Finalizer;
1253 -- Create the spec and body of the finalizer and insert them in the
1254 -- proper place in the tree depending on the context.
1256 procedure Process_Declarations
1258 Preprocess : Boolean := False;
1259 Top_Level : Boolean := False);
1260 -- Inspect a list of declarations or statements which may contain
1261 -- objects that need finalization. When flag Preprocess is set, the
1262 -- routine will simply count the total number of controlled objects in
1263 -- Decls. Flag Top_Level denotes whether the processing is done for
1264 -- objects in nested package decparations or instances.
1266 procedure Process_Object_Declaration
1268 Has_No_Init : Boolean := False;
1269 Is_Protected : Boolean := False);
1270 -- Generate all the machinery associated with the finalization of a
1271 -- single object. Flag Has_No_Init is used to denote certain contexts
1272 -- where Decl does not have initialization call(s). Flag Is_Protected
1273 -- is set when Decl denotes a simple protected object.
1275 ----------------------
1276 -- Build_Components --
1277 ----------------------
1279 procedure Build_Components is
1280 Counter_Decl : Node_Id;
1281 Counter_Typ : Entity_Id;
1282 Counter_Typ_Decl : Node_Id;
1285 pragma Assert (Present (Decls));
1287 -- This routine might be invoked several times when dealing with
1288 -- constructs that have two lists (either two declarative regions
1289 -- or declarations and statements). Avoid double initialization.
1291 if Components_Built then
1295 Components_Built := True;
1297 if Has_Ctrl_Objs then
1299 -- Create entities for the counter, its type, the local exception
1300 -- and the raised flag.
1302 Counter_Id := Make_Temporary (Loc, 'C');
1303 Counter_Typ := Make_Temporary (Loc, 'T');
1305 if Exceptions_OK then
1306 Abort_Id := Make_Temporary (Loc, 'A');
1307 E_Id := Make_Temporary (Loc, 'E');
1308 Raised_Id := Make_Temporary (Loc, 'R');
1311 -- Since the total number of controlled objects is always known,
1312 -- build a subtype of Natural with precise bounds. This allows
1313 -- the backend to optimize the case statement. Generate:
1315 -- subtype Tnn is Natural range 0 .. Counter_Val;
1318 Make_Subtype_Declaration (Loc,
1319 Defining_Identifier => Counter_Typ,
1320 Subtype_Indication =>
1321 Make_Subtype_Indication (Loc,
1322 Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
1324 Make_Range_Constraint (Loc,
1328 Make_Integer_Literal (Loc, Uint_0),
1330 Make_Integer_Literal (Loc, Counter_Val)))));
1332 -- Generate the declaration of the counter itself:
1334 -- Counter : Integer := 0;
1337 Make_Object_Declaration (Loc,
1338 Defining_Identifier => Counter_Id,
1339 Object_Definition => New_Reference_To (Counter_Typ, Loc),
1340 Expression => Make_Integer_Literal (Loc, 0));
1342 -- Set the type of the counter explicitly to prevent errors when
1343 -- examining object declarations later on.
1345 Set_Etype (Counter_Id, Counter_Typ);
1347 -- The counter and its type are inserted before the source
1348 -- declarations of N.
1350 Prepend_To (Decls, Counter_Decl);
1351 Prepend_To (Decls, Counter_Typ_Decl);
1353 -- The counter and its associated type must be manually analized
1354 -- since N has already been analyzed. Use the scope of the spec
1355 -- when inserting in a package.
1358 Push_Scope (Spec_Id);
1359 Analyze (Counter_Typ_Decl);
1360 Analyze (Counter_Decl);
1364 Analyze (Counter_Typ_Decl);
1365 Analyze (Counter_Decl);
1368 Finalizer_Decls := New_List;
1369 Jump_Alts := New_List;
1372 -- If the context requires additional clean up, the finalization
1373 -- machinery is added after the clean up code.
1375 if Acts_As_Clean then
1376 Finalizer_Stmts := Clean_Stmts;
1377 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1379 Finalizer_Stmts := New_List;
1381 end Build_Components;
1383 ----------------------
1384 -- Create_Finalizer --
1385 ----------------------
1387 procedure Create_Finalizer is
1388 Body_Id : Entity_Id;
1391 Jump_Block : Node_Id;
1393 Label_Id : Entity_Id;
1395 function New_Finalizer_Name return Name_Id;
1396 -- Create a fully qualified name of a package spec or body finalizer.
1397 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1399 ------------------------
1400 -- New_Finalizer_Name --
1401 ------------------------
1403 function New_Finalizer_Name return Name_Id is
1404 procedure New_Finalizer_Name (Id : Entity_Id);
1405 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1406 -- has a non-standard scope, process the scope first.
1408 ------------------------
1409 -- New_Finalizer_Name --
1410 ------------------------
1412 procedure New_Finalizer_Name (Id : Entity_Id) is
1414 if Scope (Id) = Standard_Standard then
1415 Get_Name_String (Chars (Id));
1418 New_Finalizer_Name (Scope (Id));
1419 Add_Str_To_Name_Buffer ("__");
1420 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1422 end New_Finalizer_Name;
1424 -- Start of processing for New_Finalizer_Name
1427 -- Create the fully qualified name of the enclosing scope
1429 New_Finalizer_Name (Spec_Id);
1432 -- __finalize_[spec|body]
1434 Add_Str_To_Name_Buffer ("__finalize_");
1436 if For_Package_Spec then
1437 Add_Str_To_Name_Buffer ("spec");
1439 Add_Str_To_Name_Buffer ("body");
1443 end New_Finalizer_Name;
1445 -- Start of processing for Create_Finalizer
1448 -- Step 1: Creation of the finalizer name
1450 -- Packages must use a distinct name for their finalizers since the
1451 -- binder will have to generate calls to them by name. The name is
1452 -- of the following form:
1454 -- xx__yy__finalize_[spec|body]
1457 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1458 Set_Has_Qualified_Name (Fin_Id);
1459 Set_Has_Fully_Qualified_Name (Fin_Id);
1461 -- The default name is _finalizer
1465 Make_Defining_Identifier (Loc,
1466 Chars => New_External_Name (Name_uFinalizer));
1469 -- Step 2: Creation of the finalizer specification
1472 -- procedure Fin_Id;
1475 Make_Subprogram_Declaration (Loc,
1477 Make_Procedure_Specification (Loc,
1478 Defining_Unit_Name => Fin_Id));
1480 -- Step 3: Creation of the finalizer body
1482 if Has_Ctrl_Objs then
1484 -- Add L0, the default destination to the jump block
1486 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1487 Set_Entity (Label_Id,
1488 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1489 Label := Make_Label (Loc, Label_Id);
1494 Prepend_To (Finalizer_Decls,
1495 Make_Implicit_Label_Declaration (Loc,
1496 Defining_Identifier => Entity (Label_Id),
1497 Label_Construct => Label));
1503 Append_To (Jump_Alts,
1504 Make_Case_Statement_Alternative (Loc,
1505 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1506 Statements => New_List (
1507 Make_Goto_Statement (Loc,
1508 Name => New_Reference_To (Entity (Label_Id), Loc)))));
1513 Append_To (Finalizer_Stmts, Label);
1515 -- The local exception does not need to be reraised for library-
1516 -- level finalizers. Generate:
1519 -- Raise_From_Controlled_Operation (E, Abort);
1523 and then Exceptions_OK
1525 Append_To (Finalizer_Stmts,
1526 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
1529 -- Create the jump block which controls the finalization flow
1530 -- depending on the value of the state counter.
1533 Make_Case_Statement (Loc,
1534 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1535 Alternatives => Jump_Alts);
1538 and then Present (Jump_Block_Insert_Nod)
1540 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1542 Prepend_To (Finalizer_Stmts, Jump_Block);
1546 -- Add a call to the previous At_End handler if it exists. The call
1547 -- must always precede the jump block.
1549 if Present (Prev_At_End) then
1550 Prepend_To (Finalizer_Stmts,
1551 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1553 -- Clear the At_End handler since we have already generated the
1554 -- proper replacement call for it.
1556 Set_At_End_Proc (HSS, Empty);
1559 -- Release the secondary stack mark
1561 if Present (Mark_Id) then
1562 Append_To (Finalizer_Stmts,
1563 Make_Procedure_Call_Statement (Loc,
1565 New_Reference_To (RTE (RE_SS_Release), Loc),
1566 Parameter_Associations => New_List (
1567 New_Reference_To (Mark_Id, Loc))));
1570 -- Protect the statements with abort defer/undefer. This is only when
1571 -- aborts are allowed and the clean up statements require deferral or
1572 -- there are controlled objects to be finalized.
1576 (Defer_Abort or else Has_Ctrl_Objs)
1578 Prepend_To (Finalizer_Stmts,
1579 Make_Procedure_Call_Statement (Loc,
1580 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
1582 Append_To (Finalizer_Stmts,
1583 Make_Procedure_Call_Statement (Loc,
1584 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
1588 -- procedure Fin_Id is
1589 -- Abort : constant Boolean :=
1590 -- Exception_Occurrence (Get_Current_Excep.all.all) =
1591 -- Standard'Abort_Signal'Identity;
1593 -- Abort : constant Boolean := False; -- no abort
1595 -- E : Exception_Occurrence; -- All added if flag
1596 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1602 -- Abort_Defer; -- Added if abort is allowed
1603 -- <call to Prev_At_End> -- Added if exists
1604 -- <cleanup statements> -- Added if Acts_As_Clean
1605 -- <jump block> -- Added if Has_Ctrl_Objs
1606 -- <finalization statements> -- Added if Has_Ctrl_Objs
1607 -- <stack release> -- Added if Mark_Id exists
1608 -- Abort_Undefer; -- Added if abort is allowed
1612 and then Exceptions_OK
1614 Prepend_List_To (Finalizer_Decls,
1615 Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id));
1618 -- Create the body of the finalizer
1620 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1623 Set_Has_Qualified_Name (Body_Id);
1624 Set_Has_Fully_Qualified_Name (Body_Id);
1628 Make_Subprogram_Body (Loc,
1630 Make_Procedure_Specification (Loc,
1631 Defining_Unit_Name => Body_Id),
1633 Declarations => Finalizer_Decls,
1635 Handled_Statement_Sequence =>
1636 Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1638 -- Step 4: Spec and body insertion, analysis
1642 -- If the package spec has private declarations, the finalizer
1643 -- body must be added to the end of the list in order to have
1644 -- visibility of all private controlled objects.
1646 if For_Package_Spec then
1647 if Present (Priv_Decls) then
1648 Append_To (Priv_Decls, Fin_Spec);
1649 Append_To (Priv_Decls, Fin_Body);
1651 Append_To (Decls, Fin_Spec);
1652 Append_To (Decls, Fin_Body);
1655 -- For package bodies, both the finalizer spec and body are
1656 -- inserted at the end of the package declarations.
1659 Append_To (Decls, Fin_Spec);
1660 Append_To (Decls, Fin_Body);
1663 -- Push the name of the package
1665 Push_Scope (Spec_Id);
1673 -- Create the spec for the finalizer. The At_End handler must be
1674 -- able to call the body which resides in a nested structure.
1678 -- procedure Fin_Id; -- Spec
1680 -- <objects and possibly statements>
1681 -- procedure Fin_Id is ... -- Body
1684 -- Fin_Id; -- At_End handler
1687 pragma Assert (Present (Spec_Decls));
1689 Append_To (Spec_Decls, Fin_Spec);
1692 -- When the finalizer acts solely as a clean up routine, the body
1693 -- is inserted right after the spec.
1696 and then not Has_Ctrl_Objs
1698 Insert_After (Fin_Spec, Fin_Body);
1700 -- In all other cases the body is inserted after either:
1702 -- 1) The counter update statement of the last controlled object
1703 -- 2) The last top level nested controlled package
1704 -- 3) The last top level controlled instantiation
1707 -- Manually freeze the spec. This is somewhat of a hack because
1708 -- a subprogram is frozen when its body is seen and the freeze
1709 -- node appears right before the body. However, in this case,
1710 -- the spec must be frozen earlier since the At_End handler
1711 -- must be able to call it.
1714 -- procedure Fin_Id; -- Spec
1715 -- [Fin_Id] -- Freeze node
1719 -- Fin_Id; -- At_End handler
1722 Ensure_Freeze_Node (Fin_Id);
1723 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1724 Set_Is_Frozen (Fin_Id);
1726 -- In the case where the last construct to contain a controlled
1727 -- object is either a nested package, an instantiation or a
1728 -- freeze node, the body must be inserted directly after the
1731 if Nkind_In (Last_Top_Level_Ctrl_Construct,
1733 N_Package_Declaration,
1736 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1739 Insert_After (Finalizer_Insert_Nod, Fin_Body);
1744 end Create_Finalizer;
1746 --------------------------
1747 -- Process_Declarations --
1748 --------------------------
1750 procedure Process_Declarations
1752 Preprocess : Boolean := False;
1753 Top_Level : Boolean := False)
1758 Obj_Typ : Entity_Id;
1759 Pack_Id : Entity_Id;
1763 Old_Counter_Val : Int;
1764 -- This variable is used to determine whether a nested package or
1765 -- instance contains at least one controlled object.
1767 procedure Processing_Actions
1768 (Has_No_Init : Boolean := False;
1769 Is_Protected : Boolean := False);
1770 -- Depending on the mode of operation of Process_Declarations, either
1771 -- increment the controlled object counter, set the controlled object
1772 -- flag and store the last top level construct or process the current
1773 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1774 -- the current declaration may not have initialization proc(s). Flag
1775 -- Is_Protected should be set when the current declaration denotes a
1776 -- simple protected object.
1778 ------------------------
1779 -- Processing_Actions --
1780 ------------------------
1782 procedure Processing_Actions
1783 (Has_No_Init : Boolean := False;
1784 Is_Protected : Boolean := False)
1788 Counter_Val := Counter_Val + 1;
1789 Has_Ctrl_Objs := True;
1792 and then No (Last_Top_Level_Ctrl_Construct)
1794 Last_Top_Level_Ctrl_Construct := Decl;
1797 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1799 end Processing_Actions;
1801 -- Start of processing for Process_Declarations
1804 if No (Decls) or else Is_Empty_List (Decls) then
1808 -- Process all declarations in reverse order
1810 Decl := Last_Non_Pragma (Decls);
1811 while Present (Decl) loop
1813 -- Regular object declarations
1815 if Nkind (Decl) = N_Object_Declaration then
1816 Obj_Id := Defining_Identifier (Decl);
1817 Obj_Typ := Base_Type (Etype (Obj_Id));
1818 Expr := Expression (Decl);
1820 -- Bypass any form of processing for objects which have their
1821 -- finalization disabled. This applies only to objects at the
1825 and then Finalize_Storage_Only (Obj_Typ)
1829 -- Transient variables are treated separately in order to
1830 -- minimize the size of the generated code. See Process_
1831 -- Transient_Objects.
1833 elsif Is_Processed_Transient (Obj_Id) then
1836 -- The object is of the form:
1837 -- Obj : Typ [:= Expr];
1839 -- Do not process the incomplete view of a deferred constant.
1840 -- Do not consider tag-to-class-wide conversions.
1842 elsif not Is_Imported (Obj_Id)
1843 and then Needs_Finalization (Obj_Typ)
1844 and then not (Ekind (Obj_Id) = E_Constant
1845 and then not Has_Completion (Obj_Id))
1846 and then not Is_Tag_To_CW_Conversion (Obj_Id)
1850 -- The object is of the form:
1851 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
1853 -- Obj : Access_Typ :=
1854 -- BIP_Function_Call
1855 -- (..., BIPaccess => null, ...)'reference;
1857 elsif Is_Access_Type (Obj_Typ)
1858 and then Needs_Finalization
1859 (Available_View (Designated_Type (Obj_Typ)))
1860 and then Present (Expr)
1862 (Is_Null_Access_BIP_Func_Call (Expr)
1863 or else (Is_Non_BIP_Func_Call (Expr)
1865 Is_Related_To_Func_Return (Obj_Id)))
1867 Processing_Actions (Has_No_Init => True);
1869 -- Processing for "hook" objects generated for controlled
1870 -- transients declared inside an Expression_With_Actions.
1872 elsif Is_Access_Type (Obj_Typ)
1873 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1874 and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
1875 N_Object_Declaration
1876 and then Is_Finalizable_Transient
1877 (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
1879 Processing_Actions (Has_No_Init => True);
1881 -- Simple protected objects which use type System.Tasking.
1882 -- Protected_Objects.Protection to manage their locks should
1883 -- be treated as controlled since they require manual cleanup.
1884 -- The only exception is illustrated in the following example:
1887 -- type Ctrl is new Controlled ...
1888 -- procedure Finalize (Obj : in out Ctrl);
1892 -- package body Pkg is
1893 -- protected Prot is
1894 -- procedure Do_Something (Obj : in out Ctrl);
1897 -- protected body Prot is
1898 -- procedure Do_Something (Obj : in out Ctrl) is ...
1901 -- procedure Finalize (Obj : in out Ctrl) is
1903 -- Prot.Do_Something (Obj);
1907 -- Since for the most part entities in package bodies depend on
1908 -- those in package specs, Prot's lock should be cleaned up
1909 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
1910 -- This act however attempts to invoke Do_Something and fails
1911 -- because the lock has disappeared.
1913 elsif Ekind (Obj_Id) = E_Variable
1914 and then not In_Library_Level_Package_Body (Obj_Id)
1916 (Is_Simple_Protected_Type (Obj_Typ)
1917 or else Has_Simple_Protected_Object (Obj_Typ))
1919 Processing_Actions (Is_Protected => True);
1922 -- Specific cases of object renamings
1924 elsif Nkind (Decl) = N_Object_Renaming_Declaration
1925 and then Nkind (Name (Decl)) = N_Explicit_Dereference
1926 and then Nkind (Prefix (Name (Decl))) = N_Identifier
1928 Obj_Id := Defining_Identifier (Decl);
1929 Obj_Typ := Base_Type (Etype (Obj_Id));
1931 -- Bypass any form of processing for objects which have their
1932 -- finalization disabled. This applies only to objects at the
1936 and then Finalize_Storage_Only (Obj_Typ)
1940 -- Return object of a build-in-place function. This case is
1941 -- recognized and marked by the expansion of an extended return
1942 -- statement (see Expand_N_Extended_Return_Statement).
1944 elsif Needs_Finalization (Obj_Typ)
1945 and then Is_Return_Object (Obj_Id)
1946 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1948 Processing_Actions (Has_No_Init => True);
1951 -- Inspect the freeze node of an access-to-controlled type and
1952 -- look for a delayed finalization collection. This case arises
1953 -- when the freeze actions are inserted at a later time than the
1954 -- expansion of the context. Since Build_Finalizer is never called
1955 -- on a single construct twice, the collection will be ultimately
1956 -- left out and never finalized. This is also needed for freeze
1957 -- actions of designated types themselves, since in some cases the
1958 -- finalization collection is associated with a designated type's
1959 -- freeze node rather than that of the access type (see handling
1960 -- for freeze actions in Build_Finalization_Collection).
1962 elsif Nkind (Decl) = N_Freeze_Entity
1963 and then Present (Actions (Decl))
1965 Typ := Entity (Decl);
1967 if (Is_Access_Type (Typ)
1968 and then not Is_Access_Subprogram_Type (Typ)
1969 and then Needs_Finalization
1970 (Available_View (Designated_Type (Typ))))
1971 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
1973 Old_Counter_Val := Counter_Val;
1975 -- Freeze nodes are considered to be identical to packages
1976 -- and blocks in terms of nesting. The difference is that
1977 -- a finalization collection created inside the freeze node
1978 -- is at the same nesting level as the node itself.
1980 Process_Declarations (Actions (Decl), Preprocess);
1982 -- The freeze node contains a finalization collection
1986 and then No (Last_Top_Level_Ctrl_Construct)
1987 and then Counter_Val > Old_Counter_Val
1989 Last_Top_Level_Ctrl_Construct := Decl;
1993 -- Nested package declarations, avoid generics
1995 elsif Nkind (Decl) = N_Package_Declaration then
1996 Spec := Specification (Decl);
1997 Pack_Id := Defining_Unit_Name (Spec);
1999 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
2000 Pack_Id := Defining_Identifier (Pack_Id);
2003 if Ekind (Pack_Id) /= E_Generic_Package then
2004 Old_Counter_Val := Counter_Val;
2005 Process_Declarations
2006 (Private_Declarations (Spec), Preprocess);
2007 Process_Declarations
2008 (Visible_Declarations (Spec), Preprocess);
2010 -- Either the visible or the private declarations contain a
2011 -- controlled object. The nested package declaration is the
2012 -- last such construct.
2016 and then No (Last_Top_Level_Ctrl_Construct)
2017 and then Counter_Val > Old_Counter_Val
2019 Last_Top_Level_Ctrl_Construct := Decl;
2023 -- Nested package bodies, avoid generics
2025 elsif Nkind (Decl) = N_Package_Body then
2026 Spec := Corresponding_Spec (Decl);
2028 if Ekind (Spec) /= E_Generic_Package then
2029 Old_Counter_Val := Counter_Val;
2030 Process_Declarations (Declarations (Decl), Preprocess);
2032 -- The nested package body is the last construct to contain
2033 -- a controlled object.
2037 and then No (Last_Top_Level_Ctrl_Construct)
2038 and then Counter_Val > Old_Counter_Val
2040 Last_Top_Level_Ctrl_Construct := Decl;
2044 -- Handle a rare case caused by a controlled transient variable
2045 -- created as part of a record init proc. The variable is wrapped
2046 -- in a block, but the block is not associated with a transient
2049 elsif Nkind (Decl) = N_Block_Statement
2050 and then Inside_Init_Proc
2052 Old_Counter_Val := Counter_Val;
2054 if Present (Handled_Statement_Sequence (Decl)) then
2055 Process_Declarations
2056 (Statements (Handled_Statement_Sequence (Decl)),
2060 Process_Declarations (Declarations (Decl), Preprocess);
2062 -- Either the declaration or statement list of the block has a
2063 -- controlled object.
2067 and then No (Last_Top_Level_Ctrl_Construct)
2068 and then Counter_Val > Old_Counter_Val
2070 Last_Top_Level_Ctrl_Construct := Decl;
2074 Prev_Non_Pragma (Decl);
2076 end Process_Declarations;
2078 --------------------------------
2079 -- Process_Object_Declaration --
2080 --------------------------------
2082 procedure Process_Object_Declaration
2084 Has_No_Init : Boolean := False;
2085 Is_Protected : Boolean := False)
2087 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2088 Loc : constant Source_Ptr := Sloc (Decl);
2090 Count_Ins : Node_Id;
2092 Fin_Stmts : List_Id;
2095 Label_Id : Entity_Id;
2097 Obj_Typ : Entity_Id;
2099 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2100 -- Once it has been established that the current object is in fact a
2101 -- return object of build-in-place function Func_Id, generate the
2102 -- following cleanup code:
2104 -- if BIPallocfrom > Secondary_Stack'Pos
2105 -- and then BIPcollection /= null
2108 -- type Ptr_Typ is access Obj_Typ;
2109 -- for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection);
2112 -- Free (Ptr_Typ (Temp));
2116 -- Obj_Typ is the type of the current object, Temp is the original
2117 -- allocation which Obj_Id renames.
2119 procedure Find_Last_Init
2122 Last_Init : out Node_Id;
2123 Body_Insert : out Node_Id);
2124 -- An object declaration has at least one and at most two init calls:
2125 -- that of the type and the user-defined initialize. Given an object
2126 -- declaration, Last_Init denotes the last initialization call which
2127 -- follows the declaration. Body_Insert denotes the place where the
2128 -- finalizer body could be potentially inserted.
2130 -----------------------------
2131 -- Build_BIP_Cleanup_Stmts --
2132 -----------------------------
2134 function Build_BIP_Cleanup_Stmts
2135 (Func_Id : Entity_Id) return Node_Id
2137 Collect : constant Entity_Id :=
2138 Build_In_Place_Formal (Func_Id, BIP_Collection);
2139 Decls : constant List_Id := New_List;
2140 Obj_Typ : constant Entity_Id := Etype (Func_Id);
2141 Temp_Id : constant Entity_Id :=
2142 Entity (Prefix (Name (Parent (Obj_Id))));
2146 Free_Stmt : Node_Id;
2147 Pool_Id : Entity_Id;
2148 Ptr_Typ : Entity_Id;
2152 -- Pool_Id renames Base_Pool (BIPcollection.all).all;
2154 Pool_Id := Make_Temporary (Loc, 'P');
2157 Make_Object_Renaming_Declaration (Loc,
2158 Defining_Identifier => Pool_Id,
2160 New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
2162 Make_Explicit_Dereference (Loc,
2164 Make_Function_Call (Loc,
2166 New_Reference_To (RTE (RE_Base_Pool), Loc),
2167 Parameter_Associations => New_List (
2168 Make_Explicit_Dereference (Loc,
2169 Prefix => New_Reference_To (Collect, Loc)))))));
2171 -- Create an access type which uses the storage pool of the
2172 -- caller's collection.
2175 -- type Ptr_Typ is access Obj_Typ;
2177 Ptr_Typ := Make_Temporary (Loc, 'P');
2180 Make_Full_Type_Declaration (Loc,
2181 Defining_Identifier => Ptr_Typ,
2183 Make_Access_To_Object_Definition (Loc,
2184 Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
2186 -- Perform minor decoration in order to set the collection and the
2187 -- storage pool attributes.
2189 Set_Ekind (Ptr_Typ, E_Access_Type);
2190 Set_Associated_Collection (Ptr_Typ, Collect);
2191 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2193 -- Create an explicit free statement. Note that the free uses the
2194 -- caller's pool expressed as a renaming.
2197 Make_Free_Statement (Loc,
2199 Unchecked_Convert_To (Ptr_Typ,
2200 New_Reference_To (Temp_Id, Loc)));
2202 Set_Storage_Pool (Free_Stmt, Pool_Id);
2204 -- Create a block to house the dummy type and the instantiation as
2205 -- well as to perform the cleanup the temporary.
2211 -- Free (Ptr_Typ (Temp_Id));
2215 Make_Block_Statement (Loc,
2216 Declarations => Decls,
2217 Handled_Statement_Sequence =>
2218 Make_Handled_Sequence_Of_Statements (Loc,
2219 Statements => New_List (Free_Stmt)));
2222 -- if BIPcollection /= null then
2226 Left_Opnd => New_Reference_To (Collect, Loc),
2227 Right_Opnd => Make_Null (Loc));
2229 -- For constrained or tagged results escalate the condition to
2230 -- include the allocation format. Generate:
2232 -- if BIPallocform > Secondary_Stack'Pos
2233 -- and then BIPcollection /= null
2236 if not Is_Constrained (Obj_Typ)
2237 or else Is_Tagged_Type (Obj_Typ)
2240 Alloc : constant Entity_Id :=
2241 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2247 Left_Opnd => New_Reference_To (Alloc, Loc),
2249 Make_Integer_Literal (Loc,
2251 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2253 Right_Opnd => Cond);
2263 Make_If_Statement (Loc,
2265 Then_Statements => New_List (Free_Blk));
2266 end Build_BIP_Cleanup_Stmts;
2268 --------------------
2269 -- Find_Last_Init --
2270 --------------------
2272 procedure Find_Last_Init
2275 Last_Init : out Node_Id;
2276 Body_Insert : out Node_Id)
2278 Nod_1 : Node_Id := Empty;
2279 Nod_2 : Node_Id := Empty;
2282 function Is_Init_Call
2284 Typ : Entity_Id) return Boolean;
2285 -- Given an arbitrary node, determine whether N is a procedure
2286 -- call and if it is, try to match the name of the call with the
2287 -- [Deep_]Initialize proc of Typ.
2293 function Is_Init_Call
2295 Typ : Entity_Id) return Boolean
2298 -- A call to [Deep_]Initialize is always direct
2300 if Nkind (N) = N_Procedure_Call_Statement
2301 and then Nkind (Name (N)) = N_Identifier
2304 Call_Nam : constant Name_Id := Chars (Entity (Name (N)));
2305 Deep_Init : constant Entity_Id :=
2306 TSS (Typ, TSS_Deep_Initialize);
2307 Init : Entity_Id := Empty;
2310 -- A type may have controlled components but not be
2313 if Is_Controlled (Typ) then
2314 Init := Find_Prim_Op (Typ, Name_Initialize);
2318 (Present (Deep_Init)
2319 and then Chars (Deep_Init) = Call_Nam)
2322 and then Chars (Init) = Call_Nam);
2329 -- Start of processing for Find_Last_Init
2333 Body_Insert := Empty;
2335 -- Object renamings and objects associated with controlled
2336 -- function results do not have initialization calls.
2342 if Is_Concurrent_Type (Typ) then
2343 Utyp := Corresponding_Record_Type (Typ);
2348 -- The init procedures are arranged as follows:
2350 -- Object : Controlled_Type;
2351 -- Controlled_TypeIP (Object);
2352 -- [[Deep_]Initialize (Object);]
2354 -- where the user-defined initialize may be optional or may appear
2355 -- inside a block when abort deferral is needed.
2357 Nod_1 := Next (Decl);
2358 if Present (Nod_1) then
2359 Nod_2 := Next (Nod_1);
2361 -- The statement following an object declaration is always a
2362 -- call to the type init proc.
2367 -- Optional user-defined init or deep init processing
2369 if Present (Nod_2) then
2371 -- The statement following the type init proc may be a block
2372 -- statement in cases where abort deferral is required.
2374 if Nkind (Nod_2) = N_Block_Statement then
2376 HSS : constant Node_Id :=
2377 Handled_Statement_Sequence (Nod_2);
2382 and then Present (Statements (HSS))
2384 Stmt := First (Statements (HSS));
2386 -- Examine individual block statements and locate the
2387 -- call to [Deep_]Initialze.
2389 while Present (Stmt) loop
2390 if Is_Init_Call (Stmt, Utyp) then
2392 Body_Insert := Nod_2;
2402 elsif Is_Init_Call (Nod_2, Utyp) then
2408 -- Start of processing for Process_Object_Declaration
2411 Obj_Ref := New_Reference_To (Obj_Id, Loc);
2412 Obj_Typ := Base_Type (Etype (Obj_Id));
2414 -- Handle access types
2416 if Is_Access_Type (Obj_Typ) then
2417 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2418 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2421 Set_Etype (Obj_Ref, Obj_Typ);
2423 -- Set a new value for the state counter and insert the statement
2424 -- after the object declaration. Generate:
2426 -- Counter := <value>;
2429 Make_Assignment_Statement (Loc,
2430 Name => New_Reference_To (Counter_Id, Loc),
2431 Expression => Make_Integer_Literal (Loc, Counter_Val));
2433 -- Insert the counter after all initialization has been done. The
2434 -- place of insertion depends on the context. When dealing with a
2435 -- controlled function, the counter is inserted directly after the
2436 -- declaration because such objects lack init calls.
2438 Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
2440 Insert_After (Count_Ins, Inc_Decl);
2443 -- If the current declaration is the last in the list, the finalizer
2444 -- body needs to be inserted after the set counter statement for the
2445 -- current object declaration. This is complicated by the fact that
2446 -- the set counter statement may appear in abort deferred block. In
2447 -- that case, the proper insertion place is after the block.
2449 if No (Finalizer_Insert_Nod) then
2451 -- Insertion after an abort deffered block
2453 if Present (Body_Ins) then
2454 Finalizer_Insert_Nod := Body_Ins;
2456 Finalizer_Insert_Nod := Inc_Decl;
2460 -- Create the associated label with this object, generate:
2462 -- L<counter> : label;
2465 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2466 Set_Entity (Label_Id,
2467 Make_Defining_Identifier (Loc, Chars (Label_Id)));
2468 Label := Make_Label (Loc, Label_Id);
2470 Prepend_To (Finalizer_Decls,
2471 Make_Implicit_Label_Declaration (Loc,
2472 Defining_Identifier => Entity (Label_Id),
2473 Label_Construct => Label));
2475 -- Create the associated jump with this object, generate:
2477 -- when <counter> =>
2480 Prepend_To (Jump_Alts,
2481 Make_Case_Statement_Alternative (Loc,
2482 Discrete_Choices => New_List (
2483 Make_Integer_Literal (Loc, Counter_Val)),
2484 Statements => New_List (
2485 Make_Goto_Statement (Loc,
2486 Name => New_Reference_To (Entity (Label_Id), Loc)))));
2488 -- Insert the jump destination, generate:
2492 Append_To (Finalizer_Stmts, Label);
2494 -- Processing for simple protected objects. Such objects require
2495 -- manual finalization of their lock managers.
2497 if Is_Protected then
2498 Fin_Stmts := No_List;
2500 if Is_Simple_Protected_Type (Obj_Typ) then
2501 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2502 if Present (Fin_Call) then
2503 Fin_Stmts := New_List (Fin_Call);
2506 elsif Has_Simple_Protected_Object (Obj_Typ) then
2507 if Is_Record_Type (Obj_Typ) then
2508 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2510 elsif Is_Array_Type (Obj_Typ) then
2511 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2517 -- System.Tasking.Protected_Objects.Finalize_Protection
2525 if Present (Fin_Stmts) then
2526 Append_To (Finalizer_Stmts,
2527 Make_Block_Statement (Loc,
2528 Handled_Statement_Sequence =>
2529 Make_Handled_Sequence_Of_Statements (Loc,
2530 Statements => Fin_Stmts,
2532 Exception_Handlers => New_List (
2533 Make_Exception_Handler (Loc,
2534 Exception_Choices => New_List (
2535 Make_Others_Choice (Loc)),
2537 Statements => New_List (
2538 Make_Null_Statement (Loc)))))));
2541 -- Processing for regular controlled objects
2545 -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
2547 -- begin -- Exception handlers allowed
2548 -- [Deep_]Finalize (Obj);
2551 -- when Id : others =>
2552 -- if not Raised then
2554 -- Save_Occurrence (E, Id);
2563 if Exceptions_OK then
2564 Fin_Stmts := New_List (
2565 Make_Block_Statement (Loc,
2566 Handled_Statement_Sequence =>
2567 Make_Handled_Sequence_Of_Statements (Loc,
2568 Statements => New_List (Fin_Call),
2570 Exception_Handlers => New_List (
2571 Build_Exception_Handler
2572 (Loc, E_Id, Raised_Id, For_Package)))));
2574 -- When exception handlers are prohibited, the finalization call
2575 -- appears unprotected. Any exception raised during finalization
2576 -- will bypass the circuitry which ensures the cleanup of all
2577 -- remaining objects.
2580 Fin_Stmts := New_List (Fin_Call);
2583 -- If we are dealing with a return object of a build-in-place
2584 -- function, generate the following cleanup statements:
2586 -- if BIPallocfrom > Secondary_Stack'Pos then
2588 -- type Ptr_Typ is access Obj_Typ;
2589 -- for Ptr_Typ'Storage_Pool use
2590 -- Base_Pool (BIPcollection.all).all;
2593 -- Free (Ptr_Typ (Temp));
2597 -- The generated code effectively detaches the temporary from the
2598 -- caller finalization chain and deallocates the object. This is
2599 -- disabled on .NET/JVM because pools are not supported.
2601 -- H505-021 This needs to be revisited on .NET/JVM
2603 if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2605 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2607 if Is_Build_In_Place_Function (Func_Id)
2608 and then Needs_BIP_Collection (Func_Id)
2610 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2615 if Ekind_In (Obj_Id, E_Constant, E_Variable)
2616 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
2618 -- Return objects use a flag to aid their potential
2619 -- finalization when the enclosing function fails to return
2620 -- properly. Generate:
2623 -- <object finalization statements>
2626 if Is_Return_Object (Obj_Id) then
2627 Fin_Stmts := New_List (
2628 Make_If_Statement (Loc,
2633 (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2635 Then_Statements => Fin_Stmts));
2637 -- Temporaries created for the purpose of "exporting" a
2638 -- controlled transient out of an Expression_With_Actions (EWA)
2639 -- need guards. The following illustrates the usage of such
2642 -- Access_Typ : access [all] Obj_Typ;
2643 -- Temp : Access_Typ := null;
2644 -- <Counter> := ...;
2647 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
2648 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
2650 -- Temp := Ctrl_Trans'Unchecked_Access;
2653 -- The finalization machinery does not process EWA nodes as
2654 -- this may lead to premature finalization of expressions. Note
2655 -- that Temp is marked as being properly initialized regardless
2656 -- of whether the initialization of Ctrl_Trans succeeded. Since
2657 -- a failed initialization may leave Temp with a value of null,
2658 -- add a guard to handle this case:
2660 -- if Obj /= null then
2661 -- <object finalization statements>
2666 (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
2667 N_Object_Declaration);
2669 Fin_Stmts := New_List (
2670 Make_If_Statement (Loc,
2673 Left_Opnd => New_Reference_To (Obj_Id, Loc),
2674 Right_Opnd => Make_Null (Loc)),
2676 Then_Statements => Fin_Stmts));
2681 Append_List_To (Finalizer_Stmts, Fin_Stmts);
2683 -- Since the declarations are examined in reverse, the state counter
2684 -- must be decremented in order to keep with the true position of
2687 Counter_Val := Counter_Val - 1;
2688 end Process_Object_Declaration;
2690 -- Start of processing for Build_Finalizer
2695 -- Step 1: Extract all lists which may contain controlled objects
2697 if For_Package_Spec then
2698 Decls := Visible_Declarations (Specification (N));
2699 Priv_Decls := Private_Declarations (Specification (N));
2701 -- Retrieve the package spec id
2703 Spec_Id := Defining_Unit_Name (Specification (N));
2705 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2706 Spec_Id := Defining_Identifier (Spec_Id);
2709 -- Accept statement, block, entry body, package body, protected body,
2710 -- subprogram body or task body.
2713 Decls := Declarations (N);
2714 HSS := Handled_Statement_Sequence (N);
2716 if Present (HSS) then
2717 if Present (Statements (HSS)) then
2718 Stmts := Statements (HSS);
2721 if Present (At_End_Proc (HSS)) then
2722 Prev_At_End := At_End_Proc (HSS);
2726 -- Retrieve the package spec id for package bodies
2728 if For_Package_Body then
2729 Spec_Id := Corresponding_Spec (N);
2733 -- Do not process nested packages since those are handled by the
2734 -- enclosing scope's finalizer. Do not process non-expanded package
2735 -- instantiations since those will be re-analyzed and re-expanded.
2739 (not Is_Library_Level_Entity (Spec_Id)
2741 -- Nested packages are considered to be library level entities,
2742 -- but do not need to be processed separately. True library level
2743 -- packages have a scope value of 1.
2745 or else Scope_Depth_Value (Spec_Id) /= Uint_1
2746 or else (Is_Generic_Instance (Spec_Id)
2747 and then Package_Instantiation (Spec_Id) /= N))
2752 -- Step 2: Object [pre]processing
2756 -- Preprocess the visible declarations now in order to obtain the
2757 -- correct number of controlled object by the time the private
2758 -- declarations are processed.
2760 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2762 -- From all the possible contexts, only package specifications may
2763 -- have private declarations.
2765 if For_Package_Spec then
2766 Process_Declarations
2767 (Priv_Decls, Preprocess => True, Top_Level => True);
2770 -- The current context may lack controlled objects, but require some
2771 -- other form of completion (task termination for instance). In such
2772 -- cases, the finalizer must be created and carry the additional
2775 if Acts_As_Clean or else Has_Ctrl_Objs then
2779 -- The preprocessing has determined that the context has objects that
2780 -- need finalization actions.
2782 if Has_Ctrl_Objs then
2784 -- Private declarations are processed first in order to preserve
2785 -- possible dependencies between public and private objects.
2787 if For_Package_Spec then
2788 Process_Declarations (Priv_Decls);
2791 Process_Declarations (Decls);
2797 -- Preprocess both declarations and statements
2799 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2800 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
2802 -- At this point it is known that N has controlled objects. Ensure
2803 -- that N has a declarative list since the finalizer spec will be
2806 if Has_Ctrl_Objs and then No (Decls) then
2807 Set_Declarations (N, New_List);
2808 Decls := Declarations (N);
2809 Spec_Decls := Decls;
2812 -- The current context may lack controlled objects, but require some
2813 -- other form of completion (task termination for instance). In such
2814 -- cases, the finalizer must be created and carry the additional
2817 if Acts_As_Clean or else Has_Ctrl_Objs then
2821 if Has_Ctrl_Objs then
2822 Process_Declarations (Stmts);
2823 Process_Declarations (Decls);
2827 -- Step 3: Finalizer creation
2829 if Acts_As_Clean or else Has_Ctrl_Objs then
2832 end Build_Finalizer;
2834 --------------------------
2835 -- Build_Finalizer_Call --
2836 --------------------------
2838 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
2839 Loc : constant Source_Ptr := Sloc (N);
2840 HSS : Node_Id := Handled_Statement_Sequence (N);
2842 Is_Prot_Body : constant Boolean :=
2843 Nkind (N) = N_Subprogram_Body
2844 and then Is_Protected_Subprogram_Body (N);
2845 -- Determine whether N denotes the protected version of a subprogram
2846 -- which belongs to a protected type.
2849 -- The At_End handler should have been assimilated by the finalizer
2851 pragma Assert (No (At_End_Proc (HSS)));
2853 -- If the construct to be cleaned up is a protected subprogram body, the
2854 -- finalizer call needs to be associated with the block which wraps the
2855 -- unprotected version of the subprogram. The following illustrates this
2858 -- procedure Prot_SubpP is
2859 -- procedure finalizer is
2861 -- Service_Entries (Prot_Obj);
2868 -- Prot_SubpN (Prot_Obj);
2874 if Is_Prot_Body then
2875 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
2877 -- An At_End handler and regular exception handlers cannot coexist in
2878 -- the same statement sequence. Wrap the original statements in a block.
2880 elsif Present (Exception_Handlers (HSS)) then
2882 End_Lab : constant Node_Id := End_Label (HSS);
2887 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
2889 Set_Handled_Statement_Sequence (N,
2890 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
2892 HSS := Handled_Statement_Sequence (N);
2893 Set_End_Label (HSS, End_Lab);
2897 Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));
2899 Analyze (At_End_Proc (HSS));
2900 Expand_At_End_Handler (HSS, Empty);
2901 end Build_Finalizer_Call;
2903 ---------------------
2904 -- Build_Late_Proc --
2905 ---------------------
2907 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
2909 for Final_Prim in Name_Of'Range loop
2910 if Name_Of (Final_Prim) = Nam then
2913 (Prim => Final_Prim,
2915 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
2918 end Build_Late_Proc;
2920 -------------------------------
2921 -- Build_Object_Declarations --
2922 -------------------------------
2924 function Build_Object_Declarations
2926 Abort_Id : Entity_Id;
2928 Raised_Id : Entity_Id) return List_Id
2935 if Restriction_Active (No_Exception_Propagation) then
2939 pragma Assert (Present (Abort_Id));
2940 pragma Assert (Present (E_Id));
2941 pragma Assert (Present (Raised_Id));
2945 -- In certain scenarios, finalization can be triggered by an abort. If
2946 -- the finalization itself fails and raises an exception, the resulting
2947 -- Program_Error must be supressed and replaced by an abort signal. In
2948 -- order to detect this scenario, save the state of entry into the
2949 -- finalization code.
2951 -- No need to do this for VM case, since VM version of Ada.Exceptions
2952 -- does not include routine Raise_From_Controlled_Operation which is the
2953 -- the sole user of flag Abort.
2956 and then VM_Target = No_VM
2959 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
2963 -- Temp : constant Exception_Occurrence_Access :=
2964 -- Get_Current_Excep.all;
2967 Make_Object_Declaration (Loc,
2968 Defining_Identifier => Temp_Id,
2969 Constant_Present => True,
2970 Object_Definition =>
2971 New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc),
2973 Make_Function_Call (Loc,
2975 Make_Explicit_Dereference (Loc,
2978 (RTE (RE_Get_Current_Excep), Loc)))));
2982 -- and then Exception_Identity (Temp.all) =
2983 -- Standard'Abort_Signal'Identity;
2989 Left_Opnd => New_Reference_To (Temp_Id, Loc),
2990 Right_Opnd => Make_Null (Loc)),
2995 Make_Function_Call (Loc,
2997 New_Reference_To (RTE (RE_Exception_Identity), Loc),
2998 Parameter_Associations => New_List (
2999 Make_Explicit_Dereference (Loc,
3000 Prefix => New_Reference_To (Temp_Id, Loc)))),
3003 Make_Attribute_Reference (Loc,
3005 New_Reference_To (Stand.Abort_Signal, Loc),
3006 Attribute_Name => Name_Identity)));
3009 -- No abort or .NET/JVM
3012 A_Expr := New_Reference_To (Standard_False, Loc);
3016 -- Abort_Id : constant Boolean := <A_Expr>;
3019 Make_Object_Declaration (Loc,
3020 Defining_Identifier => Abort_Id,
3021 Constant_Present => True,
3022 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
3023 Expression => A_Expr));
3026 -- E_Id : Exception_Occurrence;
3029 Make_Object_Declaration (Loc,
3030 Defining_Identifier => E_Id,
3031 Object_Definition =>
3032 New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
3033 Set_No_Initialization (E_Decl);
3035 Append_To (Result, E_Decl);
3038 -- Raised_Id : Boolean := False;
3041 Make_Object_Declaration (Loc,
3042 Defining_Identifier => Raised_Id,
3043 Object_Definition => New_Reference_To (Standard_Boolean, Loc),
3044 Expression => New_Reference_To (Standard_False, Loc)));
3047 end Build_Object_Declarations;
3049 ---------------------------
3050 -- Build_Raise_Statement --
3051 ---------------------------
3053 function Build_Raise_Statement
3055 Abort_Id : Entity_Id;
3057 Raised_Id : Entity_Id) return Node_Id
3060 Proc_Id : Entity_Id;
3063 -- The default parameter is the local exception occurrence
3065 Params := New_List (New_Reference_To (E_Id, Loc));
3067 -- Standard run-time, .NET/JVM targets, this case handles finalization
3068 -- exceptions raised during an abort.
3070 if RTE_Available (RE_Raise_From_Controlled_Operation) then
3071 Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
3072 Append_To (Params, New_Reference_To (Abort_Id, Loc));
3074 -- Restricted runtime: exception messages are not supported and hence
3075 -- Raise_From_Controlled_Operation is not supported.
3078 Proc_Id := RTE (RE_Reraise_Occurrence);
3082 -- if Raised_Id then
3083 -- <Proc_Id> (<Params>);
3087 Make_If_Statement (Loc,
3088 Condition => New_Reference_To (Raised_Id, Loc),
3089 Then_Statements => New_List (
3090 Make_Procedure_Call_Statement (Loc,
3091 Name => New_Reference_To (Proc_Id, Loc),
3092 Parameter_Associations => Params)));
3093 end Build_Raise_Statement;
3095 -----------------------------
3096 -- Build_Record_Deep_Procs --
3097 -----------------------------
3099 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3103 (Prim => Initialize_Case,
3105 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3107 if not Is_Immutably_Limited_Type (Typ) then
3110 (Prim => Adjust_Case,
3112 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3117 (Prim => Finalize_Case,
3119 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3121 -- Create TSS primitive Finalize_Address for non-VM targets. JVM and
3122 -- .NET do not support address arithmetic and unchecked conversions.
3124 if VM_Target = No_VM then
3127 (Prim => Address_Case,
3129 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3131 end Build_Record_Deep_Procs;
3137 function Cleanup_Array
3140 Typ : Entity_Id) return List_Id
3142 Loc : constant Source_Ptr := Sloc (N);
3143 Index_List : constant List_Id := New_List;
3145 function Free_Component return List_Id;
3146 -- Generate the code to finalize the task or protected subcomponents
3147 -- of a single component of the array.
3149 function Free_One_Dimension (Dim : Int) return List_Id;
3150 -- Generate a loop over one dimension of the array
3152 --------------------
3153 -- Free_Component --
3154 --------------------
3156 function Free_Component return List_Id is
3157 Stmts : List_Id := New_List;
3159 C_Typ : constant Entity_Id := Component_Type (Typ);
3162 -- Component type is known to contain tasks or protected objects
3165 Make_Indexed_Component (Loc,
3166 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3167 Expressions => Index_List);
3169 Set_Etype (Tsk, C_Typ);
3171 if Is_Task_Type (C_Typ) then
3172 Append_To (Stmts, Cleanup_Task (N, Tsk));
3174 elsif Is_Simple_Protected_Type (C_Typ) then
3175 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3177 elsif Is_Record_Type (C_Typ) then
3178 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3180 elsif Is_Array_Type (C_Typ) then
3181 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3187 ------------------------
3188 -- Free_One_Dimension --
3189 ------------------------
3191 function Free_One_Dimension (Dim : Int) return List_Id is
3195 if Dim > Number_Dimensions (Typ) then
3196 return Free_Component;
3198 -- Here we generate the required loop
3201 Index := Make_Temporary (Loc, 'J');
3202 Append (New_Reference_To (Index, Loc), Index_List);
3205 Make_Implicit_Loop_Statement (N,
3206 Identifier => Empty,
3208 Make_Iteration_Scheme (Loc,
3209 Loop_Parameter_Specification =>
3210 Make_Loop_Parameter_Specification (Loc,
3211 Defining_Identifier => Index,
3212 Discrete_Subtype_Definition =>
3213 Make_Attribute_Reference (Loc,
3214 Prefix => Duplicate_Subexpr (Obj),
3215 Attribute_Name => Name_Range,
3216 Expressions => New_List (
3217 Make_Integer_Literal (Loc, Dim))))),
3218 Statements => Free_One_Dimension (Dim + 1)));
3220 end Free_One_Dimension;
3222 -- Start of processing for Cleanup_Array
3225 return Free_One_Dimension (1);
3228 --------------------
3229 -- Cleanup_Record --
3230 --------------------
3232 function Cleanup_Record
3235 Typ : Entity_Id) return List_Id
3237 Loc : constant Source_Ptr := Sloc (N);
3240 Stmts : constant List_Id := New_List;
3241 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3244 if Has_Discriminants (U_Typ)
3245 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3247 Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3250 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3252 -- For now, do not attempt to free a component that may appear in a
3253 -- variant, and instead issue a warning. Doing this "properly" would
3254 -- require building a case statement and would be quite a mess. Note
3255 -- that the RM only requires that free "work" for the case of a task
3256 -- access value, so already we go way beyond this in that we deal
3257 -- with the array case and non-discriminated record cases.
3260 ("task/protected object in variant record will not be freed?", N);
3261 return New_List (Make_Null_Statement (Loc));
3264 Comp := First_Component (Typ);
3265 while Present (Comp) loop
3266 if Has_Task (Etype (Comp))
3267 or else Has_Simple_Protected_Object (Etype (Comp))
3270 Make_Selected_Component (Loc,
3271 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3272 Selector_Name => New_Occurrence_Of (Comp, Loc));
3273 Set_Etype (Tsk, Etype (Comp));
3275 if Is_Task_Type (Etype (Comp)) then
3276 Append_To (Stmts, Cleanup_Task (N, Tsk));
3278 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3279 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3281 elsif Is_Record_Type (Etype (Comp)) then
3283 -- Recurse, by generating the prefix of the argument to
3284 -- the eventual cleanup call.
3286 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3288 elsif Is_Array_Type (Etype (Comp)) then
3289 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3293 Next_Component (Comp);
3299 ------------------------------
3300 -- Cleanup_Protected_Object --
3301 ------------------------------
3303 function Cleanup_Protected_Object
3305 Ref : Node_Id) return Node_Id
3307 Loc : constant Source_Ptr := Sloc (N);
3310 -- For restricted run-time libraries (Ravenscar), tasks are
3311 -- non-terminating, and protected objects can only appear at library
3312 -- level, so we do not want finalization of protected objects.
3314 if Restricted_Profile then
3319 Make_Procedure_Call_Statement (Loc,
3321 New_Reference_To (RTE (RE_Finalize_Protection), Loc),
3322 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3324 end Cleanup_Protected_Object;
3330 function Cleanup_Task
3332 Ref : Node_Id) return Node_Id
3334 Loc : constant Source_Ptr := Sloc (N);
3337 -- For restricted run-time libraries (Ravenscar), tasks are
3338 -- non-terminating and they can only appear at library level, so we do
3339 -- not want finalization of task objects.
3341 if Restricted_Profile then
3346 Make_Procedure_Call_Statement (Loc,
3348 New_Reference_To (RTE (RE_Free_Task), Loc),
3349 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3353 ------------------------------
3354 -- Check_Visibly_Controlled --
3355 ------------------------------
3357 procedure Check_Visibly_Controlled
3358 (Prim : Final_Primitives;
3360 E : in out Entity_Id;
3361 Cref : in out Node_Id)
3363 Parent_Type : Entity_Id;
3367 if Is_Derived_Type (Typ)
3368 and then Comes_From_Source (E)
3369 and then not Present (Overridden_Operation (E))
3371 -- We know that the explicit operation on the type does not override
3372 -- the inherited operation of the parent, and that the derivation
3373 -- is from a private type that is not visibly controlled.
3375 Parent_Type := Etype (Typ);
3376 Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3378 if Present (Op) then
3381 -- Wrap the object to be initialized into the proper
3382 -- unchecked conversion, to be compatible with the operation
3385 if Nkind (Cref) = N_Unchecked_Type_Conversion then
3386 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3388 Cref := Unchecked_Convert_To (Parent_Type, Cref);
3392 end Check_Visibly_Controlled;
3394 -------------------------------
3395 -- CW_Or_Has_Controlled_Part --
3396 -------------------------------
3398 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3400 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3401 end CW_Or_Has_Controlled_Part;
3407 function Convert_View
3410 Ind : Pos := 1) return Node_Id
3412 Fent : Entity_Id := First_Entity (Proc);
3417 for J in 2 .. Ind loop
3421 Ftyp := Etype (Fent);
3423 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3424 Atyp := Entity (Subtype_Mark (Arg));
3426 Atyp := Etype (Arg);
3429 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3430 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3433 and then Present (Atyp)
3434 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3435 and then Base_Type (Underlying_Type (Atyp)) =
3436 Base_Type (Underlying_Type (Ftyp))
3438 return Unchecked_Convert_To (Ftyp, Arg);
3440 -- If the argument is already a conversion, as generated by
3441 -- Make_Init_Call, set the target type to the type of the formal
3442 -- directly, to avoid spurious typing problems.
3444 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3445 and then not Is_Class_Wide_Type (Atyp)
3447 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3448 Set_Etype (Arg, Ftyp);
3456 ------------------------
3457 -- Enclosing_Function --
3458 ------------------------
3460 function Enclosing_Function (E : Entity_Id) return Entity_Id is
3461 Func_Id : Entity_Id;
3465 while Present (Func_Id)
3466 and then Func_Id /= Standard_Standard
3468 if Ekind (Func_Id) = E_Function then
3472 Func_Id := Scope (Func_Id);
3476 end Enclosing_Function;
3478 -------------------------------
3479 -- Establish_Transient_Scope --
3480 -------------------------------
3482 -- This procedure is called each time a transient block has to be inserted
3483 -- that is to say for each call to a function with unconstrained or tagged
3484 -- result. It creates a new scope on the stack scope in order to enclose
3485 -- all transient variables generated
3487 procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3488 Loc : constant Source_Ptr := Sloc (N);
3489 Wrap_Node : Node_Id;
3492 -- Do not create a transient scope if we are already inside one
3494 for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3495 if Scope_Stack.Table (S).Is_Transient then
3497 Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3502 -- If we have encountered Standard there are no enclosing
3503 -- transient scopes.
3505 elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3510 Wrap_Node := Find_Node_To_Be_Wrapped (N);
3512 -- Case of no wrap node, false alert, no transient scope needed
3514 if No (Wrap_Node) then
3517 -- If the node to wrap is an iteration_scheme, the expression is
3518 -- one of the bounds, and the expansion will make an explicit
3519 -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3520 -- so do not apply any transformations here.
3522 elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
3526 Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3527 Set_Scope_Is_Transient;
3530 Set_Uses_Sec_Stack (Current_Scope);
3531 Check_Restriction (No_Secondary_Stack, N);
3534 Set_Etype (Current_Scope, Standard_Void_Type);
3535 Set_Node_To_Be_Wrapped (Wrap_Node);
3537 if Debug_Flag_W then
3538 Write_Str (" <Transient>");
3542 end Establish_Transient_Scope;
3544 ----------------------------
3545 -- Expand_Cleanup_Actions --
3546 ----------------------------
3548 procedure Expand_Cleanup_Actions (N : Node_Id) is
3549 Scop : constant Entity_Id := Current_Scope;
3551 Is_Asynchronous_Call : constant Boolean :=
3552 Nkind (N) = N_Block_Statement
3553 and then Is_Asynchronous_Call_Block (N);
3554 Is_Master : constant Boolean :=
3555 Nkind (N) /= N_Entry_Body
3556 and then Is_Task_Master (N);
3557 Is_Protected_Body : constant Boolean :=
3558 Nkind (N) = N_Subprogram_Body
3559 and then Is_Protected_Subprogram_Body (N);
3560 Is_Task_Allocation : constant Boolean :=
3561 Nkind (N) = N_Block_Statement
3562 and then Is_Task_Allocation_Block (N);
3563 Is_Task_Body : constant Boolean :=
3564 Nkind (Original_Node (N)) = N_Task_Body;
3565 Needs_Sec_Stack_Mark : constant Boolean :=
3566 Uses_Sec_Stack (Scop)
3568 not Sec_Stack_Needed_For_Return (Scop)
3569 and then VM_Target = No_VM;
3571 Actions_Required : constant Boolean :=
3572 Requires_Cleanup_Actions (N)
3573 or else Is_Asynchronous_Call
3575 or else Is_Protected_Body
3576 or else Is_Task_Allocation
3577 or else Is_Task_Body
3578 or else Needs_Sec_Stack_Mark;
3580 HSS : Node_Id := Handled_Statement_Sequence (N);
3583 procedure Wrap_HSS_In_Block;
3584 -- Move HSS inside a new block along with the original exception
3585 -- handlers. Make the newly generated block the sole statement of HSS.
3587 -----------------------
3588 -- Wrap_HSS_In_Block --
3589 -----------------------
3591 procedure Wrap_HSS_In_Block is
3596 -- Preserve end label to provide proper cross-reference information
3598 End_Lab := End_Label (HSS);
3600 Make_Block_Statement (Loc,
3601 Handled_Statement_Sequence => HSS);
3603 Set_Handled_Statement_Sequence (N,
3604 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3605 HSS := Handled_Statement_Sequence (N);
3607 Set_First_Real_Statement (HSS, Block);
3608 Set_End_Label (HSS, End_Lab);
3610 -- Comment needed here, see RH for 1.306 ???
3612 if Nkind (N) = N_Subprogram_Body then
3613 Set_Has_Nested_Block_With_Handler (Scop);
3615 end Wrap_HSS_In_Block;
3617 -- Start of processing for Expand_Cleanup_Actions
3620 -- The current construct does not need any form of servicing
3622 if not Actions_Required then
3625 -- If the current node is a rewritten task body and the descriptors have
3626 -- not been delayed (due to some nested instantiations), do not generate
3627 -- redundant cleanup actions.
3630 and then Nkind (N) = N_Subprogram_Body
3631 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3637 Decls : List_Id := Declarations (N);
3639 Mark : Entity_Id := Empty;
3640 New_Decls : List_Id;
3644 -- If we are generating expanded code for debugging purposes, use the
3645 -- Sloc of the point of insertion for the cleanup code. The Sloc will
3646 -- be updated subsequently to reference the proper line in .dg files.
3647 -- If we are not debugging generated code, use No_Location instead,
3648 -- so that no debug information is generated for the cleanup code.
3649 -- This makes the behavior of the NEXT command in GDB monotonic, and
3650 -- makes the placement of breakpoints more accurate.
3652 if Debug_Generated_Code then
3658 -- Set polling off. The finalization and cleanup code is executed
3659 -- with aborts deferred.
3661 Old_Poll := Polling_Required;
3662 Polling_Required := False;
3664 -- A task activation call has already been built for a task
3665 -- allocation block.
3667 if not Is_Task_Allocation then
3668 Build_Task_Activation_Call (N);
3672 Establish_Task_Master (N);
3675 New_Decls := New_List;
3677 -- If secondary stack is in use, generate:
3679 -- Mnn : constant Mark_Id := SS_Mark;
3681 -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3682 -- secondary stack is never used on a VM.
3684 if Needs_Sec_Stack_Mark then
3685 Mark := Make_Temporary (Loc, 'M');
3687 Append_To (New_Decls,
3688 Make_Object_Declaration (Loc,
3689 Defining_Identifier => Mark,
3690 Object_Definition =>
3691 New_Reference_To (RTE (RE_Mark_Id), Loc),
3693 Make_Function_Call (Loc,
3694 Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
3696 Set_Uses_Sec_Stack (Scop, False);
3699 -- If exception handlers are present, wrap the sequence of statements
3700 -- in a block since it is not possible to have exception handlers and
3701 -- an At_End handler in the same construct.
3703 if Present (Exception_Handlers (HSS)) then
3706 -- Ensure that the First_Real_Statement field is set
3708 elsif No (First_Real_Statement (HSS)) then
3709 Set_First_Real_Statement (HSS, First (Statements (HSS)));
3712 -- Do not move the Activation_Chain declaration in the context of
3713 -- task allocation blocks. Task allocation blocks use _chain in their
3714 -- cleanup handlers and gigi complains if it is declared in the
3715 -- sequence of statements of the scope that declares the handler.
3717 if Is_Task_Allocation then
3719 Chain : constant Entity_Id := Activation_Chain_Entity (N);
3723 Decl := First (Decls);
3724 while Nkind (Decl) /= N_Object_Declaration
3725 or else Defining_Identifier (Decl) /= Chain
3729 -- A task allocation block should always include a _chain
3732 pragma Assert (Present (Decl));
3736 Prepend_To (New_Decls, Decl);
3740 -- Ensure the presence of a declaration list in order to successfully
3741 -- append all original statements to it.
3744 Set_Declarations (N, New_List);
3745 Decls := Declarations (N);
3748 -- Move the declarations into the sequence of statements in order to
3749 -- have them protected by the At_End handler. It may seem weird to
3750 -- put declarations in the sequence of statement but in fact nothing
3751 -- forbids that at the tree level.
3753 Append_List_To (Decls, Statements (HSS));
3754 Set_Statements (HSS, Decls);
3756 -- Reset the Sloc of the handled statement sequence to properly
3757 -- reflect the new initial "statement" in the sequence.
3759 Set_Sloc (HSS, Sloc (First (Decls)));
3761 -- The declarations of finalizer spec and auxiliary variables replace
3762 -- the old declarations that have been moved inward.
3764 Set_Declarations (N, New_Decls);
3765 Analyze_Declarations (New_Decls);
3767 -- Generate finalization calls for all controlled objects appearing
3768 -- in the statements of N. Add context specific cleanup for various
3773 Clean_Stmts => Build_Cleanup_Statements (N),
3775 Top_Decls => New_Decls,
3776 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
3780 if Present (Fin_Id) then
3781 Build_Finalizer_Call (N, Fin_Id);
3784 -- Restore saved polling mode
3786 Polling_Required := Old_Poll;
3788 end Expand_Cleanup_Actions;
3790 ---------------------------
3791 -- Expand_N_Package_Body --
3792 ---------------------------
3794 -- Add call to Activate_Tasks if body is an activator (actual processing
3795 -- is in chapter 9).
3797 -- Generate subprogram descriptor for elaboration routine
3799 -- Encode entity names in package body
3801 procedure Expand_N_Package_Body (N : Node_Id) is
3802 Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
3806 -- This is done only for non-generic packages
3808 if Ekind (Spec_Ent) = E_Package then
3809 Push_Scope (Corresponding_Spec (N));
3811 -- Build dispatch tables of library level tagged types
3813 if Is_Library_Level_Entity (Spec_Ent) then
3814 if Tagged_Type_Expansion then
3815 Build_Static_Dispatch_Tables (N);
3817 -- In VM targets there is no need to build dispatch tables but
3818 -- we must generate the corresponding Type Specific Data record.
3820 elsif Unit (Cunit (Main_Unit)) = N then
3822 -- If the runtime package Ada_Tags has not been loaded then
3823 -- this package does not have tagged type declarations and
3824 -- there is no need to search for tagged types to generate
3827 if RTU_Loaded (Ada_Tags) then
3833 Build_Task_Activation_Call (N);
3837 Set_Elaboration_Flag (N, Corresponding_Spec (N));
3838 Set_In_Package_Body (Spec_Ent, False);
3840 -- Set to encode entity names in package body before gigi is called
3842 Qualify_Entity_Names (N);
3844 if Ekind (Spec_Ent) /= E_Generic_Package then
3847 Clean_Stmts => Build_Cleanup_Statements (N),
3849 Top_Decls => No_List,
3850 Defer_Abort => False,
3853 if Present (Fin_Id) then
3855 Body_Ent : Node_Id := Defining_Unit_Name (N);
3858 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
3859 Body_Ent := Defining_Identifier (Body_Ent);
3862 Set_Finalizer (Body_Ent, Fin_Id);
3866 end Expand_N_Package_Body;
3868 ----------------------------------
3869 -- Expand_N_Package_Declaration --
3870 ----------------------------------
3872 -- Add call to Activate_Tasks if there are tasks declared and the package
3873 -- has no body. Note that in Ada83, this may result in premature activation
3874 -- of some tasks, given that we cannot tell whether a body will eventually
3877 procedure Expand_N_Package_Declaration (N : Node_Id) is
3878 Id : constant Entity_Id := Defining_Entity (N);
3879 Spec : constant Node_Id := Specification (N);
3883 No_Body : Boolean := False;
3884 -- True in the case of a package declaration that is a compilation
3885 -- unit and for which no associated body will be compiled in this
3889 -- Case of a package declaration other than a compilation unit
3891 if Nkind (Parent (N)) /= N_Compilation_Unit then
3894 -- Case of a compilation unit that does not require a body
3896 elsif not Body_Required (Parent (N))
3897 and then not Unit_Requires_Body (Id)
3901 -- Special case of generating calling stubs for a remote call interface
3902 -- package: even though the package declaration requires one, the body
3903 -- won't be processed in this compilation (so any stubs for RACWs
3904 -- declared in the package must be generated here, along with the spec).
3906 elsif Parent (N) = Cunit (Main_Unit)
3907 and then Is_Remote_Call_Interface (Id)
3908 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
3913 -- For a package declaration that implies no associated body, generate
3914 -- task activation call and RACW supporting bodies now (since we won't
3915 -- have a specific separate compilation unit for that).
3920 if Has_RACW (Id) then
3922 -- Generate RACW subprogram bodies
3924 Decls := Private_Declarations (Spec);
3927 Decls := Visible_Declarations (Spec);
3932 Set_Visible_Declarations (Spec, Decls);
3935 Append_RACW_Bodies (Decls, Id);
3936 Analyze_List (Decls);
3939 if Present (Activation_Chain_Entity (N)) then
3941 -- Generate task activation call as last step of elaboration
3943 Build_Task_Activation_Call (N);
3949 -- Build dispatch tables of library level tagged types
3951 if Is_Compilation_Unit (Id)
3952 or else (Is_Generic_Instance (Id)
3953 and then Is_Library_Level_Entity (Id))
3955 if Tagged_Type_Expansion then
3956 Build_Static_Dispatch_Tables (N);
3958 -- In VM targets there is no need to build dispatch tables, but we
3959 -- must generate the corresponding Type Specific Data record.
3961 elsif Unit (Cunit (Main_Unit)) = N then
3963 -- If the runtime package Ada_Tags has not been loaded then
3964 -- this package does not have tagged types and there is no need
3965 -- to search for tagged types to generate their TSDs.
3967 if RTU_Loaded (Ada_Tags) then
3969 -- Enter the scope of the package because the new declarations
3970 -- are appended at the end of the package and must be analyzed
3975 if Is_Generic_Instance (Main_Unit_Entity) then
3976 if Package_Instantiation (Main_Unit_Entity) = N then
3989 -- Note: it is not necessary to worry about generating a subprogram
3990 -- descriptor, since the only way to get exception handlers into a
3991 -- package spec is to include instantiations, and that would cause
3992 -- generation of subprogram descriptors to be delayed in any case.
3994 -- Set to encode entity names in package spec before gigi is called
3996 Qualify_Entity_Names (N);
3998 if Ekind (Id) /= E_Generic_Package then
4001 Clean_Stmts => Build_Cleanup_Statements (N),
4003 Top_Decls => No_List,
4004 Defer_Abort => False,
4007 Set_Finalizer (Id, Fin_Id);
4009 end Expand_N_Package_Declaration;
4011 -----------------------------
4012 -- Find_Node_To_Be_Wrapped --
4013 -----------------------------
4015 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
4017 The_Parent : Node_Id;
4023 pragma Assert (P /= Empty);
4024 The_Parent := Parent (P);
4026 case Nkind (The_Parent) is
4028 -- Simple statement can be wrapped
4033 -- Usually assignments are good candidate for wrapping
4034 -- except when they have been generated as part of a
4035 -- controlled aggregate where the wrapping should take
4036 -- place more globally.
4038 when N_Assignment_Statement =>
4039 if No_Ctrl_Actions (The_Parent) then
4045 -- An entry call statement is a special case if it occurs in
4046 -- the context of a Timed_Entry_Call. In this case we wrap
4047 -- the entire timed entry call.
4049 when N_Entry_Call_Statement |
4050 N_Procedure_Call_Statement =>
4051 if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
4052 and then Nkind_In (Parent (Parent (The_Parent)),
4054 N_Conditional_Entry_Call)
4056 return Parent (Parent (The_Parent));
4061 -- Object declarations are also a boundary for the transient scope
4062 -- even if they are not really wrapped
4063 -- (see Wrap_Transient_Declaration)
4065 when N_Object_Declaration |
4066 N_Object_Renaming_Declaration |
4067 N_Subtype_Declaration =>
4070 -- The expression itself is to be wrapped if its parent is a
4071 -- compound statement or any other statement where the expression
4072 -- is known to be scalar
4074 when N_Accept_Alternative |
4075 N_Attribute_Definition_Clause |
4078 N_Delay_Alternative |
4079 N_Delay_Until_Statement |
4080 N_Delay_Relative_Statement |
4081 N_Discriminant_Association |
4083 N_Entry_Body_Formal_Part |
4086 N_Iteration_Scheme |
4087 N_Terminate_Alternative =>
4090 when N_Attribute_Reference =>
4092 if Is_Procedure_Attribute_Name
4093 (Attribute_Name (The_Parent))
4098 -- A raise statement can be wrapped. This will arise when the
4099 -- expression in a raise_with_expression uses the secondary
4100 -- stack, for example.
4102 when N_Raise_Statement =>
4105 -- If the expression is within the iteration scheme of a loop,
4106 -- we must create a declaration for it, followed by an assignment
4107 -- in order to have a usable statement to wrap.
4109 when N_Loop_Parameter_Specification =>
4110 return Parent (The_Parent);
4112 -- The following nodes contains "dummy calls" which don't
4113 -- need to be wrapped.
4115 when N_Parameter_Specification |
4116 N_Discriminant_Specification |
4117 N_Component_Declaration =>
4120 -- The return statement is not to be wrapped when the function
4121 -- itself needs wrapping at the outer-level
4123 when N_Simple_Return_Statement =>
4125 Applies_To : constant Entity_Id :=
4127 (Return_Statement_Entity (The_Parent));
4128 Return_Type : constant Entity_Id := Etype (Applies_To);
4130 if Requires_Transient_Scope (Return_Type) then
4137 -- If we leave a scope without having been able to find a node to
4138 -- wrap, something is going wrong but this can happen in error
4139 -- situation that are not detected yet (such as a dynamic string
4140 -- in a pragma export)
4142 when N_Subprogram_Body |
4143 N_Package_Declaration |
4145 N_Block_Statement =>
4148 -- otherwise continue the search
4154 end Find_Node_To_Be_Wrapped;
4156 -------------------------------------
4157 -- Get_Global_Pool_For_Access_Type --
4158 -------------------------------------
4160 function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
4162 -- Access types whose size is smaller than System.Address size can
4163 -- exist only on VMS. We can't use the usual global pool which returns
4164 -- an object of type Address as truncation will make it invalid.
4165 -- To handle this case, VMS has a dedicated global pool that returns
4166 -- addresses that fit into 32 bit accesses.
4168 if Opt.True_VMS_Target and then Esize (T) = 32 then
4169 return RTE (RE_Global_Pool_32_Object);
4171 return RTE (RE_Global_Pool_Object);
4173 end Get_Global_Pool_For_Access_Type;
4175 ----------------------------------
4176 -- Has_New_Controlled_Component --
4177 ----------------------------------
4179 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4183 if not Is_Tagged_Type (E) then
4184 return Has_Controlled_Component (E);
4185 elsif not Is_Derived_Type (E) then
4186 return Has_Controlled_Component (E);
4189 Comp := First_Component (E);
4190 while Present (Comp) loop
4191 if Chars (Comp) = Name_uParent then
4194 elsif Scope (Original_Record_Component (Comp)) = E
4195 and then Needs_Finalization (Etype (Comp))
4200 Next_Component (Comp);
4204 end Has_New_Controlled_Component;
4206 ---------------------------------
4207 -- Has_Simple_Protected_Object --
4208 ---------------------------------
4210 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
4212 if Has_Task (T) then
4215 elsif Is_Simple_Protected_Type (T) then
4218 elsif Is_Array_Type (T) then
4219 return Has_Simple_Protected_Object (Component_Type (T));
4221 elsif Is_Record_Type (T) then
4226 Comp := First_Component (T);
4227 while Present (Comp) loop
4228 if Has_Simple_Protected_Object (Etype (Comp)) then
4232 Next_Component (Comp);
4241 end Has_Simple_Protected_Object;
4243 ------------------------------------
4244 -- Insert_Actions_In_Scope_Around --
4245 ------------------------------------
4247 procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
4248 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
4249 After : List_Id renames SE.Actions_To_Be_Wrapped_After;
4250 Before : List_Id renames SE.Actions_To_Be_Wrapped_Before;
4252 procedure Process_Transient_Objects
4253 (First_Object : Node_Id;
4254 Last_Object : Node_Id;
4255 Related_Node : Node_Id);
4256 -- First_Object and Last_Object define a list which contains potential
4257 -- controlled transient objects. Finalization flags are inserted before
4258 -- First_Object and finalization calls are inserted after Last_Object.
4259 -- Related_Node is the node for which transient objects have been
4262 -------------------------------
4263 -- Process_Transient_Objects --
4264 -------------------------------
4266 procedure Process_Transient_Objects
4267 (First_Object : Node_Id;
4268 Last_Object : Node_Id;
4269 Related_Node : Node_Id)
4271 Abort_Id : Entity_Id;
4272 Built : Boolean := False;
4275 Fin_Block : Node_Id;
4276 Last_Fin : Node_Id := Empty;
4280 Obj_Typ : Entity_Id;
4281 Raised_Id : Entity_Id;
4285 -- Examine all objects in the list First_Object .. Last_Object
4287 Stmt := First_Object;
4288 while Present (Stmt) loop
4289 if Nkind (Stmt) = N_Object_Declaration
4290 and then Analyzed (Stmt)
4291 and then Is_Finalizable_Transient (Stmt, N)
4293 -- Do not process the node to be wrapped since it will be
4294 -- handled by the enclosing finalizer.
4296 and then Stmt /= Related_Node
4299 Obj_Id := Defining_Identifier (Stmt);
4300 Obj_Typ := Base_Type (Etype (Obj_Id));
4303 Set_Is_Processed_Transient (Obj_Id);
4305 -- Handle access types
4307 if Is_Access_Type (Desig) then
4308 Desig := Available_View (Designated_Type (Desig));
4311 -- Create the necessary entities and declarations the first
4315 Abort_Id := Make_Temporary (Loc, 'A');
4316 E_Id := Make_Temporary (Loc, 'E');
4317 Raised_Id := Make_Temporary (Loc, 'R');
4319 Insert_List_Before_And_Analyze (First_Object,
4320 Build_Object_Declarations
4321 (Loc, Abort_Id, E_Id, Raised_Id));
4328 -- [Deep_]Finalize (Obj_Ref);
4335 -- (Enn, Get_Current_Excep.all.all);
4339 Obj_Ref := New_Reference_To (Obj_Id, Loc);
4341 if Is_Access_Type (Obj_Typ) then
4342 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4346 Make_Block_Statement (Loc,
4347 Handled_Statement_Sequence =>
4348 Make_Handled_Sequence_Of_Statements (Loc,
4349 Statements => New_List (
4351 (Obj_Ref => Obj_Ref,
4354 Exception_Handlers => New_List (
4355 Build_Exception_Handler (Loc, E_Id, Raised_Id))));
4356 Insert_After_And_Analyze (Last_Object, Fin_Block);
4358 -- The raise statement must be inserted after all the
4359 -- finalization blocks.
4361 if No (Last_Fin) then
4362 Last_Fin := Fin_Block;
4365 -- When the associated node is an array object, the expander may
4366 -- sometimes generate a loop and create transient objects inside
4369 elsif Nkind (Stmt) = N_Loop_Statement then
4370 Process_Transient_Objects
4371 (First_Object => First (Statements (Stmt)),
4372 Last_Object => Last (Statements (Stmt)),
4373 Related_Node => Related_Node);
4375 -- Terminate the scan after the last object has been processed
4377 elsif Stmt = Last_Object then
4386 -- Raise_From_Controlled_Operation (E, Abort);
4390 and then Present (Last_Fin)
4392 Insert_After_And_Analyze (Last_Fin,
4393 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
4395 end Process_Transient_Objects;
4397 -- Start of processing for Insert_Actions_In_Scope_Around
4400 if No (Before) and then No (After) then
4405 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
4406 First_Obj : Node_Id;
4411 -- If the node to be wrapped is the trigger of an asynchronous
4412 -- select, it is not part of a statement list. The actions must be
4413 -- inserted before the select itself, which is part of some list of
4414 -- statements. Note that the triggering alternative includes the
4415 -- triggering statement and an optional statement list. If the node
4416 -- to be wrapped is part of that list, the normal insertion applies.
4418 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
4419 and then not Is_List_Member (Node_To_Wrap)
4421 Target := Parent (Parent (Node_To_Wrap));
4426 First_Obj := Target;
4429 -- Add all actions associated with a transient scope into the main
4430 -- tree. There are several scenarios here:
4432 -- +--- Before ----+ +----- After ---+
4433 -- 1) First_Obj ....... Target ........ Last_Obj
4435 -- 2) First_Obj ....... Target
4437 -- 3) Target ........ Last_Obj
4439 if Present (Before) then
4441 -- Flag declarations are inserted before the first object
4443 First_Obj := First (Before);
4445 Insert_List_Before (Target, Before);
4448 if Present (After) then
4450 -- Finalization calls are inserted after the last object
4452 Last_Obj := Last (After);
4454 Insert_List_After (Target, After);
4457 -- Check for transient controlled objects associated with Target and
4458 -- generate the appropriate finalization actions for them.
4460 Process_Transient_Objects
4461 (First_Object => First_Obj,
4462 Last_Object => Last_Obj,
4463 Related_Node => Target);
4465 -- Reset the action lists
4467 if Present (Before) then
4471 if Present (After) then
4475 end Insert_Actions_In_Scope_Around;
4477 ------------------------------
4478 -- Is_Simple_Protected_Type --
4479 ------------------------------
4481 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
4484 Is_Protected_Type (T)
4485 and then not Has_Entries (T)
4486 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
4487 end Is_Simple_Protected_Type;
4489 -----------------------
4490 -- Make_Adjust_Call --
4491 -----------------------
4493 function Make_Adjust_Call
4496 For_Parent : Boolean := False) return Node_Id
4498 Loc : constant Source_Ptr := Sloc (Obj_Ref);
4499 Adj_Id : Entity_Id := Empty;
4500 Ref : Node_Id := Obj_Ref;
4504 -- Recover the proper type which contains Deep_Adjust
4506 if Is_Class_Wide_Type (Typ) then
4507 Utyp := Root_Type (Typ);
4512 Utyp := Underlying_Type (Base_Type (Utyp));
4513 Set_Assignment_OK (Ref);
4515 -- Deal with non-tagged derivation of private views
4517 if Is_Untagged_Derivation (Typ) then
4518 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
4519 Ref := Unchecked_Convert_To (Utyp, Ref);
4520 Set_Assignment_OK (Ref);
4523 -- When dealing with the completion of a private type, use the base
4526 if Utyp /= Base_Type (Utyp) then
4527 pragma Assert (Is_Private_Type (Typ));
4529 Utyp := Base_Type (Utyp);
4530 Ref := Unchecked_Convert_To (Utyp, Ref);
4533 -- Select the appropriate version of adjust
4536 if Has_Controlled_Component (Utyp) then
4537 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4540 -- For types that are both controlled and have controlled components,
4541 -- generate a call to Deep_Adjust.
4543 elsif Is_Controlled (Utyp)
4544 and then Has_Controlled_Component (Utyp)
4546 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4548 -- For types that are not controlled themselves, but contain controlled
4549 -- components or can be extended by types with controlled components,
4550 -- create a call to Deep_Adjust.
4552 elsif Is_Class_Wide_Type (Typ)
4553 or else Has_Controlled_Component (Utyp)
4555 if Is_Tagged_Type (Utyp) then
4556 Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4558 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
4561 -- For types that are derived from Controlled and do not have controlled
4562 -- components, build a call to Adjust.
4565 Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
4568 if Present (Adj_Id) then
4570 -- If the object is unanalyzed, set its expected type for use in
4571 -- Convert_View in case an additional conversion is needed.
4574 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
4576 Set_Etype (Ref, Typ);
4579 -- The object reference may need another conversion depending on the
4580 -- type of the formal and that of the actual.
4582 if not Is_Class_Wide_Type (Typ) then
4583 Ref := Convert_View (Adj_Id, Ref);
4586 return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
4590 end Make_Adjust_Call;
4592 ----------------------
4593 -- Make_Attach_Call --
4594 ----------------------
4596 function Make_Attach_Call
4598 Ptr_Typ : Entity_Id) return Node_Id
4600 Loc : constant Source_Ptr := Sloc (Obj_Ref);
4603 Make_Procedure_Call_Statement (Loc,
4605 New_Reference_To (RTE (RE_Attach), Loc),
4606 Parameter_Associations => New_List (
4607 New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
4608 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4609 end Make_Attach_Call;
4611 ----------------------
4612 -- Make_Detach_Call --
4613 ----------------------
4615 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
4616 Loc : constant Source_Ptr := Sloc (Obj_Ref);
4620 Make_Procedure_Call_Statement (Loc,
4622 New_Reference_To (RTE (RE_Detach), Loc),
4623 Parameter_Associations => New_List (
4624 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4625 end Make_Detach_Call;
4633 Proc_Id : Entity_Id;
4635 For_Parent : Boolean := False) return Node_Id
4637 Params : constant List_Id := New_List (Param);
4640 -- When creating a call to Deep_Finalize for a _parent field of a
4641 -- derived type, disable the invocation of the nested Finalize by giving
4642 -- the corresponding flag a False value.
4645 Append_To (Params, New_Reference_To (Standard_False, Loc));
4649 Make_Procedure_Call_Statement (Loc,
4650 Name => New_Reference_To (Proc_Id, Loc),
4651 Parameter_Associations => Params);
4654 --------------------------
4655 -- Make_Deep_Array_Body --
4656 --------------------------
4658 function Make_Deep_Array_Body
4659 (Prim : Final_Primitives;
4660 Typ : Entity_Id) return List_Id
4662 function Build_Adjust_Or_Finalize_Statements
4663 (Typ : Entity_Id) return List_Id;
4664 -- Create the statements necessary to adjust or finalize an array of
4665 -- controlled elements. Generate:
4668 -- Temp : constant Exception_Occurrence_Access :=
4669 -- Get_Current_Excep.all;
4670 -- Abort : constant Boolean :=
4672 -- and then Exception_Identity (Temp_Id.all) =
4673 -- Standard'Abort_Signal'Identity;
4675 -- Abort : constant Boolean := False; -- no abort
4677 -- E : Exception_Occurrence;
4678 -- Raised : Boolean := False;
4681 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4682 -- ^-- in the finalization case
4684 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4686 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4690 -- if not Raised then
4692 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4700 -- Raise_From_Controlled_Operation (E, Abort);
4704 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
4705 -- Create the statements necessary to initialize an array of controlled
4706 -- elements. Include a mechanism to carry out partial finalization if an
4707 -- exception occurs. Generate:
4710 -- Counter : Integer := 0;
4713 -- for J1 in V'Range (1) loop
4715 -- for JN in V'Range (N) loop
4717 -- [Deep_]Initialize (V (J1, ..., JN));
4719 -- Counter := Counter + 1;
4724 -- Temp : constant Exception_Occurrence_Access :=
4725 -- Get_Current_Excep.all;
4726 -- Abort : constant Boolean :=
4728 -- and then Exception_Identity (Temp_Id.all) =
4729 -- Standard'Abort_Signal'Identity;
4731 -- Abort : constant Boolean := False; -- no abort
4732 -- E : Exception_Occurence;
4733 -- Raised : Boolean := False;
4740 -- V'Length (N) - Counter;
4742 -- for F1 in reverse V'Range (1) loop
4744 -- for FN in reverse V'Range (N) loop
4745 -- if Counter > 0 then
4746 -- Counter := Counter - 1;
4749 -- [Deep_]Finalize (V (F1, ..., FN));
4753 -- if not Raised then
4755 -- Save_Occurrence (E,
4756 -- Get_Current_Excep.all.all);
4766 -- Raise_From_Controlled_Operation (E, Abort);
4775 function New_References_To
4777 Loc : Source_Ptr) return List_Id;
4778 -- Given a list of defining identifiers, return a list of references to
4779 -- the original identifiers, in the same order as they appear.
4781 -----------------------------------------
4782 -- Build_Adjust_Or_Finalize_Statements --
4783 -----------------------------------------
4785 function Build_Adjust_Or_Finalize_Statements
4786 (Typ : Entity_Id) return List_Id
4788 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4789 Index_List : constant List_Id := New_List;
4790 Loc : constant Source_Ptr := Sloc (Typ);
4791 Num_Dims : constant Int := Number_Dimensions (Typ);
4792 Abort_Id : Entity_Id := Empty;
4795 Core_Loop : Node_Id;
4797 E_Id : Entity_Id := Empty;
4799 Loop_Id : Entity_Id;
4800 Raised_Id : Entity_Id := Empty;
4803 Exceptions_OK : constant Boolean :=
4804 not Restriction_Active (No_Exception_Propagation);
4806 procedure Build_Indices;
4807 -- Generate the indices used in the dimension loops
4813 procedure Build_Indices is
4815 -- Generate the following identifiers:
4816 -- Jnn - for initialization
4818 for Dim in 1 .. Num_Dims loop
4819 Append_To (Index_List,
4820 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
4824 -- Start of processing for Build_Adjust_Or_Finalize_Statements
4829 if Exceptions_OK then
4830 Abort_Id := Make_Temporary (Loc, 'A');
4831 E_Id := Make_Temporary (Loc, 'E');
4832 Raised_Id := Make_Temporary (Loc, 'R');
4836 Make_Indexed_Component (Loc,
4837 Prefix => Make_Identifier (Loc, Name_V),
4838 Expressions => New_References_To (Index_List, Loc));
4839 Set_Etype (Comp_Ref, Comp_Typ);
4842 -- [Deep_]Adjust (V (J1, ..., JN))
4844 if Prim = Adjust_Case then
4845 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
4848 -- [Deep_]Finalize (V (J1, ..., JN))
4850 else pragma Assert (Prim = Finalize_Case);
4851 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
4854 -- Generate the block which houses the adjust or finalize call:
4856 -- <adjust or finalize call>; -- No_Exception_Propagation
4858 -- begin -- Exception handlers allowed
4859 -- <adjust or finalize call>
4863 -- if not Raised then
4865 -- Save_Occurrence (E, Get_Current_Excep.all.all);
4869 if Exceptions_OK then
4871 Make_Block_Statement (Loc,
4872 Handled_Statement_Sequence =>
4873 Make_Handled_Sequence_Of_Statements (Loc,
4874 Statements => New_List (Call),
4875 Exception_Handlers => New_List (
4876 Build_Exception_Handler (Loc, E_Id, Raised_Id))));
4881 -- Generate the dimension loops starting from the innermost one
4883 -- for Jnn in [reverse] V'Range (Dim) loop
4887 J := Last (Index_List);
4889 while Present (J) and then Dim > 0 loop
4895 Make_Loop_Statement (Loc,
4897 Make_Iteration_Scheme (Loc,
4898 Loop_Parameter_Specification =>
4899 Make_Loop_Parameter_Specification (Loc,
4900 Defining_Identifier => Loop_Id,
4901 Discrete_Subtype_Definition =>
4902 Make_Attribute_Reference (Loc,
4903 Prefix => Make_Identifier (Loc, Name_V),
4904 Attribute_Name => Name_Range,
4905 Expressions => New_List (
4906 Make_Integer_Literal (Loc, Dim))),
4908 Reverse_Present => Prim = Finalize_Case)),
4910 Statements => New_List (Core_Loop),
4911 End_Label => Empty);
4916 -- Generate the block which contains the core loop, the declarations
4917 -- of the abort flag, the exception occurrence, the raised flag and
4918 -- the conditional raise:
4921 -- Abort : constant Boolean :=
4922 -- Exception_Occurrence (Get_Current_Excep.all.all) =
4923 -- Standard'Abort_Signal'Identity;
4925 -- Abort : constant Boolean := False; -- no abort
4927 -- E : Exception_Occurrence;
4928 -- Raised : Boolean := False;
4933 -- if Raised then -- Expection handlers allowed
4934 -- Raise_From_Controlled_Operation (E, Abort);
4938 Stmts := New_List (Core_Loop);
4940 if Exceptions_OK then
4942 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
4947 Make_Block_Statement (Loc,
4949 Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
4950 Handled_Statement_Sequence =>
4951 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
4952 end Build_Adjust_Or_Finalize_Statements;
4954 ---------------------------------
4955 -- Build_Initialize_Statements --
4956 ---------------------------------
4958 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
4959 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4960 Final_List : constant List_Id := New_List;
4961 Index_List : constant List_Id := New_List;
4962 Loc : constant Source_Ptr := Sloc (Typ);
4963 Num_Dims : constant Int := Number_Dimensions (Typ);
4964 Abort_Id : Entity_Id;
4965 Counter_Id : Entity_Id;
4967 E_Id : Entity_Id := Empty;
4970 Final_Block : Node_Id;
4971 Final_Loop : Node_Id;
4972 Init_Loop : Node_Id;
4975 Raised_Id : Entity_Id := Empty;
4978 Exceptions_OK : constant Boolean :=
4979 not Restriction_Active (No_Exception_Propagation);
4981 function Build_Counter_Assignment return Node_Id;
4982 -- Generate the following assignment:
4983 -- Counter := V'Length (1) *
4985 -- V'Length (N) - Counter;
4987 function Build_Finalization_Call return Node_Id;
4988 -- Generate a deep finalization call for an array element
4990 procedure Build_Indices;
4991 -- Generate the initialization and finalization indices used in the
4994 function Build_Initialization_Call return Node_Id;
4995 -- Generate a deep initialization call for an array element
4997 ------------------------------
4998 -- Build_Counter_Assignment --
4999 ------------------------------
5001 function Build_Counter_Assignment return Node_Id is
5006 -- Start from the first dimension and generate:
5011 Make_Attribute_Reference (Loc,
5012 Prefix => Make_Identifier (Loc, Name_V),
5013 Attribute_Name => Name_Length,
5014 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
5016 -- Process the rest of the dimensions, generate:
5017 -- Expr * V'Length (N)
5020 while Dim <= Num_Dims loop
5022 Make_Op_Multiply (Loc,
5025 Make_Attribute_Reference (Loc,
5026 Prefix => Make_Identifier (Loc, Name_V),
5027 Attribute_Name => Name_Length,
5028 Expressions => New_List (
5029 Make_Integer_Literal (Loc, Dim))));
5035 -- Counter := Expr - Counter;
5038 Make_Assignment_Statement (Loc,
5039 Name => New_Reference_To (Counter_Id, Loc),
5041 Make_Op_Subtract (Loc,
5043 Right_Opnd => New_Reference_To (Counter_Id, Loc)));
5044 end Build_Counter_Assignment;
5046 -----------------------------
5047 -- Build_Finalization_Call --
5048 -----------------------------
5050 function Build_Finalization_Call return Node_Id is
5051 Comp_Ref : constant Node_Id :=
5052 Make_Indexed_Component (Loc,
5053 Prefix => Make_Identifier (Loc, Name_V),
5054 Expressions => New_References_To (Final_List, Loc));
5057 Set_Etype (Comp_Ref, Comp_Typ);
5060 -- [Deep_]Finalize (V);
5062 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5063 end Build_Finalization_Call;
5069 procedure Build_Indices is
5071 -- Generate the following identifiers:
5072 -- Jnn - for initialization
5073 -- Fnn - for finalization
5075 for Dim in 1 .. Num_Dims loop
5076 Append_To (Index_List,
5077 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5079 Append_To (Final_List,
5080 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
5084 -------------------------------
5085 -- Build_Initialization_Call --
5086 -------------------------------
5088 function Build_Initialization_Call return Node_Id is
5089 Comp_Ref : constant Node_Id :=
5090 Make_Indexed_Component (Loc,
5091 Prefix => Make_Identifier (Loc, Name_V),
5092 Expressions => New_References_To (Index_List, Loc));
5095 Set_Etype (Comp_Ref, Comp_Typ);
5098 -- [Deep_]Initialize (V (J1, ..., JN));
5100 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5101 end Build_Initialization_Call;
5103 -- Start of processing for Build_Initialize_Statements
5108 Counter_Id := Make_Temporary (Loc, 'C');
5110 if Exceptions_OK then
5111 Abort_Id := Make_Temporary (Loc, 'A');
5112 E_Id := Make_Temporary (Loc, 'E');
5113 Raised_Id := Make_Temporary (Loc, 'R');
5116 -- Generate the block which houses the finalization call, the index
5117 -- guard and the handler which triggers Program_Error later on.
5119 -- if Counter > 0 then
5120 -- Counter := Counter - 1;
5122 -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation
5124 -- begin -- Exceptions allowed
5125 -- [Deep_]Finalize (V (F1, ..., FN));
5128 -- if not Raised then
5130 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5135 if Exceptions_OK then
5137 Make_Block_Statement (Loc,
5138 Handled_Statement_Sequence =>
5139 Make_Handled_Sequence_Of_Statements (Loc,
5140 Statements => New_List (Build_Finalization_Call),
5141 Exception_Handlers => New_List (
5142 Build_Exception_Handler (Loc, E_Id, Raised_Id))));
5144 Fin_Stmt := Build_Finalization_Call;
5147 -- This is the core of the loop, the dimension iterators are added
5148 -- one by one in reverse.
5151 Make_If_Statement (Loc,
5154 Left_Opnd => New_Reference_To (Counter_Id, Loc),
5155 Right_Opnd => Make_Integer_Literal (Loc, 0)),
5157 Then_Statements => New_List (
5158 Make_Assignment_Statement (Loc,
5159 Name => New_Reference_To (Counter_Id, Loc),
5161 Make_Op_Subtract (Loc,
5162 Left_Opnd => New_Reference_To (Counter_Id, Loc),
5163 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
5165 Else_Statements => New_List (Fin_Stmt));
5167 -- Generate all finalization loops starting from the innermost
5170 -- for Fnn in reverse V'Range (Dim) loop
5174 F := Last (Final_List);
5176 while Present (F) and then Dim > 0 loop
5182 Make_Loop_Statement (Loc,
5184 Make_Iteration_Scheme (Loc,
5185 Loop_Parameter_Specification =>
5186 Make_Loop_Parameter_Specification (Loc,
5187 Defining_Identifier => Loop_Id,
5188 Discrete_Subtype_Definition =>
5189 Make_Attribute_Reference (Loc,
5190 Prefix => Make_Identifier (Loc, Name_V),
5191 Attribute_Name => Name_Range,
5192 Expressions => New_List (
5193 Make_Integer_Literal (Loc, Dim))),
5195 Reverse_Present => True)),
5197 Statements => New_List (Final_Loop),
5198 End_Label => Empty);
5203 -- Generate the block which contains the finalization loops, the
5204 -- declarations of the abort flag, the exception occurrence, the
5205 -- raised flag and the conditional raise.
5208 -- Abort : constant Boolean :=
5209 -- Exception_Occurrence (Get_Current_Excep.all.all) =
5210 -- Standard'Abort_Signal'Identity;
5212 -- Abort : constant Boolean := False; -- no abort
5214 -- E : Exception_Occurrence;
5215 -- Raised : Boolean := False;
5221 -- V'Length (N) - Counter;
5225 -- if Raised then -- Exception handlers allowed
5226 -- Raise_From_Controlled_Operation (E, Abort);
5229 -- raise; -- Exception handlers allowed
5232 Stmts := New_List (Build_Counter_Assignment, Final_Loop);
5234 if Exceptions_OK then
5236 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
5237 Append_To (Stmts, Make_Raise_Statement (Loc));
5241 Make_Block_Statement (Loc,
5243 Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
5244 Handled_Statement_Sequence =>
5245 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
5247 -- Generate the block which contains the initialization call and
5248 -- the partial finalization code.
5251 -- [Deep_]Initialize (V (J1, ..., JN));
5253 -- Counter := Counter + 1;
5257 -- <finalization code>
5261 Make_Block_Statement (Loc,
5262 Handled_Statement_Sequence =>
5263 Make_Handled_Sequence_Of_Statements (Loc,
5264 Statements => New_List (Build_Initialization_Call),
5265 Exception_Handlers => New_List (
5266 Make_Exception_Handler (Loc,
5267 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5268 Statements => New_List (Final_Block)))));
5270 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
5271 Make_Assignment_Statement (Loc,
5272 Name => New_Reference_To (Counter_Id, Loc),
5275 Left_Opnd => New_Reference_To (Counter_Id, Loc),
5276 Right_Opnd => Make_Integer_Literal (Loc, 1))));
5278 -- Generate all initialization loops starting from the innermost
5281 -- for Jnn in V'Range (Dim) loop
5285 J := Last (Index_List);
5287 while Present (J) and then Dim > 0 loop
5293 Make_Loop_Statement (Loc,
5295 Make_Iteration_Scheme (Loc,
5296 Loop_Parameter_Specification =>
5297 Make_Loop_Parameter_Specification (Loc,
5298 Defining_Identifier => Loop_Id,
5299 Discrete_Subtype_Definition =>
5300 Make_Attribute_Reference (Loc,
5301 Prefix => Make_Identifier (Loc, Name_V),
5302 Attribute_Name => Name_Range,
5303 Expressions => New_List (
5304 Make_Integer_Literal (Loc, Dim))))),
5306 Statements => New_List (Init_Loop),
5307 End_Label => Empty);
5312 -- Generate the block which contains the counter variable and the
5313 -- initialization loops.
5316 -- Counter : Integer := 0;
5323 Make_Block_Statement (Loc,
5324 Declarations => New_List (
5325 Make_Object_Declaration (Loc,
5326 Defining_Identifier => Counter_Id,
5327 Object_Definition =>
5328 New_Reference_To (Standard_Integer, Loc),
5329 Expression => Make_Integer_Literal (Loc, 0))),
5331 Handled_Statement_Sequence =>
5332 Make_Handled_Sequence_Of_Statements (Loc,
5333 Statements => New_List (Init_Loop))));
5334 end Build_Initialize_Statements;
5336 -----------------------
5337 -- New_References_To --
5338 -----------------------
5340 function New_References_To
5342 Loc : Source_Ptr) return List_Id
5344 Refs : constant List_Id := New_List;
5349 while Present (Id) loop
5350 Append_To (Refs, New_Reference_To (Id, Loc));
5355 end New_References_To;
5357 -- Start of processing for Make_Deep_Array_Body
5361 when Address_Case =>
5362 return Make_Finalize_Address_Stmts (Typ);
5366 return Build_Adjust_Or_Finalize_Statements (Typ);
5368 when Initialize_Case =>
5369 return Build_Initialize_Statements (Typ);
5371 end Make_Deep_Array_Body;
5373 --------------------
5374 -- Make_Deep_Proc --
5375 --------------------
5377 function Make_Deep_Proc
5378 (Prim : Final_Primitives;
5380 Stmts : List_Id) return Entity_Id
5382 Loc : constant Source_Ptr := Sloc (Typ);
5384 Proc_Id : Entity_Id;
5387 -- Create the object formal, generate:
5388 -- V : System.Address
5390 if Prim = Address_Case then
5391 Formals := New_List (
5392 Make_Parameter_Specification (Loc,
5393 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5394 Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)));
5401 Formals := New_List (
5402 Make_Parameter_Specification (Loc,
5403 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5405 Out_Present => True,
5406 Parameter_Type => New_Reference_To (Typ, Loc)));
5408 -- F : Boolean := True
5410 if Prim = Adjust_Case
5411 or else Prim = Finalize_Case
5414 Make_Parameter_Specification (Loc,
5415 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
5417 New_Reference_To (Standard_Boolean, Loc),
5419 New_Reference_To (Standard_True, Loc)));
5424 Make_Defining_Identifier (Loc,
5425 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
5428 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5431 -- exception -- Finalize and Adjust cases only
5432 -- raise Program_Error;
5433 -- end Deep_Initialize / Adjust / Finalize;
5437 -- procedure Finalize_Address (V : System.Address) is
5440 -- end Finalize_Address;
5443 Make_Subprogram_Body (Loc,
5445 Make_Procedure_Specification (Loc,
5446 Defining_Unit_Name => Proc_Id,
5447 Parameter_Specifications => Formals),
5449 Declarations => Empty_List,
5451 Handled_Statement_Sequence =>
5452 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
5457 ---------------------------
5458 -- Make_Deep_Record_Body --
5459 ---------------------------
5461 function Make_Deep_Record_Body
5462 (Prim : Final_Primitives;
5464 Is_Local : Boolean := False) return List_Id
5466 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
5467 -- Build the statements necessary to adjust a record type. The type may
5468 -- have discriminants and contain variant parts. Generate:
5471 -- Root_Controlled (V).Finalized := False;
5474 -- [Deep_]Adjust (V.Comp_1);
5476 -- when Id : others =>
5477 -- if not Raised then
5479 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5484 -- [Deep_]Adjust (V.Comp_N);
5486 -- when Id : others =>
5487 -- if not Raised then
5489 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5494 -- Deep_Adjust (V._parent, False); -- If applicable
5496 -- when Id : others =>
5497 -- if not Raised then
5499 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5505 -- Adjust (V); -- If applicable
5508 -- if not Raised then
5510 -- Save_Occurence (E, Get_Current_Excep.all.all);
5516 -- Raise_From_Controlled_Object (E, Abort);
5520 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
5521 -- Build the statements necessary to finalize a record type. The type
5522 -- may have discriminants and contain variant parts. Generate:
5525 -- Temp : constant Exception_Occurrence_Access :=
5526 -- Get_Current_Excep.all;
5527 -- Abort : constant Boolean :=
5529 -- and then Exception_Identity (Temp_Id.all) =
5530 -- Standard'Abort_Signal'Identity;
5532 -- Abort : constant Boolean := False; -- no abort
5533 -- E : Exception_Occurence;
5534 -- Raised : Boolean := False;
5537 -- if Root_Controlled (V).Finalized then
5543 -- Finalize (V); -- If applicable
5546 -- if not Raised then
5548 -- Save_Occurence (E, Get_Current_Excep.all.all);
5553 -- case Variant_1 is
5555 -- case State_Counter_N => -- If Is_Local is enabled
5565 -- <<LN>> -- If Is_Local is enabled
5567 -- [Deep_]Finalize (V.Comp_N);
5570 -- if not Raised then
5572 -- Save_Occurence (E, Get_Current_Excep.all.all);
5578 -- [Deep_]Finalize (V.Comp_1);
5581 -- if not Raised then
5583 -- Save_Occurence (E, Get_Current_Excep.all.all);
5589 -- case State_Counter_1 => -- If Is_Local is enabled
5595 -- Deep_Finalize (V._parent, False); -- If applicable
5597 -- when Id : others =>
5598 -- if not Raised then
5600 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5604 -- Root_Controlled (V).Finalized := True;
5607 -- Raise_From_Controlled_Object (E, Abort);
5611 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
5612 -- Given a derived tagged type Typ, traverse all components, find field
5613 -- _parent and return its type.
5615 procedure Preprocess_Components
5617 Num_Comps : out Int;
5618 Has_POC : out Boolean);
5619 -- Examine all components in component list Comps, count all controlled
5620 -- components and determine whether at least one of them is per-object
5621 -- constrained. Component _parent is always skipped.
5623 -----------------------------
5624 -- Build_Adjust_Statements --
5625 -----------------------------
5627 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
5628 Loc : constant Source_Ptr := Sloc (Typ);
5629 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
5630 Abort_Id : Entity_Id := Empty;
5631 Bod_Stmts : List_Id;
5632 E_Id : Entity_Id := Empty;
5633 Raised_Id : Entity_Id := Empty;
5637 Exceptions_OK : constant Boolean :=
5638 not Restriction_Active (No_Exception_Propagation);
5640 function Process_Component_List_For_Adjust
5641 (Comps : Node_Id) return List_Id;
5642 -- Build all necessary adjust statements for a single component list
5644 ---------------------------------------
5645 -- Process_Component_List_For_Adjust --
5646 ---------------------------------------
5648 function Process_Component_List_For_Adjust
5649 (Comps : Node_Id) return List_Id
5651 Stmts : constant List_Id := New_List;
5653 Decl_Id : Entity_Id;
5654 Decl_Typ : Entity_Id;
5658 procedure Process_Component_For_Adjust (Decl : Node_Id);
5659 -- Process the declaration of a single controlled component
5661 ----------------------------------
5662 -- Process_Component_For_Adjust --
5663 ----------------------------------
5665 procedure Process_Component_For_Adjust (Decl : Node_Id) is
5666 Id : constant Entity_Id := Defining_Identifier (Decl);
5667 Typ : constant Entity_Id := Etype (Id);
5672 -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation
5674 -- begin -- Exception handlers allowed
5675 -- [Deep_]Adjust (V.Id);
5678 -- if not Raised then
5680 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5687 Make_Selected_Component (Loc,
5688 Prefix => Make_Identifier (Loc, Name_V),
5689 Selector_Name => Make_Identifier (Loc, Chars (Id))),
5692 if Exceptions_OK then
5694 Make_Block_Statement (Loc,
5695 Handled_Statement_Sequence =>
5696 Make_Handled_Sequence_Of_Statements (Loc,
5697 Statements => New_List (Adj_Stmt),
5698 Exception_Handlers => New_List (
5699 Build_Exception_Handler (Loc, E_Id, Raised_Id))));
5702 Append_To (Stmts, Adj_Stmt);
5703 end Process_Component_For_Adjust;
5705 -- Start of processing for Process_Component_List_For_Adjust
5708 -- Perform an initial check, determine the number of controlled
5709 -- components in the current list and whether at least one of them
5710 -- is per-object constrained.
5712 Preprocess_Components (Comps, Num_Comps, Has_POC);
5714 -- The processing in this routine is done in the following order:
5715 -- 1) Regular components
5716 -- 2) Per-object constrained components
5719 if Num_Comps > 0 then
5721 -- Process all regular components in order of declarations
5723 Decl := First_Non_Pragma (Component_Items (Comps));
5724 while Present (Decl) loop
5725 Decl_Id := Defining_Identifier (Decl);
5726 Decl_Typ := Etype (Decl_Id);
5728 -- Skip _parent as well as per-object constrained components
5730 if Chars (Decl_Id) /= Name_uParent
5731 and then Needs_Finalization (Decl_Typ)
5733 if Has_Access_Constraint (Decl_Id)
5734 and then No (Expression (Decl))
5738 Process_Component_For_Adjust (Decl);
5742 Next_Non_Pragma (Decl);
5745 -- Process all per-object constrained components in order of
5749 Decl := First_Non_Pragma (Component_Items (Comps));
5750 while Present (Decl) loop
5751 Decl_Id := Defining_Identifier (Decl);
5752 Decl_Typ := Etype (Decl_Id);
5756 if Chars (Decl_Id) /= Name_uParent
5757 and then Needs_Finalization (Decl_Typ)
5758 and then Has_Access_Constraint (Decl_Id)
5759 and then No (Expression (Decl))
5761 Process_Component_For_Adjust (Decl);
5764 Next_Non_Pragma (Decl);
5769 -- Process all variants, if any
5772 if Present (Variant_Part (Comps)) then
5774 Var_Alts : constant List_Id := New_List;
5778 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
5779 while Present (Var) loop
5782 -- when <discrete choices> =>
5783 -- <adjust statements>
5785 Append_To (Var_Alts,
5786 Make_Case_Statement_Alternative (Loc,
5788 New_Copy_List (Discrete_Choices (Var)),
5790 Process_Component_List_For_Adjust (
5791 Component_List (Var))));
5793 Next_Non_Pragma (Var);
5797 -- case V.<discriminant> is
5798 -- when <discrete choices 1> =>
5799 -- <adjust statements 1>
5801 -- when <discrete choices N> =>
5802 -- <adjust statements N>
5806 Make_Case_Statement (Loc,
5808 Make_Selected_Component (Loc,
5809 Prefix => Make_Identifier (Loc, Name_V),
5811 Make_Identifier (Loc,
5812 Chars => Chars (Name (Variant_Part (Comps))))),
5813 Alternatives => Var_Alts);
5817 -- Add the variant case statement to the list of statements
5819 if Present (Var_Case) then
5820 Append_To (Stmts, Var_Case);
5823 -- If the component list did not have any controlled components
5824 -- nor variants, return null.
5826 if Is_Empty_List (Stmts) then
5827 Append_To (Stmts, Make_Null_Statement (Loc));
5831 end Process_Component_List_For_Adjust;
5833 -- Start of processing for Build_Adjust_Statements
5836 if Exceptions_OK then
5837 Abort_Id := Make_Temporary (Loc, 'A');
5838 E_Id := Make_Temporary (Loc, 'E');
5839 Raised_Id := Make_Temporary (Loc, 'R');
5842 if Nkind (Typ_Def) = N_Derived_Type_Definition then
5843 Rec_Def := Record_Extension_Part (Typ_Def);
5848 -- Create an adjust sequence for all record components
5850 if Present (Component_List (Rec_Def)) then
5852 Process_Component_List_For_Adjust (Component_List (Rec_Def));
5855 -- A derived record type must adjust all inherited components. This
5856 -- action poses the following problem:
5858 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
5863 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
5865 -- Deep_Adjust (Obj._parent);
5870 -- Adjusting the derived type will invoke Adjust of the parent and
5871 -- then that of the derived type. This is undesirable because both
5872 -- routines may modify shared components. Only the Adjust of the
5873 -- derived type should be invoked.
5875 -- To prevent this double adjustment of shared components,
5876 -- Deep_Adjust uses a flag to control the invocation of Adjust:
5878 -- procedure Deep_Adjust
5879 -- (Obj : in out Some_Type;
5880 -- Flag : Boolean := True)
5888 -- When Deep_Adjust is invokes for field _parent, a value of False is
5889 -- provided for the flag:
5891 -- Deep_Adjust (Obj._parent, False);
5893 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
5895 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
5900 if Needs_Finalization (Par_Typ) then
5904 Make_Selected_Component (Loc,
5905 Prefix => Make_Identifier (Loc, Name_V),
5907 Make_Identifier (Loc, Name_uParent)),
5909 For_Parent => True);
5912 -- Deep_Adjust (V._parent, False); -- No_Except_Propagat
5914 -- begin -- Exceptions OK
5915 -- Deep_Adjust (V._parent, False);
5917 -- when Id : others =>
5918 -- if not Raised then
5920 -- Save_Occurrence (E,
5921 -- Get_Current_Excep.all.all);
5925 if Present (Call) then
5928 if Exceptions_OK then
5930 Make_Block_Statement (Loc,
5931 Handled_Statement_Sequence =>
5932 Make_Handled_Sequence_Of_Statements (Loc,
5933 Statements => New_List (Adj_Stmt),
5934 Exception_Handlers => New_List (
5935 Build_Exception_Handler
5936 (Loc, E_Id, Raised_Id))));
5939 Prepend_To (Bod_Stmts, Adj_Stmt);
5945 -- Adjust the object. This action must be performed last after all
5946 -- components have been adjusted.
5948 if Is_Controlled (Typ) then
5954 Proc := Find_Prim_Op (Typ, Name_Adjust);
5958 -- Adjust (V); -- No_Exception_Propagation
5960 -- begin -- Exception handlers allowed
5964 -- if not Raised then
5966 -- Save_Occurrence (E,
5967 -- Get_Current_Excep.all.all);
5972 if Present (Proc) then
5974 Make_Procedure_Call_Statement (Loc,
5975 Name => New_Reference_To (Proc, Loc),
5976 Parameter_Associations => New_List (
5977 Make_Identifier (Loc, Name_V)));
5979 if Exceptions_OK then
5981 Make_Block_Statement (Loc,
5982 Handled_Statement_Sequence =>
5983 Make_Handled_Sequence_Of_Statements (Loc,
5984 Statements => New_List (Adj_Stmt),
5985 Exception_Handlers => New_List (
5986 Build_Exception_Handler
5987 (Loc, E_Id, Raised_Id))));
5990 Append_To (Bod_Stmts,
5991 Make_If_Statement (Loc,
5992 Condition => Make_Identifier (Loc, Name_F),
5993 Then_Statements => New_List (Adj_Stmt)));
5998 -- At this point either all adjustment statements have been generated
5999 -- or the type is not controlled.
6001 if Is_Empty_List (Bod_Stmts) then
6002 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
6008 -- Abort : constant Boolean :=
6009 -- Exception_Occurrence (Get_Current_Excep.all.all) =
6010 -- Standard'Abort_Signal'Identity;
6012 -- Abort : constant Boolean := False; -- no abort
6014 -- E : Exception_Occurence;
6015 -- Raised : Boolean := False;
6018 -- Root_Controlled (V).Finalized := False;
6020 -- <adjust statements>
6023 -- Raise_From_Controlled_Operation (E, Abort);
6028 if Exceptions_OK then
6029 Append_To (Bod_Stmts,
6030 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
6035 Make_Block_Statement (Loc,
6037 Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
6038 Handled_Statement_Sequence =>
6039 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6041 end Build_Adjust_Statements;
6043 -------------------------------
6044 -- Build_Finalize_Statements --
6045 -------------------------------
6047 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
6048 Loc : constant Source_Ptr := Sloc (Typ);
6049 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
6050 Abort_Id : Entity_Id := Empty;
6051 Bod_Stmts : List_Id;
6053 E_Id : Entity_Id := Empty;
6054 Raised_Id : Entity_Id := Empty;
6058 Exceptions_OK : constant Boolean :=
6059 not Restriction_Active (No_Exception_Propagation);
6061 function Process_Component_List_For_Finalize
6062 (Comps : Node_Id) return List_Id;
6063 -- Build all necessary finalization statements for a single component
6064 -- list. The statements may include a jump circuitry if flag Is_Local
6067 -----------------------------------------
6068 -- Process_Component_List_For_Finalize --
6069 -----------------------------------------
6071 function Process_Component_List_For_Finalize
6072 (Comps : Node_Id) return List_Id
6075 Counter_Id : Entity_Id;
6077 Decl_Id : Entity_Id;
6078 Decl_Typ : Entity_Id;
6081 Jump_Block : Node_Id;
6083 Label_Id : Entity_Id;
6087 procedure Process_Component_For_Finalize
6092 -- Process the declaration of a single controlled component. If
6093 -- flag Is_Local is enabled, create the corresponding label and
6094 -- jump circuitry. Alts is the list of case alternatives, Decls
6095 -- is the top level declaration list where labels are declared
6096 -- and Stmts is the list of finalization actions.
6098 ------------------------------------
6099 -- Process_Component_For_Finalize --
6100 ------------------------------------
6102 procedure Process_Component_For_Finalize
6108 Id : constant Entity_Id := Defining_Identifier (Decl);
6109 Typ : constant Entity_Id := Etype (Id);
6116 Label_Id : Entity_Id;
6123 Make_Identifier (Loc,
6124 Chars => New_External_Name ('L', Num_Comps));
6125 Set_Entity (Label_Id,
6126 Make_Defining_Identifier (Loc, Chars (Label_Id)));
6127 Label := Make_Label (Loc, Label_Id);
6130 Make_Implicit_Label_Declaration (Loc,
6131 Defining_Identifier => Entity (Label_Id),
6132 Label_Construct => Label));
6139 Make_Case_Statement_Alternative (Loc,
6140 Discrete_Choices => New_List (
6141 Make_Integer_Literal (Loc, Num_Comps)),
6143 Statements => New_List (
6144 Make_Goto_Statement (Loc,
6146 New_Reference_To (Entity (Label_Id), Loc)))));
6151 Append_To (Stmts, Label);
6153 -- Decrease the number of components to be processed.
6154 -- This action yields a new Label_Id in future calls.
6156 Num_Comps := Num_Comps - 1;
6161 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
6163 -- begin -- Exception handlers allowed
6164 -- [Deep_]Finalize (V.Id);
6167 -- if not Raised then
6169 -- Save_Occurrence (E,
6170 -- Get_Current_Excep.all.all);
6177 Make_Selected_Component (Loc,
6178 Prefix => Make_Identifier (Loc, Name_V),
6179 Selector_Name => Make_Identifier (Loc, Chars (Id))),
6182 if not Restriction_Active (No_Exception_Propagation) then
6184 Make_Block_Statement (Loc,
6185 Handled_Statement_Sequence =>
6186 Make_Handled_Sequence_Of_Statements (Loc,
6187 Statements => New_List (Fin_Stmt),
6188 Exception_Handlers => New_List (
6189 Build_Exception_Handler (Loc, E_Id, Raised_Id))));
6192 Append_To (Stmts, Fin_Stmt);
6193 end Process_Component_For_Finalize;
6195 -- Start of processing for Process_Component_List_For_Finalize
6198 -- Perform an initial check, look for controlled and per-object
6199 -- constrained components.
6201 Preprocess_Components (Comps, Num_Comps, Has_POC);
6203 -- Create a state counter to service the current component list.
6204 -- This step is performed before the variants are inspected in
6205 -- order to generate the same state counter names as those from
6206 -- Build_Initialize_Statements.
6211 Counter := Counter + 1;
6214 Make_Defining_Identifier (Loc,
6215 Chars => New_External_Name ('C', Counter));
6218 -- Process the component in the following order:
6220 -- 2) Per-object constrained components
6221 -- 3) Regular components
6223 -- Start with the variant parts
6226 if Present (Variant_Part (Comps)) then
6228 Var_Alts : constant List_Id := New_List;
6232 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6233 while Present (Var) loop
6236 -- when <discrete choices> =>
6237 -- <finalize statements>
6239 Append_To (Var_Alts,
6240 Make_Case_Statement_Alternative (Loc,
6242 New_Copy_List (Discrete_Choices (Var)),
6244 Process_Component_List_For_Finalize (
6245 Component_List (Var))));
6247 Next_Non_Pragma (Var);
6251 -- case V.<discriminant> is
6252 -- when <discrete choices 1> =>
6253 -- <finalize statements 1>
6255 -- when <discrete choices N> =>
6256 -- <finalize statements N>
6260 Make_Case_Statement (Loc,
6262 Make_Selected_Component (Loc,
6263 Prefix => Make_Identifier (Loc, Name_V),
6265 Make_Identifier (Loc,
6266 Chars => Chars (Name (Variant_Part (Comps))))),
6267 Alternatives => Var_Alts);
6271 -- The current component list does not have a single controlled
6272 -- component, however it may contain variants. Return the case
6273 -- statement for the variants or nothing.
6275 if Num_Comps = 0 then
6276 if Present (Var_Case) then
6277 return New_List (Var_Case);
6279 return New_List (Make_Null_Statement (Loc));
6283 -- Prepare all lists
6289 -- Process all per-object constrained components in reverse order
6292 Decl := Last_Non_Pragma (Component_Items (Comps));
6293 while Present (Decl) loop
6294 Decl_Id := Defining_Identifier (Decl);
6295 Decl_Typ := Etype (Decl_Id);
6299 if Chars (Decl_Id) /= Name_uParent
6300 and then Needs_Finalization (Decl_Typ)
6301 and then Has_Access_Constraint (Decl_Id)
6302 and then No (Expression (Decl))
6304 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6307 Prev_Non_Pragma (Decl);
6311 -- Process the rest of the components in reverse order
6313 Decl := Last_Non_Pragma (Component_Items (Comps));
6314 while Present (Decl) loop
6315 Decl_Id := Defining_Identifier (Decl);
6316 Decl_Typ := Etype (Decl_Id);
6320 if Chars (Decl_Id) /= Name_uParent
6321 and then Needs_Finalization (Decl_Typ)
6323 -- Skip per-object constrained components since they were
6324 -- handled in the above step.
6326 if Has_Access_Constraint (Decl_Id)
6327 and then No (Expression (Decl))
6331 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6335 Prev_Non_Pragma (Decl);
6340 -- LN : label; -- If Is_Local is enabled
6345 -- case CounterX is .
6355 -- <<LN>> -- If Is_Local is enabled
6357 -- [Deep_]Finalize (V.CompY);
6359 -- when Id : others =>
6360 -- if not Raised then
6362 -- Save_Occurrence (E,
6363 -- Get_Current_Excep.all.all);
6367 -- <<L0>> -- If Is_Local is enabled
6372 -- Add the declaration of default jump location L0, its
6373 -- corresponding alternative and its place in the statements.
6375 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
6376 Set_Entity (Label_Id,
6377 Make_Defining_Identifier (Loc, Chars (Label_Id)));
6378 Label := Make_Label (Loc, Label_Id);
6380 Append_To (Decls, -- declaration
6381 Make_Implicit_Label_Declaration (Loc,
6382 Defining_Identifier => Entity (Label_Id),
6383 Label_Construct => Label));
6385 Append_To (Alts, -- alternative
6386 Make_Case_Statement_Alternative (Loc,
6387 Discrete_Choices => New_List (
6388 Make_Others_Choice (Loc)),
6390 Statements => New_List (
6391 Make_Goto_Statement (Loc,
6392 Name => New_Reference_To (Entity (Label_Id), Loc)))));
6394 Append_To (Stmts, Label); -- statement
6396 -- Create the jump block
6399 Make_Case_Statement (Loc,
6400 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
6401 Alternatives => Alts));
6405 Make_Block_Statement (Loc,
6406 Declarations => Decls,
6407 Handled_Statement_Sequence =>
6408 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6410 if Present (Var_Case) then
6411 return New_List (Var_Case, Jump_Block);
6413 return New_List (Jump_Block);
6415 end Process_Component_List_For_Finalize;
6417 -- Start of processing for Build_Finalize_Statements
6420 if Exceptions_OK then
6421 Abort_Id := Make_Temporary (Loc, 'A');
6422 E_Id := Make_Temporary (Loc, 'E');
6423 Raised_Id := Make_Temporary (Loc, 'R');
6426 if Nkind (Typ_Def) = N_Derived_Type_Definition then
6427 Rec_Def := Record_Extension_Part (Typ_Def);
6432 -- Create a finalization sequence for all record components
6434 if Present (Component_List (Rec_Def)) then
6436 Process_Component_List_For_Finalize (Component_List (Rec_Def));
6439 -- A derived record type must finalize all inherited components. This
6440 -- action poses the following problem:
6442 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
6447 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
6449 -- Deep_Finalize (Obj._parent);
6454 -- Finalizing the derived type will invoke Finalize of the parent and
6455 -- then that of the derived type. This is undesirable because both
6456 -- routines may modify shared components. Only the Finalize of the
6457 -- derived type should be invoked.
6459 -- To prevent this double adjustment of shared components,
6460 -- Deep_Finalize uses a flag to control the invocation of Finalize:
6462 -- procedure Deep_Finalize
6463 -- (Obj : in out Some_Type;
6464 -- Flag : Boolean := True)
6472 -- When Deep_Finalize is invokes for field _parent, a value of False
6473 -- is provided for the flag:
6475 -- Deep_Finalize (Obj._parent, False);
6477 if Is_Tagged_Type (Typ)
6478 and then Is_Derived_Type (Typ)
6481 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
6486 if Needs_Finalization (Par_Typ) then
6490 Make_Selected_Component (Loc,
6491 Prefix => Make_Identifier (Loc, Name_V),
6493 Make_Identifier (Loc, Name_uParent)),
6495 For_Parent => True);
6498 -- Deep_Finalize (V._parent, False); -- No_Except_Propag
6500 -- begin -- Exceptions OK
6501 -- Deep_Finalize (V._parent, False);
6503 -- when Id : others =>
6504 -- if not Raised then
6506 -- Save_Occurrence (E,
6507 -- Get_Current_Excep.all.all);
6511 if Present (Call) then
6514 if Exceptions_OK then
6516 Make_Block_Statement (Loc,
6517 Handled_Statement_Sequence =>
6518 Make_Handled_Sequence_Of_Statements (Loc,
6519 Statements => New_List (Fin_Stmt),
6520 Exception_Handlers => New_List (
6521 Build_Exception_Handler
6522 (Loc, E_Id, Raised_Id))));
6525 Append_To (Bod_Stmts, Fin_Stmt);
6531 -- Finalize the object. This action must be performed first before
6532 -- all components have been finalized.
6534 if Is_Controlled (Typ)
6535 and then not Is_Local
6542 Proc := Find_Prim_Op (Typ, Name_Finalize);
6546 -- Finalize (V); -- No_Exception_Propagation
6552 -- if not Raised then
6554 -- Save_Occurrence (E,
6555 -- Get_Current_Excep.all.all);
6560 if Present (Proc) then
6562 Make_Procedure_Call_Statement (Loc,
6563 Name => New_Reference_To (Proc, Loc),
6564 Parameter_Associations => New_List (
6565 Make_Identifier (Loc, Name_V)));
6567 if Exceptions_OK then
6569 Make_Block_Statement (Loc,
6570 Handled_Statement_Sequence =>
6571 Make_Handled_Sequence_Of_Statements (Loc,
6572 Statements => New_List (Fin_Stmt),
6573 Exception_Handlers => New_List (
6574 Build_Exception_Handler
6575 (Loc, E_Id, Raised_Id))));
6578 Prepend_To (Bod_Stmts,
6579 Make_If_Statement (Loc,
6580 Condition => Make_Identifier (Loc, Name_F),
6581 Then_Statements => New_List (Fin_Stmt)));
6586 -- At this point either all finalization statements have been
6587 -- generated or the type is not controlled.
6589 if No (Bod_Stmts) then
6590 return New_List (Make_Null_Statement (Loc));
6594 -- Abort : constant Boolean :=
6595 -- Exception_Occurrence (Get_Current_Excep.all.all) =
6596 -- Standard'Abort_Signal'Identity;
6598 -- Abort : constant Boolean := False; -- no abort
6600 -- E : Exception_Occurence;
6601 -- Raised : Boolean := False;
6604 -- if V.Finalized then
6608 -- <finalize statements>
6609 -- V.Finalized := True;
6612 -- Raise_From_Controlled_Operation (E, Abort);
6617 if Exceptions_OK then
6618 Append_To (Bod_Stmts,
6619 Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id));
6624 Make_Block_Statement (Loc,
6626 Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
6627 Handled_Statement_Sequence =>
6628 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6630 end Build_Finalize_Statements;
6632 -----------------------
6633 -- Parent_Field_Type --
6634 -----------------------
6636 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
6640 Field := First_Entity (Typ);
6641 while Present (Field) loop
6642 if Chars (Field) = Name_uParent then
6643 return Etype (Field);
6646 Next_Entity (Field);
6649 -- A derived tagged type should always have a parent field
6651 raise Program_Error;
6652 end Parent_Field_Type;
6654 ---------------------------
6655 -- Preprocess_Components --
6656 ---------------------------
6658 procedure Preprocess_Components
6660 Num_Comps : out Int;
6661 Has_POC : out Boolean)
6671 Decl := First_Non_Pragma (Component_Items (Comps));
6672 while Present (Decl) loop
6673 Id := Defining_Identifier (Decl);
6676 -- Skip field _parent
6678 if Chars (Id) /= Name_uParent
6679 and then Needs_Finalization (Typ)
6681 Num_Comps := Num_Comps + 1;
6683 if Has_Access_Constraint (Id)
6684 and then No (Expression (Decl))
6690 Next_Non_Pragma (Decl);
6692 end Preprocess_Components;
6694 -- Start of processing for Make_Deep_Record_Body
6698 when Address_Case =>
6699 return Make_Finalize_Address_Stmts (Typ);
6702 return Build_Adjust_Statements (Typ);
6704 when Finalize_Case =>
6705 return Build_Finalize_Statements (Typ);
6707 when Initialize_Case =>
6709 Loc : constant Source_Ptr := Sloc (Typ);
6712 if Is_Controlled (Typ) then
6714 Make_Procedure_Call_Statement (Loc,
6717 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
6718 Parameter_Associations => New_List (
6719 Make_Identifier (Loc, Name_V))));
6725 end Make_Deep_Record_Body;
6727 ----------------------
6728 -- Make_Final_Call --
6729 ----------------------
6731 function Make_Final_Call
6734 For_Parent : Boolean := False) return Node_Id
6736 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6737 Fin_Id : Entity_Id := Empty;
6742 -- Recover the proper type which contains [Deep_]Finalize
6744 if Is_Class_Wide_Type (Typ) then
6745 Utyp := Root_Type (Typ);
6748 elsif Is_Concurrent_Type (Typ) then
6749 Utyp := Corresponding_Record_Type (Typ);
6750 Ref := Convert_Concurrent (Obj_Ref, Typ);
6752 elsif Is_Private_Type (Typ)
6753 and then Present (Full_View (Typ))
6754 and then Is_Concurrent_Type (Full_View (Typ))
6756 Utyp := Corresponding_Record_Type (Full_View (Typ));
6757 Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
6764 Utyp := Underlying_Type (Base_Type (Utyp));
6765 Set_Assignment_OK (Ref);
6767 -- Deal with non-tagged derivation of private views. If the parent type
6768 -- is a protected type, Deep_Finalize is found on the corresponding
6769 -- record of the ancestor.
6771 if Is_Untagged_Derivation (Typ) then
6772 if Is_Protected_Type (Typ) then
6773 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
6775 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6777 if Is_Protected_Type (Utyp) then
6778 Utyp := Corresponding_Record_Type (Utyp);
6782 Ref := Unchecked_Convert_To (Utyp, Ref);
6783 Set_Assignment_OK (Ref);
6786 -- Deal with derived private types which do not inherit primitives from
6787 -- their parents. In this case, [Deep_]Finalize can be found in the full
6788 -- view of the parent type.
6790 if Is_Tagged_Type (Utyp)
6791 and then Is_Derived_Type (Utyp)
6792 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
6793 and then Is_Private_Type (Etype (Utyp))
6794 and then Present (Full_View (Etype (Utyp)))
6796 Utyp := Full_View (Etype (Utyp));
6797 Ref := Unchecked_Convert_To (Utyp, Ref);
6798 Set_Assignment_OK (Ref);
6801 -- When dealing with the completion of a private type, use the base type
6804 if Utyp /= Base_Type (Utyp) then
6805 pragma Assert (Is_Private_Type (Typ));
6807 Utyp := Base_Type (Utyp);
6808 Ref := Unchecked_Convert_To (Utyp, Ref);
6809 Set_Assignment_OK (Ref);
6812 -- Select the appropriate version of finalize
6815 if Has_Controlled_Component (Utyp) then
6816 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6819 -- For types that are both controlled and have controlled components,
6820 -- generate a call to Deep_Finalize.
6822 elsif Is_Controlled (Utyp)
6823 and then Has_Controlled_Component (Utyp)
6825 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6827 -- For types that are not controlled themselves, but contain controlled
6828 -- components or can be extended by types with controlled components,
6829 -- create a call to Deep_Finalize.
6831 elsif Is_Class_Wide_Type (Typ)
6832 or else Is_Interface (Typ)
6833 or else Has_Controlled_Component (Utyp)
6835 if Is_Tagged_Type (Utyp) then
6836 Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
6838 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
6841 -- For types that are derived from Controlled and do not have controlled
6842 -- components, build a call to Finalize.
6845 Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
6848 if Present (Fin_Id) then
6850 -- When finalizing a class-wide object, do not convert to the root
6851 -- type in order to produce a dispatching call.
6853 if Is_Class_Wide_Type (Typ) then
6856 -- Ensure that a finalization routine is at least decorated in order
6857 -- to inspect the object parameter.
6859 elsif Analyzed (Fin_Id)
6860 or else Ekind (Fin_Id) = E_Procedure
6862 -- In certain cases, such as the creation of Stream_Read, the
6863 -- visible entity of the type is its full view. Since Stream_Read
6864 -- will have to create an object of type Typ, the local object
6865 -- will be finalzed by the scope finalizer generated later on. The
6866 -- object parameter of Deep_Finalize will always use the private
6867 -- view of the type. To avoid such a clash between a private and a
6868 -- full view, perform an unchecked conversion of the object
6869 -- reference to the private view.
6872 Formal_Typ : constant Entity_Id :=
6873 Etype (First_Formal (Fin_Id));
6875 if Is_Private_Type (Formal_Typ)
6876 and then Present (Full_View (Formal_Typ))
6877 and then Full_View (Formal_Typ) = Utyp
6879 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
6883 Ref := Convert_View (Fin_Id, Ref);
6886 return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
6890 end Make_Final_Call;
6892 --------------------------------
6893 -- Make_Finalize_Address_Body --
6894 --------------------------------
6896 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
6898 -- Nothing to do if the type is not controlled or it already has a
6899 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
6900 -- come from source. These are usually generated for completeness and
6901 -- do not need the Finalize_Address primitive.
6903 if not Needs_Finalization (Typ)
6904 or else Present (TSS (Typ, TSS_Finalize_Address))
6906 (Is_Class_Wide_Type (Typ)
6907 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
6908 and then not Comes_From_Source (Root_Type (Typ)))
6914 Loc : constant Source_Ptr := Sloc (Typ);
6915 Proc_Id : Entity_Id;
6919 Make_Defining_Identifier (Loc,
6920 Make_TSS_Name (Typ, TSS_Finalize_Address));
6923 -- procedure TypFD (V : System.Address) is
6926 -- type Pnn is access all Typ;
6927 -- for Pnn'Storage_Size use 0;
6929 -- [Deep_]Finalize (Pnn (V).all);
6934 Make_Subprogram_Body (Loc,
6936 Make_Procedure_Specification (Loc,
6937 Defining_Unit_Name => Proc_Id,
6939 Parameter_Specifications => New_List (
6940 Make_Parameter_Specification (Loc,
6941 Defining_Identifier =>
6942 Make_Defining_Identifier (Loc, Name_V),
6944 New_Reference_To (RTE (RE_Address), Loc)))),
6946 Declarations => No_List,
6948 Handled_Statement_Sequence =>
6949 Make_Handled_Sequence_Of_Statements (Loc,
6951 Make_Finalize_Address_Stmts (Typ))));
6953 Set_TSS (Typ, Proc_Id);
6955 end Make_Finalize_Address_Body;
6957 ---------------------------------
6958 -- Make_Finalize_Address_Stmts --
6959 ---------------------------------
6961 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
6962 Loc : constant Source_Ptr := Sloc (Typ);
6963 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
6965 Desg_Typ : Entity_Id;
6968 function Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
6969 -- Subsidiary routine, generate the following attribute reference:
6971 -- Some_Typ'Alignment
6973 function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
6974 -- Subsidiary routine, generate the following expression:
6976 -- 2 * Some_Typ'Alignment
6982 function Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
6985 Make_Attribute_Reference (Loc,
6986 Prefix => New_Reference_To (Some_Typ, Loc),
6987 Attribute_Name => Name_Alignment);
6990 -------------------------
6991 -- Double_Alignment_Of --
6992 -------------------------
6994 function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
6997 Make_Op_Multiply (Loc,
6998 Left_Opnd => Make_Integer_Literal (Loc, 2),
6999 Right_Opnd => Alignment_Of (Some_Typ));
7000 end Double_Alignment_Of;
7002 -- Start of processing for Make_Finalize_Address_Stmts
7005 if Is_Array_Type (Typ) then
7006 if Is_Constrained (First_Subtype (Typ)) then
7007 Desg_Typ := First_Subtype (Typ);
7009 Desg_Typ := Base_Type (Typ);
7012 -- Class-wide types of constrained root types
7014 elsif Is_Class_Wide_Type (Typ)
7015 and then Has_Discriminants (Root_Type (Typ))
7017 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
7020 Parent_Typ : Entity_Id := Root_Type (Typ);
7023 -- Climb the parent type chain looking for a non-constrained type
7025 while Parent_Typ /= Etype (Parent_Typ)
7026 and then Has_Discriminants (Parent_Typ)
7028 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
7030 Parent_Typ := Etype (Parent_Typ);
7033 -- Handle views created for tagged types with unknown
7036 if Is_Underlying_Record_View (Parent_Typ) then
7037 Parent_Typ := Underlying_Record_View (Parent_Typ);
7040 Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
7050 -- type Ptr_Typ is access all Typ;
7051 -- for Ptr_Typ'Storage_Size use 0;
7054 Make_Full_Type_Declaration (Loc,
7055 Defining_Identifier => Ptr_Typ,
7057 Make_Access_To_Object_Definition (Loc,
7058 All_Present => True,
7059 Subtype_Indication => New_Reference_To (Desg_Typ, Loc))),
7061 Make_Attribute_Definition_Clause (Loc,
7062 Name => New_Reference_To (Ptr_Typ, Loc),
7063 Chars => Name_Storage_Size,
7064 Expression => Make_Integer_Literal (Loc, 0)));
7066 Obj_Expr := Make_Identifier (Loc, Name_V);
7068 -- Unconstrained arrays require special processing in order to retrieve
7069 -- the elements. To achieve this, we have to skip the dope vector which
7070 -- lays in front of the elements and then use a thin pointer to perform
7071 -- the address-to-access conversion.
7073 if Is_Array_Type (Typ)
7074 and then not Is_Constrained (First_Subtype (Typ))
7077 Dope_Expr : Node_Id;
7078 Dope_Id : Entity_Id;
7079 For_First : Boolean := True;
7081 Index_Typ : Entity_Id;
7084 -- Ensure that Ptr_Typ a thin pointer, generate:
7086 -- for Ptr_Typ'Size use System.Address'Size;
7089 Make_Attribute_Definition_Clause (Loc,
7090 Name => New_Reference_To (Ptr_Typ, Loc),
7093 Make_Integer_Literal (Loc, System_Address_Size)));
7095 -- For unconstrained arrays, create the expression which computes
7096 -- the size of the dope vector.
7098 Index := First_Index (Typ);
7099 while Present (Index) loop
7100 Index_Typ := Etype (Index);
7102 -- Each bound has two values and a potential hole added to
7103 -- compensate for alignment differences.
7109 -- 2 * Index_Typ'Alignment
7111 Dope_Expr := Double_Alignment_Of (Index_Typ);
7115 -- Dope_Expr + 2 * Index_Typ'Alignment
7119 Left_Opnd => Dope_Expr,
7120 Right_Opnd => Double_Alignment_Of (Index_Typ));
7126 -- Round the cumulative alignment to the next higher multiple of
7127 -- the array alignment. Generate:
7129 -- ((Dope_Expr + Typ'Alignment - 1) / Typ'Alignment)
7133 Make_Op_Multiply (Loc,
7135 Make_Op_Divide (Loc,
7138 Left_Opnd => Dope_Expr,
7140 Make_Op_Subtract (Loc,
7141 Left_Opnd => Alignment_Of (Typ),
7142 Right_Opnd => Make_Integer_Literal (Loc, 1))),
7143 Right_Opnd => Alignment_Of (Typ)),
7144 Right_Opnd => Alignment_Of (Typ));
7147 -- Dnn : Storage_Offset := Dope_Expr;
7149 Dope_Id := Make_Temporary (Loc, 'D');
7152 Make_Object_Declaration (Loc,
7153 Defining_Identifier => Dope_Id,
7154 Constant_Present => True,
7155 Object_Definition =>
7156 New_Reference_To (RTE (RE_Storage_Offset), Loc),
7157 Expression => Dope_Expr));
7159 -- Shift the address from the start of the dope vector to the
7160 -- start of the elements:
7164 -- Note that this is done through a wrapper routine since RTSfind
7165 -- cannot retrieve operations with string names of the form "+".
7168 Make_Function_Call (Loc,
7170 New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc),
7171 Parameter_Associations => New_List (
7173 New_Reference_To (Dope_Id, Loc)));
7177 -- Create the block and the finalization call
7180 Make_Block_Statement (Loc,
7181 Declarations => Decls,
7183 Handled_Statement_Sequence =>
7184 Make_Handled_Sequence_Of_Statements (Loc,
7185 Statements => New_List (
7188 Make_Explicit_Dereference (Loc,
7189 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
7190 Typ => Desg_Typ)))));
7191 end Make_Finalize_Address_Stmts;
7193 -------------------------------------
7194 -- Make_Handler_For_Ctrl_Operation --
7195 -------------------------------------
7199 -- when E : others =>
7200 -- Raise_From_Controlled_Operation (E, False);
7205 -- raise Program_Error [finalize raised exception];
7207 -- depending on whether Raise_From_Controlled_Operation is available
7209 function Make_Handler_For_Ctrl_Operation
7210 (Loc : Source_Ptr) return Node_Id
7213 -- Choice parameter (for the first case above)
7215 Raise_Node : Node_Id;
7216 -- Procedure call or raise statement
7219 -- Standard runtime, .NET/JVM targets: add choice parameter E and pass
7220 -- it to Raise_From_Controlled_Operation so that the original exception
7221 -- name and message can be recorded in the exception message for
7224 if RTE_Available (RE_Raise_From_Controlled_Operation) then
7225 E_Occ := Make_Defining_Identifier (Loc, Name_E);
7227 Make_Procedure_Call_Statement (Loc,
7230 (RTE (RE_Raise_From_Controlled_Operation), Loc),
7231 Parameter_Associations => New_List (
7232 New_Reference_To (E_Occ, Loc),
7233 New_Reference_To (Standard_False, Loc)));
7235 -- Restricted runtime: exception messages are not supported
7240 Make_Raise_Program_Error (Loc,
7241 Reason => PE_Finalize_Raised_Exception);
7245 Make_Implicit_Exception_Handler (Loc,
7246 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7247 Choice_Parameter => E_Occ,
7248 Statements => New_List (Raise_Node));
7249 end Make_Handler_For_Ctrl_Operation;
7251 --------------------
7252 -- Make_Init_Call --
7253 --------------------
7255 function Make_Init_Call
7257 Typ : Entity_Id) return Node_Id
7259 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7266 -- Deal with the type and object reference. Depending on the context, an
7267 -- object reference may need several conversions.
7269 if Is_Concurrent_Type (Typ) then
7271 Utyp := Corresponding_Record_Type (Typ);
7272 Ref := Convert_Concurrent (Obj_Ref, Typ);
7274 elsif Is_Private_Type (Typ)
7275 and then Present (Full_View (Typ))
7276 and then Is_Concurrent_Type (Underlying_Type (Typ))
7279 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
7280 Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
7288 Set_Assignment_OK (Ref);
7290 Utyp := Underlying_Type (Base_Type (Utyp));
7292 -- Deal with non-tagged derivation of private views
7294 if Is_Untagged_Derivation (Typ)
7295 and then not Is_Conc
7297 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7298 Ref := Unchecked_Convert_To (Utyp, Ref);
7300 -- The following is to prevent problems with UC see 1.156 RH ???
7302 Set_Assignment_OK (Ref);
7305 -- If the underlying_type is a subtype, then we are dealing with the
7306 -- completion of a private type. We need to access the base type and
7307 -- generate a conversion to it.
7309 if Utyp /= Base_Type (Utyp) then
7310 pragma Assert (Is_Private_Type (Typ));
7311 Utyp := Base_Type (Utyp);
7312 Ref := Unchecked_Convert_To (Utyp, Ref);
7315 -- Select the appropriate version of initialize
7317 if Has_Controlled_Component (Utyp) then
7318 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
7320 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
7321 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
7324 -- The object reference may need another conversion depending on the
7325 -- type of the formal and that of the actual.
7327 Ref := Convert_View (Proc, Ref);
7330 -- [Deep_]Initialize (Ref);
7333 Make_Procedure_Call_Statement (Loc,
7335 New_Reference_To (Proc, Loc),
7336 Parameter_Associations => New_List (Ref));
7339 ------------------------------
7340 -- Make_Local_Deep_Finalize --
7341 ------------------------------
7343 function Make_Local_Deep_Finalize
7345 Nam : Entity_Id) return Node_Id
7347 Loc : constant Source_Ptr := Sloc (Typ);
7351 Formals := New_List (
7355 Make_Parameter_Specification (Loc,
7356 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7358 Out_Present => True,
7359 Parameter_Type => New_Reference_To (Typ, Loc)),
7361 -- F : Boolean := True
7363 Make_Parameter_Specification (Loc,
7364 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7365 Parameter_Type => New_Reference_To (Standard_Boolean, Loc),
7366 Expression => New_Reference_To (Standard_True, Loc)));
7368 -- Add the necessary number of counters to represent the initialization
7369 -- state of an object.
7372 Make_Subprogram_Body (Loc,
7374 Make_Procedure_Specification (Loc,
7375 Defining_Unit_Name => Nam,
7376 Parameter_Specifications => Formals),
7378 Declarations => No_List,
7380 Handled_Statement_Sequence =>
7381 Make_Handled_Sequence_Of_Statements (Loc,
7382 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
7383 end Make_Local_Deep_Finalize;
7385 ----------------------------------------
7386 -- Make_Set_Finalize_Address_Ptr_Call --
7387 ----------------------------------------
7389 function Make_Set_Finalize_Address_Ptr_Call
7392 Ptr_Typ : Entity_Id) return Node_Id
7394 Desig_Typ : constant Entity_Id :=
7395 Available_View (Designated_Type (Ptr_Typ));
7399 -- If the context is a class-wide allocator, we use the class-wide type
7400 -- to obtain the proper Finalize_Address routine.
7402 if Is_Class_Wide_Type (Desig_Typ) then
7408 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
7409 Utyp := Full_View (Utyp);
7412 if Is_Concurrent_Type (Utyp) then
7413 Utyp := Corresponding_Record_Type (Utyp);
7417 Utyp := Underlying_Type (Base_Type (Utyp));
7419 -- Deal with non-tagged derivation of private views. If the parent is
7420 -- now known to be protected, the finalization routine is the one
7421 -- defined on the corresponding record of the ancestor (corresponding
7422 -- records do not automatically inherit operations, but maybe they
7425 if Is_Untagged_Derivation (Typ) then
7426 if Is_Protected_Type (Typ) then
7427 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7429 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7431 if Is_Protected_Type (Utyp) then
7432 Utyp := Corresponding_Record_Type (Utyp);
7437 -- If the underlying_type is a subtype, we are dealing with the
7438 -- completion of a private type. We need to access the base type and
7439 -- generate a conversion to it.
7441 if Utyp /= Base_Type (Utyp) then
7442 pragma Assert (Is_Private_Type (Typ));
7444 Utyp := Base_Type (Utyp);
7448 -- Set_Finalize_Address_Ptr
7449 -- (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access);
7452 Make_Procedure_Call_Statement (Loc,
7454 New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
7456 Parameter_Associations => New_List (
7457 New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
7459 Make_Attribute_Reference (Loc,
7461 New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
7462 Attribute_Name => Name_Unrestricted_Access)));
7463 end Make_Set_Finalize_Address_Ptr_Call;
7465 --------------------------
7466 -- Make_Transient_Block --
7467 --------------------------
7469 function Make_Transient_Block
7472 Par : Node_Id) return Node_Id
7474 Decls : constant List_Id := New_List;
7475 Instrs : constant List_Id := New_List (Action);
7480 -- Case where only secondary stack use is involved
7482 if VM_Target = No_VM
7483 and then Uses_Sec_Stack (Current_Scope)
7484 and then Nkind (Action) /= N_Simple_Return_Statement
7485 and then Nkind (Par) /= N_Exception_Handler
7491 S := Scope (Current_Scope);
7493 -- At the outer level, no need to release the sec stack
7495 if S = Standard_Standard then
7496 Set_Uses_Sec_Stack (Current_Scope, False);
7499 -- In a function, only release the sec stack if the
7500 -- function does not return on the sec stack otherwise
7501 -- the result may be lost. The caller is responsible for
7504 elsif Ekind (S) = E_Function then
7505 Set_Uses_Sec_Stack (Current_Scope, False);
7507 if not Requires_Transient_Scope (Etype (S)) then
7508 Set_Uses_Sec_Stack (S, True);
7509 Check_Restriction (No_Secondary_Stack, Action);
7514 -- In a loop or entry we should install a block encompassing
7515 -- all the construct. For now just release right away.
7517 elsif Ekind_In (S, E_Entry, E_Loop) then
7520 -- In a procedure or a block, we release on exit of the
7521 -- procedure or block. ??? memory leak can be created by
7524 elsif Ekind_In (S, E_Block, E_Procedure) then
7525 Set_Uses_Sec_Stack (S, True);
7526 Check_Restriction (No_Secondary_Stack, Action);
7527 Set_Uses_Sec_Stack (Current_Scope, False);
7537 -- Create the transient block. Set the parent now since the block itself
7538 -- is not part of the tree.
7541 Make_Block_Statement (Loc,
7542 Identifier => New_Reference_To (Current_Scope, Loc),
7543 Declarations => Decls,
7544 Handled_Statement_Sequence =>
7545 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
7546 Has_Created_Identifier => True);
7547 Set_Parent (Block, Par);
7549 -- Insert actions stuck in the transient scopes as well as all freezing
7550 -- nodes needed by those actions.
7552 Insert_Actions_In_Scope_Around (Action);
7554 Insert := Prev (Action);
7555 if Present (Insert) then
7556 Freeze_All (First_Entity (Current_Scope), Insert);
7559 -- When the transient scope was established, we pushed the entry for
7560 -- the transient scope onto the scope stack, so that the scope was
7561 -- active for the installation of finalizable entities etc. Now we
7562 -- must remove this entry, since we have constructed a proper block.
7567 end Make_Transient_Block;
7569 ------------------------
7570 -- Node_To_Be_Wrapped --
7571 ------------------------
7573 function Node_To_Be_Wrapped return Node_Id is
7575 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
7576 end Node_To_Be_Wrapped;
7578 ----------------------------
7579 -- Set_Node_To_Be_Wrapped --
7580 ----------------------------
7582 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
7584 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
7585 end Set_Node_To_Be_Wrapped;
7587 ----------------------------------
7588 -- Store_After_Actions_In_Scope --
7589 ----------------------------------
7591 procedure Store_After_Actions_In_Scope (L : List_Id) is
7592 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7595 if Present (SE.Actions_To_Be_Wrapped_After) then
7596 Insert_List_Before_And_Analyze (
7597 First (SE.Actions_To_Be_Wrapped_After), L);
7600 SE.Actions_To_Be_Wrapped_After := L;
7602 if Is_List_Member (SE.Node_To_Be_Wrapped) then
7603 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7605 Set_Parent (L, SE.Node_To_Be_Wrapped);
7610 end Store_After_Actions_In_Scope;
7612 -----------------------------------
7613 -- Store_Before_Actions_In_Scope --
7614 -----------------------------------
7616 procedure Store_Before_Actions_In_Scope (L : List_Id) is
7617 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7620 if Present (SE.Actions_To_Be_Wrapped_Before) then
7621 Insert_List_After_And_Analyze (
7622 Last (SE.Actions_To_Be_Wrapped_Before), L);
7625 SE.Actions_To_Be_Wrapped_Before := L;
7627 if Is_List_Member (SE.Node_To_Be_Wrapped) then
7628 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7630 Set_Parent (L, SE.Node_To_Be_Wrapped);
7635 end Store_Before_Actions_In_Scope;
7637 --------------------------------
7638 -- Wrap_Transient_Declaration --
7639 --------------------------------
7641 -- If a transient scope has been established during the processing of the
7642 -- Expression of an Object_Declaration, it is not possible to wrap the
7643 -- declaration into a transient block as usual case, otherwise the object
7644 -- would be itself declared in the wrong scope. Therefore, all entities (if
7645 -- any) defined in the transient block are moved to the proper enclosing
7646 -- scope, furthermore, if they are controlled variables they are finalized
7647 -- right after the declaration. The finalization list of the transient
7648 -- scope is defined as a renaming of the enclosing one so during their
7649 -- initialization they will be attached to the proper finalization list.
7650 -- For instance, the following declaration :
7652 -- X : Typ := F (G (A), G (B));
7654 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7655 -- is expanded into :
7657 -- X : Typ := [ complex Expression-Action ];
7658 -- [Deep_]Finalize (_v1);
7659 -- [Deep_]Finalize (_v2);
7661 procedure Wrap_Transient_Declaration (N : Node_Id) is
7668 Encl_S := Scope (S);
7670 -- Insert Actions kept in the Scope stack
7672 Insert_Actions_In_Scope_Around (N);
7674 -- If the declaration is consuming some secondary stack, mark the
7675 -- enclosing scope appropriately.
7677 Uses_SS := Uses_Sec_Stack (S);
7680 -- Put the local entities back in the enclosing scope, and set the
7681 -- Is_Public flag appropriately.
7683 Transfer_Entities (S, Encl_S);
7685 -- Mark the enclosing dynamic scope so that the sec stack will be
7686 -- released upon its exit unless this is a function that returns on
7687 -- the sec stack in which case this will be done by the caller.
7689 if VM_Target = No_VM and then Uses_SS then
7690 S := Enclosing_Dynamic_Scope (S);
7692 if Ekind (S) = E_Function
7693 and then Requires_Transient_Scope (Etype (S))
7697 Set_Uses_Sec_Stack (S);
7698 Check_Restriction (No_Secondary_Stack, N);
7701 end Wrap_Transient_Declaration;
7703 -------------------------------
7704 -- Wrap_Transient_Expression --
7705 -------------------------------
7707 procedure Wrap_Transient_Expression (N : Node_Id) is
7708 Expr : constant Node_Id := Relocate_Node (N);
7709 Loc : constant Source_Ptr := Sloc (N);
7710 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
7711 Typ : constant Entity_Id := Etype (N);
7718 -- M : constant Mark_Id := SS_Mark;
7719 -- procedure Finalizer is ... (See Build_Finalizer)
7728 Insert_Actions (N, New_List (
7729 Make_Object_Declaration (Loc,
7730 Defining_Identifier => Temp,
7731 Object_Definition => New_Reference_To (Typ, Loc)),
7733 Make_Transient_Block (Loc,
7735 Make_Assignment_Statement (Loc,
7736 Name => New_Reference_To (Temp, Loc),
7737 Expression => Expr),
7738 Par => Parent (N))));
7740 Rewrite (N, New_Reference_To (Temp, Loc));
7741 Analyze_And_Resolve (N, Typ);
7742 end Wrap_Transient_Expression;
7744 ------------------------------
7745 -- Wrap_Transient_Statement --
7746 ------------------------------
7748 procedure Wrap_Transient_Statement (N : Node_Id) is
7749 Loc : constant Source_Ptr := Sloc (N);
7750 New_Stmt : constant Node_Id := Relocate_Node (N);
7755 -- M : constant Mark_Id := SS_Mark;
7756 -- procedure Finalizer is ... (See Build_Finalizer)
7766 Make_Transient_Block (Loc,
7768 Par => Parent (N)));
7770 -- With the scope stack back to normal, we can call analyze on the
7771 -- resulting block. At this point, the transient scope is being
7772 -- treated like a perfectly normal scope, so there is nothing
7773 -- special about it.
7775 -- Note: Wrap_Transient_Statement is called with the node already
7776 -- analyzed (i.e. Analyzed (N) is True). This is important, since
7777 -- otherwise we would get a recursive processing of the node when
7778 -- we do this Analyze call.
7781 end Wrap_Transient_Statement;
git://gcc.gnu.org / gcc.git / blob