1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Einfo.Entities; use Einfo.Entities;
34 with Einfo.Utils; use Einfo.Utils;
35 with Elists; use Elists;
36 with Errout; use Errout;
37 with Exp_Ch6; use Exp_Ch6;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Ch11; use Exp_Ch11;
40 with Exp_Dbug; use Exp_Dbug;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Disp; use Exp_Disp;
43 with Exp_Prag; use Exp_Prag;
44 with Exp_Tss; use Exp_Tss;
45 with Exp_Util; use Exp_Util;
46 with Freeze; use Freeze;
47 with GNAT_CUDA; use GNAT_CUDA;
48 with Inline; use Inline;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Output; use Output;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
57 with Sinfo; use Sinfo;
58 with Sinfo.Nodes; use Sinfo.Nodes;
59 with Sinfo.Utils; use Sinfo.Utils;
61 with Sem_Aux; use Sem_Aux;
62 with Sem_Ch7; use Sem_Ch7;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Res; use Sem_Res;
65 with Sem_Util; use Sem_Util;
66 with Snames; use Snames;
67 with Stand; use Stand;
68 with Tbuild; use Tbuild;
69 with Ttypes; use Ttypes;
70 with Uintp; use Uintp;
72 package body Exp_Ch7 is
74 -----------------------------
75 -- Finalization Management --
76 -----------------------------
78 -- This paragraph describes how Initialization/Adjustment/Finalization
79 -- procedures are generated and called. Two cases must be considered: types
80 -- that are controlled (Is_Controlled flag set) and composite types that
81 -- contain controlled components (Has_Controlled_Component flag set). In
82 -- the first case the procedures to call are the user-defined primitive
83 -- operations Initialize/Adjust/Finalize. In the second case, the compiler
84 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
85 -- charge of calling the former procedures on the controlled components.
87 -- Initialize calls: they are generated for either declarations or dynamic
88 -- allocations of controlled objects with no initial value. They are always
89 -- followed by an attachment to some finalization chain. For the dynamic
90 -- dynamic allocation case, this is the collection attached to the access
91 -- type definition; otherwise, this is the master of the current scope.
93 -- Adjust calls: they are generated on two occasions: (1) for declarations
94 -- or dynamic allocations of controlled objects with an initial value (with
95 -- the exception of function calls), (2) after an assignment. In the first
96 -- case they are followed by an attachment to the finalization chain, in
97 -- the second case they are not.
99 -- Finalization calls: they are generated on three occasions: (1) on scope
100 -- exit, (2) assignments, (3) unchecked deallocations. In case (3) objects
101 -- have to be detached from the finalization chain, in case (2) they must
102 -- not and in case (1) this is optional as we are exiting the scope anyway.
104 -- There are two kinds of finalization chain to which objects are attached,
105 -- depending on the way they are created. For objects (statically) declared
106 -- in a scope, the finalization chain is that of the master of the scope,
107 -- which is embodied in a Finalization_Master object. As per RM 7.6.1(11/3)
108 -- the finalization of the master (on scope exit) performs the finalization
109 -- of objects attached to its chain in the reverse order of their creation.
111 -- For dynamically allocated objects, the finalization chain is that of the
112 -- finalization collection of the access type through which the objects are
113 -- allocated, which is embodied in a Finalization_Collection object. As per
114 -- RM 7.6.1(11.1/3), the finalization of the collection performs the
115 -- finalization of objects attached to its chain in an arbitrary order.
117 -- A Finalization_Collection object is implemented as a controlled object
118 -- and its finalization is therefore driven by the finalization master of
119 -- the scope where it is declared. As per RM 7.6.1(11.2/3), for a named
120 -- access type, the Finalization_Collection object is declared in the list
121 -- of actions of its freeze node.
123 -- ??? For an anonymous access type, the implementation deviates from the
124 -- RM 7.6.1 clause as follows: all the anonymous access types with the same
125 -- designated type that are (implicitly) declared in a library unit share a
126 -- single Finalization_Collection object declared in the outermost scope of
127 -- the library unit, except if the designated type is declared in a dynamic
128 -- scope nested in the unit; in this case no Finalization_Collection object
129 -- is created. As a result, in the first case, objects allocated through
130 -- the anonymous access types are finalized when the library unit goes out
131 -- of scope, while in the second case, they are not finalized at all.
133 -- Here is a simple example of the expansion of a controlled block:
139 -- type Rec is record
154 -- Mnn : System.Finalization_Primitives.Finalization_Master;
156 -- XMN : aliased System.Finalization_Primitives.Master_Node;
161 -- System.Finalization_Primitives.Attach_To_Master
163 -- CtrlFD'unrestricted_access,
164 -- XMN'unrestricted_access,
170 -- YMN : aliased System.Finalization_Primitives.Master_Node;
172 -- System.Finalization_Primitives.Attach_To_Master
174 -- CtrlFD'unrestricted_access,
175 -- YMN'unrestricted_access,
178 -- type Rec is record
182 -- WMN : aliased System.Finalization_Primitives.Master_Node;
187 -- Deep_Initialize (W);
188 -- System.Finalization_Primitives.Attach_To_Master
190 -- Rec_FD'unrestricted_access,
191 -- WMN'unrestricted_access,
195 -- Deep_Finalize (W);
201 -- ZMN : aliaed System.Finalization_Primitives.Master_Node;
203 -- System.Finalization_Primitives.Attach_To_Master
205 -- Rec_FD'unrestricted_access,
206 -- ZMN'unrestricted_access,
209 -- procedure _Finalizer is
210 -- Ann : constant Boolean := Ada.Exceptions.Triggered_By_Abort;
211 -- Rnn : boolean := False;
215 -- System.Finalization_Primitives.Finalize_Master (Mnn);
221 -- if Rnn and then not Ann then
222 -- [program_error "finalize raised exception"]
228 -- Deep_Finalize (W);
235 -- In the case of a block containing a single controlled object, the master
236 -- degenerates into a single master node:
248 -- XMN : aliased System.Finalization_Primitives.Master_Node;
250 -- System.Finalization_Primitives.Attach_To_Node
252 -- CtrlFD'unrestricted_access,
253 -- XMN'unrestricted_access);
255 -- procedure _Finalizer is
256 -- Ann : constant Boolean := Ada.Exceptions.Triggered_By_Abort;
257 -- Rnn : boolean := False;
261 -- System.Finalization_Primitives.Finalize_Object (XMN);
267 -- if Rnn and then not Ann then
268 -- [program_error "finalize raised exception"]
278 -- Here is the version with a dynamically allocated object:
281 -- X : P_Ctrl := new Ctrl;
290 -- Cnn : System.Finalization_Primitives.Finalization_Collection_Ptr :=
291 -- P_CtrlFC'unrestricted_access;
293 -- Pnn : constant P_Ctrl := new Ctrl[...][...];
296 -- Initialize (Pnn.all);
297 -- System.Finalization_Primitives.Attach_To_Collection
299 -- CtrlFD'unrestricted_access,
304 -- X : P_Ctrl := Pnn;
306 -- The implementation uses two different strategies for the finalization
307 -- of (statically) declared objects and of dynamically allocated objects.
309 -- For (statically) declared objects, the attachment to the finalization
310 -- chain of the current scope and the call to the finalization procedure
311 -- are generated during a post-processing phase of the expansion. These
312 -- objects are first spotted in declarative parts and statement lists by
313 -- Requires_Cleanup_Actions; then Build_Finalizer is called on the parent
314 -- node to generate both the attachment and the finalization actions.
316 -- This post processing is fully transparent for the rest of the expansion
317 -- activities, in other words those have nothing to do or to care about.
318 -- However this default processing may not be sufficient in specific cases,
319 -- e.g. for the return object of an extended return statement in a function
320 -- whose result type is controlled: in this case, the return object must be
321 -- finalized only if the function returns abnormally. In order to deal with
322 -- these cases, it is possible to directly generate detachment actions (for
323 -- the return object case) or finalization actions (for transient objects)
324 -- during the rest of expansion activities.
326 -- These direct actions must be signalled to the post-processing machinery
327 -- and this is achieved through the handling of Master_Node objects, which
328 -- are the items actually chained in the finalization chains of masters.
329 -- With the default processing, they are created by Build_Finalizer for the
330 -- controlled objects spotted by Requires_Cleanup_Actions. But when direct
331 -- actions are carried out, they are generated by these actions and later
332 -- recognized by Requires_Cleanup_Actions and picked up by Build_Finalizer.
334 -- For dynamically allocated objects, there is no post-processing phase and
335 -- the attachment to the finalization chain of the access type, as well the
336 -- the detachment from this chain for unchecked deallocation, are generated
337 -- directly by the compiler during the expansion of allocators and calls to
338 -- instances of the Unchecked_Deallocation procedure.
340 --------------------------
341 -- Relaxed Finalization --
342 --------------------------
344 -- This paragraph describes the differences between the implementation of
345 -- finalization as specified by the Ada RM (called "strict" and documented
346 -- in the previous paragraph) and that of finalization as specified by the
347 -- GNAT RM (called "relaxed") for a second category of controlled objects.
349 -- For objects (statically) declared in a scope, the default implementation
350 -- documented in the previous paragraph is used for the scope as a whole as
351 -- soon as one controlled object with strict finalization is present in it,
352 -- including one transient controlled object. Otherwise, that is to say, if
353 -- all the controlled objects in the scope have relaxed finalization, then
354 -- no Finalization_Master is built for this scope, and all the objects are
355 -- finalized explicitly in the reverse order of their creation:
368 -- XMN : aliased System.Finalization_Primitives.Master_Node;
370 -- System.Finalization_Primitives.Attach_To_Node
372 -- CtrlFD'unrestricted_access,
373 -- XMN'unrestricted_access);
374 -- YMN : aliased System.Finalization_Primitives.Master_Node;
376 -- System.Finalization_Primitives.Attach_To_Node
378 -- CtrlFD'unrestricted_access,
379 -- YMN'unrestricted_access);
381 -- procedure _Finalizer is
384 -- System.Finalization_Primitives.Finalize_Object (YMN);
385 -- System.Finalization_Primitives.Finalize_Object (XMN);
395 -- Dynamically allocated objects with relaxed finalization need not be
396 -- finalized and, therefore, are not attached to any finalization chain.
398 type Final_Primitives is
399 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
400 -- This enumeration type is defined in order to ease sharing code for
401 -- building finalization procedures for composite types.
403 Name_Of : constant array (Final_Primitives) of Name_Id :=
404 (Initialize_Case => Name_Initialize,
405 Adjust_Case => Name_Adjust,
406 Finalize_Case => Name_Finalize,
407 Address_Case => Name_Finalize_Address);
408 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
409 (Initialize_Case => TSS_Deep_Initialize,
410 Adjust_Case => TSS_Deep_Adjust,
411 Finalize_Case => TSS_Deep_Finalize,
412 Address_Case => TSS_Finalize_Address);
414 function Allows_Finalization_Collection (Typ : Entity_Id) return Boolean;
415 -- Determine whether access type Typ may have a finalization collection
417 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
418 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
419 -- Has_Controlled_Component set and store them using the TSS mechanism.
421 function Build_Cleanup_Statements
423 Additional_Cleanup : List_Id) return List_Id;
424 -- Create the cleanup calls for an asynchronous call block, task master,
425 -- protected subprogram body, task allocation block or task body, or
426 -- additional cleanup actions parked on a transient block. If the context
427 -- does not contain the above constructs, the routine returns an empty
430 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
431 -- N is a construct that contains a handled sequence of statements, Fin_Id
432 -- is the entity of a finalizer. Create an At_End handler that covers the
433 -- statements of N and calls Fin_Id. If the handled statement sequence has
434 -- an exception handler, the statements will be wrapped in a block to avoid
435 -- unwanted interaction with the new At_End handler.
437 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
438 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
439 -- Has_Component_Component set and store them using the TSS mechanism.
441 --------------------------------
442 -- Transient Scope Management --
443 --------------------------------
445 -- A transient scope is needed when certain temporary objects are created
446 -- by the compiler. These temporary objects are allocated on the secondary
447 -- stack and/or need finalization, and the transient scope is responsible
448 -- for finalizing the objects and reclaiming the memory of the secondary
449 -- stack at the appropriate time. They are generally objects allocated to
450 -- store the result of a function returning an unconstrained or controlled
451 -- value. Expressions needing to be wrapped in a transient scope may appear
452 -- in three different contexts, which lead to different kinds of transient
455 -- 1. In a simple statement (procedure call, assignment, ...). In this
456 -- case the statement is wrapped into a transient block, which takes
457 -- care of the finalization actions as well as the secondary stack
458 -- deallocation, See Wrap_Transient_Statement for details.
460 -- 2. In an expression of a control structure (test in a If statement,
461 -- expression in a Case statement, ...). In this case the expression
462 -- is replaced by a temporary and the enclosing statement is wrapped
463 -- into a transient block, which takes care of the finalization actions
464 -- and the secondary stack deallocation. See Wrap_Transient_Expression
467 -- 3. In an expression of an object declaration. No wrapping is possible
468 -- here, so the finalization actions performed on the normal path, if
469 -- any, are done right after the declaration, and those performed on
470 -- the exceptional path, as well as the secondary stack deallocation,
471 -- are deferred to the enclosing scope. See Wrap_Transient_Declaration
474 -- A transient scope is created by calling Establish_Transient_Scope on the
475 -- node that needs to be serviced by it (the serviced node can subsequently
476 -- be retrieved by invoking Node_To_Be_Wrapped when the current scope is a
477 -- transient scope). Once this has been done, the normal processing of the
478 -- Insert_Actions procedures is blocked and the procedures are redirected
479 -- to the Store_xxx_Actions_In_Scope procedures and Store_Actions_In_Scope
480 -- is ultimately invoked to store the pending actions.
482 -- A transient scope is finalized by calling one of the Wrap_Transient_xxx
483 -- procedures depending on the context as explained above. They ultimately
484 -- invoke Insert_Actions_In_Scope_Around as per the following picture:
486 -- Wrap_Transient_Expression Wrap_Transient_Statement
489 -- Make_Transient_Block
491 -- Wrap_Transient_Declaration |
494 -- Insert_Actions_In_Scope_Around
496 procedure Insert_Actions_In_Scope_Around
499 Manage_SS : Boolean);
500 -- Insert the before-actions kept in the scope stack before N, and the
501 -- after-actions after N, which must be a member of a list. If Clean is
502 -- true, insert any cleanup actions kept in the scope stack and generate
503 -- required finalization actions for the before-actions and after-actions.
504 -- If Manage_SS is true, insert calls to mark/release the secondary stack.
506 function Make_Transient_Block
509 Par : Node_Id) return Node_Id;
510 -- Action is a single statement or object declaration. Par is the proper
511 -- parent of the generated block. Create a transient block whose name is
512 -- the current scope and the only handled statement is Action. If Action
513 -- involves controlled objects or secondary stack usage, the corresponding
514 -- cleanup actions are performed at the end of the block.
516 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
517 -- Shared processing for Store_xxx_Actions_In_Scope
519 -------------------------------------------
520 -- Unnesting procedures for CCG and LLVM --
521 -------------------------------------------
523 -- Expansion generates subprograms for controlled types management that
524 -- may appear in declarative lists in package declarations and bodies.
525 -- These subprograms appear within generated blocks that contain local
526 -- declarations and a call to finalization procedures. To ensure that
527 -- such subprograms get activation records when needed, we transform the
528 -- block into a procedure body, followed by a call to it in the same
531 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
532 -- The statement part of a package body that is a compilation unit may
533 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
534 -- Mode such subprograms must be handled as nested inside the (implicit)
535 -- elaboration procedure that executes that statement part. To handle
536 -- properly uplevel references we construct that subprogram explicitly,
537 -- to contain blocks and inner subprograms, the statement part becomes
538 -- a call to this subprogram. This is only done if blocks are present
539 -- in the statement list of the body. (It would be nice to unify this
540 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
541 -- they're doing very similar work, but are structured differently. ???)
543 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
544 -- Similarly, the declarations or statements in library-level packages may
545 -- have created blocks with nested subprograms. Such a block must be
546 -- transformed into a procedure followed by a call to it, so that unnesting
547 -- can handle uplevel references within these nested subprograms (typically
548 -- subprograms that handle finalization actions). This also applies to
549 -- nested packages, including instantiations, in which case it must
550 -- recursively process inner bodies.
552 procedure Check_Unnesting_In_Handlers (N : Node_Id);
553 -- Similarly, check for blocks with nested subprograms occurring within
554 -- a set of exception handlers associated with a package body N.
556 procedure Unnest_Block (Decl : Node_Id);
557 -- Blocks that contain nested subprograms with up-level references need to
558 -- create activation records for them. We do this by rewriting the block as
559 -- a procedure, followed by a call to it in the same declarative list, to
560 -- replicate the semantics of the original block.
562 -- A common source for such block is a transient block created for a
563 -- construct (declaration, assignment, etc.) that involves controlled
564 -- actions or secondary-stack management, in which case the nested
565 -- subprogram is a finalizer.
567 procedure Unnest_If_Statement (If_Stmt : Node_Id);
568 -- The separate statement lists associated with an if-statement (then part,
569 -- elsif parts, else part) may require unnesting if they directly contain
570 -- a subprogram body that references up-level objects. Each statement list
571 -- is traversed to locate such subprogram bodies, and if a part's statement
572 -- list contains a body, then the list is replaced with a new procedure
573 -- containing the part's statements followed by a call to the procedure.
574 -- Furthermore, any nested blocks, loops, or if statements will also be
575 -- traversed to determine the need for further unnesting transformations.
577 procedure Unnest_Statement_List (Stmts : in out List_Id);
578 -- A list of statements that directly contains a subprogram at its outer
579 -- level, that may reference objects declared in that same statement list,
580 -- is rewritten as a procedure containing the statement list Stmts (which
581 -- includes any such objects as well as the nested subprogram), followed by
582 -- a call to the new procedure, and Stmts becomes the list containing the
583 -- procedure and the call. This ensures that Unnest_Subprogram will later
584 -- properly handle up-level references from the nested subprogram to
585 -- objects declared earlier in statement list, by creating an activation
586 -- record and passing it to the nested subprogram. This procedure also
587 -- resets the Scope of objects declared in the statement list, as well as
588 -- the Scope of the nested subprogram, to refer to the new procedure.
589 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
590 -- only be called when known that the statement list contains a subprogram.
592 procedure Unnest_Loop (Loop_Stmt : Node_Id);
593 -- Top-level Loops that contain nested subprograms with up-level references
594 -- need to have activation records. We do this by rewriting the loop as a
595 -- procedure containing the loop, followed by a call to the procedure in
596 -- the same library-level declarative list, to replicate the semantics of
597 -- the original loop. Such loops can occur due to aggregate expansions and
600 -----------------------
601 -- Local Subprograms --
602 -----------------------
604 procedure Check_Visibly_Controlled
605 (Prim : Final_Primitives;
607 E : in out Entity_Id;
608 Cref : in out Node_Id);
609 -- The controlled operation declared for a derived type may not be
610 -- overriding, if the controlled operations of the parent type are hidden,
611 -- for example when the parent is a private type whose full view is
612 -- controlled. For other primitive operations we modify the name of the
613 -- operation to indicate that it is not overriding, but this is not
614 -- possible for Initialize, etc. because they have to be retrievable by
615 -- name. Before generating the proper call to one of these operations we
616 -- check whether Typ is known to be controlled at the point of definition.
617 -- If it is not then we must retrieve the hidden operation of the parent
618 -- and use it instead. This is one case that might be solved more cleanly
619 -- once Overriding pragmas or declarations are in place.
621 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
622 -- Check recursively whether a loop or block contains a subprogram that
623 -- may need an activation record.
625 function Convert_View
628 Typ : Entity_Id) return Node_Id;
629 -- Proc is one of the Initialize/Adjust/Finalize operations, Arg is the one
630 -- argument being passed to it, and Typ is its expected type. This function
631 -- will, if necessary, generate a conversion between the partial and full
632 -- views of Arg to match the type of the formal of Proc, or else force a
633 -- conversion to the class-wide type in the case where the operation is
636 function Finalize_Address_For_Node (Node : Entity_Id) return Entity_Id
637 renames Einfo.Entities.Finalization_Master_Node;
638 -- Return the Finalize_Address primitive for the object that has been
639 -- attached to a finalization Master_Node.
645 Skip_Self : Boolean := False) return Node_Id;
646 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
647 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
648 -- an adjust or finalization call. When flag Skip_Self is set, the related
649 -- action has an effect on the components only (if any).
651 function Make_Deep_Proc
652 (Prim : Final_Primitives;
654 Stmts : List_Id) return Entity_Id;
655 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
656 -- Deep_Finalize procedures according to the first parameter. These
657 -- procedures operate on the type Typ. The Stmts parameter gives the
658 -- body of the procedure.
660 function Make_Deep_Array_Body
661 (Prim : Final_Primitives;
662 Typ : Entity_Id) return List_Id;
663 -- This function generates the list of statements for implementing
664 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
665 -- the first parameter, these procedures operate on the array type Typ.
667 function Make_Deep_Record_Body
668 (Prim : Final_Primitives;
670 Is_Local : Boolean := False) return List_Id;
671 -- This function generates the list of statements for implementing
672 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
673 -- the first parameter, these procedures operate on the record type Typ.
674 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
675 -- whether the inner logic should be dictated by state counters.
677 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
678 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
679 -- Make_Deep_Record_Body. Generate the following statements:
682 -- type Acc_Typ is access all Typ;
683 -- for Acc_Typ'Storage_Size use 0;
685 -- [Deep_]Finalize (Acc_Typ (V).all);
688 procedure Set_Finalize_Address_For_Node (Node, Fin_Id : Entity_Id)
689 renames Einfo.Entities.Set_Finalization_Master_Node;
690 -- Set the Finalize_Address primitive for the object that has been
691 -- attached to a finalization Master_Node.
693 ----------------------------------
694 -- Attach_Object_To_Master_Node --
695 ----------------------------------
697 procedure Attach_Object_To_Master_Node
699 Master_Node : Entity_Id)
701 Loc : constant Source_Ptr := Sloc (Obj_Decl);
702 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
703 Func_Id : constant Entity_Id :=
704 (if Is_Return_Object (Obj_Id)
705 then Return_Applies_To (Scope (Obj_Id))
708 function Build_BIP_Cleanup_Stmts
709 (Func_Id : Entity_Id;
710 Obj_Addr : Node_Id) return Node_Id;
711 -- Func_Id denotes a build-in-place function. Generate the following
714 -- if BIPallocform > Secondary_Stack'Pos
715 -- and then BIPcollection /= null
718 -- type Ptr_Typ is access Fun_Typ;
719 -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all;
722 -- Free (Ptr_Typ (Obj_Addr));
726 -- Fun_Typ is the return type of the Func_Id.
728 -----------------------------
729 -- Build_BIP_Cleanup_Stmts --
730 -----------------------------
732 function Build_BIP_Cleanup_Stmts
733 (Func_Id : Entity_Id;
734 Obj_Addr : Node_Id) return Node_Id
736 Alloc_Id : constant Entity_Id :=
737 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
738 Decls : constant List_Id := New_List;
739 Fin_Coll_Id : constant Entity_Id :=
740 Build_In_Place_Formal (Func_Id, BIP_Collection);
741 Func_Typ : constant Entity_Id := Etype (Func_Id);
751 -- Pool_Id renames BIPstoragepool.all;
753 -- This formal is not added on ZFP as those targets do not
756 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
757 Pool_Id := Make_Temporary (Loc, 'P');
760 Make_Object_Renaming_Declaration (Loc,
761 Defining_Identifier => Pool_Id,
763 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
765 Make_Explicit_Dereference (Loc,
767 (Build_In_Place_Formal
768 (Func_Id, BIP_Storage_Pool), Loc))));
770 if Debug_Generated_Code then
771 Set_Debug_Info_Needed (Pool_Id);
778 -- Create an access type which uses the storage pool of the caller
781 -- type Ptr_Typ is access Func_Typ;
783 Ptr_Typ := Make_Temporary (Loc, 'P');
786 Make_Full_Type_Declaration (Loc,
787 Defining_Identifier => Ptr_Typ,
789 Make_Access_To_Object_Definition (Loc,
790 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
792 -- Perform minor decoration in order to set the collection and the
793 -- storage pool attributes.
795 Mutate_Ekind (Ptr_Typ, E_Access_Type);
796 Set_Finalization_Collection (Ptr_Typ, Fin_Coll_Id);
797 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
799 -- Create an explicit free statement. Note that the free uses the
800 -- caller's pool expressed as a renaming.
803 Make_Free_Statement (Loc,
805 Unchecked_Convert_To (Ptr_Typ, Obj_Addr));
807 Set_Storage_Pool (Free_Stmt, Pool_Id);
809 -- Create a block to house the dummy type and the instantiation as
810 -- well as to perform the cleanup the temporary.
816 -- Free (Ptr_Typ (Obj_Addr));
820 Make_Block_Statement (Loc,
821 Declarations => Decls,
822 Handled_Statement_Sequence =>
823 Make_Handled_Sequence_Of_Statements (Loc,
824 Statements => New_List (Free_Stmt)));
827 -- if BIPallocform > Secondary_Stack'Pos
828 -- and then BIPcollection /= null
835 Left_Opnd => New_Occurrence_Of (Alloc_Id, Loc),
837 Make_Integer_Literal (Loc,
838 UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack)))),
841 Left_Opnd => New_Occurrence_Of (Fin_Coll_Id, Loc),
842 Right_Opnd => Make_Null (Loc)));
850 Make_If_Statement (Loc,
852 Then_Statements => New_List (Free_Blk));
853 end Build_BIP_Cleanup_Stmts;
858 Master_Node_Attach : Node_Id;
859 Master_Node_Ins : Node_Id;
863 -- Start of processing for Attach_Object_To_Master_Node
866 -- Finalize_Address is not generated in CodePeer mode because the
867 -- body contains address arithmetic. So we don't want to generate
868 -- the attach in this case.
870 if CodePeer_Mode then
874 -- When the object is initialized by an aggregate, the attachment must
875 -- occur after the last aggregate assignment takes place; only then is
876 -- the object considered initialized. Likewise if it is initialized by
877 -- a build-in-place call: we must attach only after the call.
879 if Ekind (Obj_Id) in E_Constant | E_Variable then
880 if Present (Last_Aggregate_Assignment (Obj_Id)) then
881 Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id);
882 elsif Present (BIP_Initialization_Call (Obj_Id)) then
883 Master_Node_Ins := BIP_Initialization_Call (Obj_Id);
885 Master_Node_Ins := Obj_Decl;
889 Master_Node_Ins := Obj_Decl;
892 -- Handle the object type and the reference to the object
894 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
895 Obj_Typ := Etype (Obj_Id);
896 if not Is_Class_Wide_Type (Obj_Typ) then
897 Obj_Typ := Base_Type (Obj_Typ);
900 if Is_Access_Type (Obj_Typ) then
901 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
902 Obj_Typ := Available_View (Designated_Type (Obj_Typ));
905 -- If we are dealing with a return object of a build-in-place function
906 -- and its allocation has been done in the function, we additionally
907 -- need to detach it from the caller's finalization collection in order
908 -- to prevent double finalization.
911 and then Is_Build_In_Place_Function (Func_Id)
912 and then Needs_BIP_Collection (Func_Id)
915 Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P');
916 Param : constant Entity_Id :=
917 Make_Defining_Identifier (Loc, Name_V);
923 Fin_Stmts := Make_Finalize_Address_Stmts (Obj_Typ);
925 Append_To (Fin_Stmts,
926 Build_BIP_Cleanup_Stmts
927 (Func_Id, New_Occurrence_Of (Param, Loc)));
930 Make_Defining_Identifier (Loc,
932 (Obj_Typ, TSS_Finalize_Address));
935 Make_Subprogram_Body (Loc,
937 Make_Procedure_Specification (Loc,
938 Defining_Unit_Name => Fin_Id,
939 Parameter_Specifications => New_List (
940 Make_Parameter_Specification (Loc,
941 Defining_Identifier => Param,
943 New_Occurrence_Of (RTE (RE_Address), Loc)))),
945 Declarations => New_List (
946 Make_Full_Type_Declaration (Loc,
947 Defining_Identifier => Ptr_Typ,
949 Make_Access_To_Object_Definition (Loc,
951 Subtype_Indication =>
952 New_Occurrence_Of (Obj_Typ, Loc)))),
954 Handled_Statement_Sequence =>
955 Make_Handled_Sequence_Of_Statements (Loc,
956 Statements => Fin_Stmts));
958 Insert_After_And_Analyze
959 (Master_Node_Ins, Fin_Body, Suppress => All_Checks);
961 Master_Node_Ins := Fin_Body;
965 Fin_Id := Finalize_Address (Obj_Typ);
967 if No (Fin_Id) and then Ekind (Obj_Typ) = E_Class_Wide_Subtype then
968 Fin_Id := TSS (Obj_Typ, TSS_Finalize_Address);
972 -- Now build the attachment call that will initialize the object's
973 -- Master_Node using the object's address and finalization procedure.
975 Master_Node_Attach :=
976 Make_Procedure_Call_Statement (Loc,
978 New_Occurrence_Of (RTE (RE_Attach_Object_To_Node), Loc),
979 Parameter_Associations => New_List (
980 Make_Address_For_Finalize (Loc, Obj_Ref, Obj_Typ),
981 Make_Attribute_Reference (Loc,
983 New_Occurrence_Of (Fin_Id, Loc),
984 Attribute_Name => Name_Unrestricted_Access),
985 New_Occurrence_Of (Master_Node, Loc)));
987 Set_Finalize_Address_For_Node (Master_Node, Fin_Id);
989 Insert_After_And_Analyze
990 (Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks);
991 end Attach_Object_To_Master_Node;
993 ------------------------------------
994 -- Allows_Finalization_Collection --
995 ------------------------------------
997 function Allows_Finalization_Collection (Typ : Entity_Id) return Boolean is
998 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
999 -- Determine whether entity E is inside a wrapper package created for
1000 -- an instance of Ada.Unchecked_Deallocation.
1002 ------------------------------
1003 -- In_Deallocation_Instance --
1004 ------------------------------
1006 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
1007 Pkg : constant Entity_Id := Scope (E);
1008 Par : Node_Id := Empty;
1011 if Ekind (Pkg) = E_Package
1012 and then Present (Related_Instance (Pkg))
1013 and then Ekind (Related_Instance (Pkg)) = E_Procedure
1015 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
1019 and then Chars (Par) = Name_Unchecked_Deallocation
1020 and then Chars (Scope (Par)) = Name_Ada
1021 and then Scope (Scope (Par)) = Standard_Standard;
1025 end In_Deallocation_Instance;
1029 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1030 Ptr_Typ : constant Entity_Id :=
1031 Root_Type_Of_Full_View (Base_Type (Typ));
1033 -- Start of processing for Allows_Finalization_Collection
1036 -- Certain run-time configurations and targets do not provide support
1037 -- for controlled types and therefore do not need collections.
1039 if Restriction_Active (No_Finalization) then
1042 -- Do not consider C and C++ types since it is assumed that the non-Ada
1043 -- side will handle their cleanup.
1045 elsif Convention (Desig_Typ) = Convention_C
1046 or else Convention (Desig_Typ) = Convention_CPP
1050 -- Do not consider controlled types with relaxed finalization
1052 elsif Has_Relaxed_Finalization (Desig_Typ) then
1055 -- Do not consider an access type that returns on the secondary stack
1057 elsif Present (Associated_Storage_Pool (Ptr_Typ))
1058 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
1062 -- Do not consider an access type that can never allocate an object
1064 elsif No_Pool_Assigned (Ptr_Typ) then
1067 -- Do not consider an access type coming from an Unchecked_Deallocation
1068 -- instance. Even though the designated type may be controlled, the
1069 -- access type will never participate in any allocations.
1071 elsif In_Deallocation_Instance (Ptr_Typ) then
1074 -- Do not consider a non-library access type when No_Nested_Finalization
1075 -- is in effect, because finalization collections are controlled objects
1076 -- and, if created, will violate the restriction.
1078 elsif Restriction_Active (No_Nested_Finalization)
1079 and then not Is_Library_Level_Entity (Ptr_Typ)
1083 -- Do not consider an access type subject to pragma No_Heap_Finalization
1084 -- because objects allocated through such a type are not to be finalized
1085 -- when the access type goes out of scope.
1087 elsif No_Heap_Finalization (Ptr_Typ) then
1090 -- Do not create finalization collections in GNATprove mode because this
1091 -- causes unwanted extra expansion. Compilation in this mode must always
1092 -- keep the tree as close as possible to the original sources.
1094 elsif GNATprove_Mode then
1097 -- Otherwise the access type may use a finalization collection
1102 end Allows_Finalization_Collection;
1104 --------------------------------
1105 -- Build_Anonymous_Collection --
1106 --------------------------------
1108 procedure Build_Anonymous_Collection (Ptr_Typ : Entity_Id) is
1109 function Create_Anonymous_Collection
1110 (Desig_Typ : Entity_Id;
1111 Unit_Id : Entity_Id;
1112 Unit_Decl : Node_Id) return Entity_Id;
1113 -- Create a new anonymous collection for access type Ptr_Typ with
1114 -- designated type Desig_Typ. The declaration of the collection and
1115 -- its initialization are inserted in the declarative part of unit
1116 -- Unit_Decl. Unit_Id is the entity of Unit_Decl.
1118 function Current_Anonymous_Collection
1119 (Desig_Typ : Entity_Id;
1120 Unit_Id : Entity_Id) return Entity_Id;
1121 -- Find an anonymous collection declared in unit Unit_Id which services
1122 -- designated type Desig_Typ. If there is none, return Empty.
1124 ---------------------------------
1125 -- Create_Anonymous_Collection --
1126 ---------------------------------
1128 function Create_Anonymous_Collection
1129 (Desig_Typ : Entity_Id;
1130 Unit_Id : Entity_Id;
1131 Unit_Decl : Node_Id) return Entity_Id
1133 Loc : constant Source_Ptr := Sloc (Unit_Id);
1139 Unit_Spec : Node_Id;
1143 -- <FC_Id> : Finalization_Collection;
1145 FC_Id := Make_Temporary (Loc, 'A');
1148 Make_Object_Declaration (Loc,
1149 Defining_Identifier => FC_Id,
1150 Object_Definition =>
1151 New_Occurrence_Of (RTE (RE_Finalization_Collection), Loc));
1153 -- Find the declarative list of the unit
1155 if Nkind (Unit_Decl) = N_Package_Declaration then
1156 Unit_Spec := Specification (Unit_Decl);
1157 Decls := Visible_Declarations (Unit_Spec);
1161 Set_Visible_Declarations (Unit_Spec, Decls);
1164 -- Package body or subprogram case
1166 -- ??? A subprogram spec or body that acts as a compilation unit may
1167 -- contain a formal parameter of an anonymous access-to-controlled
1168 -- type initialized by an allocator.
1170 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
1172 -- There is no suitable place to create the collection because the
1173 -- subprogram is not in a declarative list.
1176 Decls := Declarations (Unit_Decl);
1180 Set_Declarations (Unit_Decl, Decls);
1184 Prepend_To (Decls, FC_Decl);
1186 -- Use the scope of the unit when analyzing the declaration of the
1187 -- collection and its initialization actions.
1189 Push_Scope (Unit_Id);
1193 -- Mark the collection as servicing this specific designated type
1195 Set_Anonymous_Designated_Type (FC_Id, Desig_Typ);
1197 -- Include it in the list of existing anonymous collections which
1198 -- appear in this unit. This effectively creates a mapping between
1199 -- collections and designated types, which in turn allows for the
1200 -- reuse of collections on a per-unit basis.
1202 All_FCs := Anonymous_Collections (Unit_Id);
1204 if No (All_FCs) then
1205 All_FCs := New_Elmt_List;
1206 Set_Anonymous_Collections (Unit_Id, All_FCs);
1209 Prepend_Elmt (FC_Id, All_FCs);
1212 end Create_Anonymous_Collection;
1214 ----------------------------------
1215 -- Current_Anonymous_Collection --
1216 ----------------------------------
1218 function Current_Anonymous_Collection
1219 (Desig_Typ : Entity_Id;
1220 Unit_Id : Entity_Id) return Entity_Id
1222 All_FCs : constant Elist_Id := Anonymous_Collections (Unit_Id);
1227 -- Inspect the list of anonymous collections declared within the unit
1228 -- looking for an existing collection which services the designated
1231 if Present (All_FCs) then
1232 FC_Elmt := First_Elmt (All_FCs);
1233 while Present (FC_Elmt) loop
1234 FC_Id := Node (FC_Elmt);
1236 -- The current collection services the same designated type.
1237 -- As a result, the collection can be reused and associated
1238 -- with another anonymous access-to-controlled type.
1240 if Anonymous_Designated_Type (FC_Id) = Desig_Typ then
1244 Next_Elmt (FC_Elmt);
1249 end Current_Anonymous_Collection;
1253 Desig_Typ : Entity_Id;
1255 Priv_View : Entity_Id;
1257 Unit_Decl : Node_Id;
1258 Unit_Id : Entity_Id;
1260 -- Start of processing for Build_Anonymous_Collection
1263 -- Nothing to do if the circumstances do not allow for a finalization
1266 if not Allows_Finalization_Collection (Ptr_Typ) then
1270 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
1271 Unit_Id := Unique_Defining_Entity (Unit_Decl);
1273 -- The compilation unit is a package instantiation. In this case the
1274 -- anonymous collection is associated with the package spec, as both
1275 -- the spec and body appear at the same level.
1277 if Nkind (Unit_Decl) = N_Package_Body
1278 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
1280 Unit_Id := Corresponding_Spec (Unit_Decl);
1281 Unit_Decl := Unit_Declaration_Node (Unit_Id);
1284 -- Use the initial declaration of the designated type when it denotes
1285 -- the full view of an incomplete or private type. This ensures that
1286 -- types with one and two views are treated the same.
1288 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
1289 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
1291 if Present (Priv_View) then
1292 Desig_Typ := Priv_View;
1295 -- For a designated type not declared at library level, we cannot create
1296 -- a finalization collection attached to an outer unit since this would
1297 -- generate dangling references to the dynamic scope through access-to-
1298 -- procedure values designating the local Finalize_Address primitive.
1300 Scop := Enclosing_Dynamic_Scope (Desig_Typ);
1301 if Scop /= Standard_Standard
1302 and then Scope_Depth (Scop) > Scope_Depth (Unit_Id)
1307 -- Determine whether the current semantic unit already has an anonymous
1308 -- collection which services the designated type.
1310 FC_Id := Current_Anonymous_Collection (Desig_Typ, Unit_Id);
1312 -- If this is not the case, create a new collection
1315 FC_Id := Create_Anonymous_Collection (Desig_Typ, Unit_Id, Unit_Decl);
1318 Set_Finalization_Collection (Ptr_Typ, FC_Id);
1319 end Build_Anonymous_Collection;
1321 ----------------------------
1322 -- Build_Array_Deep_Procs --
1323 ----------------------------
1325 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
1329 (Prim => Initialize_Case,
1331 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
1333 if not Is_Inherently_Limited_Type (Typ) then
1336 (Prim => Adjust_Case,
1338 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
1341 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
1342 -- suppressed since these routine will not be used.
1344 if not Restriction_Active (No_Finalization) then
1347 (Prim => Finalize_Case,
1349 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
1351 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
1353 if not CodePeer_Mode then
1356 (Prim => Address_Case,
1358 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
1361 end Build_Array_Deep_Procs;
1363 ------------------------------
1364 -- Build_Cleanup_Statements --
1365 ------------------------------
1367 function Build_Cleanup_Statements
1369 Additional_Cleanup : List_Id) return List_Id
1371 Is_Asynchronous_Call : constant Boolean :=
1372 Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N);
1373 Is_Master : constant Boolean :=
1374 Nkind (N) /= N_Entry_Body and then Is_Task_Master (N);
1375 Is_Protected_Subp_Body : constant Boolean :=
1376 Nkind (N) = N_Subprogram_Body
1377 and then Is_Protected_Subprogram_Body (N);
1378 Is_Task_Allocation : constant Boolean :=
1379 Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N);
1380 Is_Task_Body : constant Boolean :=
1381 Nkind (Original_Node (N)) = N_Task_Body;
1383 Loc : constant Source_Ptr := Sloc (N);
1384 Stmts : constant List_Id := New_List;
1387 if Is_Task_Body then
1388 if Restricted_Profile then
1390 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
1392 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
1395 elsif Is_Master then
1396 if Restriction_Active (No_Task_Hierarchy) = False then
1397 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
1400 -- Add statements to undefer abort.
1402 elsif Is_Protected_Subp_Body then
1403 if Abort_Allowed then
1404 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
1407 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
1408 -- tasks. Other unactivated tasks are completed by Complete_Task or
1411 -- NOTE: The generated code references _chain, a local object
1413 elsif Is_Task_Allocation then
1416 -- Expunge_Unactivated_Tasks (_chain);
1418 -- where _chain is the list of tasks created by the allocator but not
1419 -- yet activated. This list will be empty unless the block completes
1423 Make_Procedure_Call_Statement (Loc,
1426 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
1427 Parameter_Associations => New_List (
1428 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
1430 -- Attempt to cancel an asynchronous entry call whenever the block which
1431 -- contains the abortable part is exited.
1433 -- NOTE: The generated code references Cnn, a local object
1435 elsif Is_Asynchronous_Call then
1437 Cancel_Param : constant Entity_Id :=
1438 Entry_Cancel_Parameter (Entity (Identifier (N)));
1441 -- If it is of type Communication_Block, this must be a protected
1442 -- entry call. Generate:
1444 -- if Enqueued (Cancel_Param) then
1445 -- Cancel_Protected_Entry_Call (Cancel_Param);
1448 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
1450 Make_If_Statement (Loc,
1452 Make_Function_Call (Loc,
1454 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
1455 Parameter_Associations => New_List (
1456 New_Occurrence_Of (Cancel_Param, Loc))),
1458 Then_Statements => New_List (
1459 Make_Procedure_Call_Statement (Loc,
1462 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
1463 Parameter_Associations => New_List (
1464 New_Occurrence_Of (Cancel_Param, Loc))))));
1466 -- Asynchronous delay, generate:
1467 -- Cancel_Async_Delay (Cancel_Param);
1469 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1471 Make_Procedure_Call_Statement (Loc,
1473 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
1474 Parameter_Associations => New_List (
1475 Make_Attribute_Reference (Loc,
1477 New_Occurrence_Of (Cancel_Param, Loc),
1478 Attribute_Name => Name_Unchecked_Access))));
1480 -- Task entry call, generate:
1481 -- Cancel_Task_Entry_Call (Cancel_Param);
1485 Make_Procedure_Call_Statement (Loc,
1487 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
1488 Parameter_Associations => New_List (
1489 New_Occurrence_Of (Cancel_Param, Loc))));
1494 Append_List_To (Stmts, Additional_Cleanup);
1496 end Build_Cleanup_Statements;
1498 -----------------------------
1499 -- Build_Controlling_Procs --
1500 -----------------------------
1502 procedure Build_Controlling_Procs (Typ : Entity_Id) is
1504 if Is_Array_Type (Typ) then
1505 Build_Array_Deep_Procs (Typ);
1506 else pragma Assert (Is_Record_Type (Typ));
1507 Build_Record_Deep_Procs (Typ);
1509 end Build_Controlling_Procs;
1511 -----------------------------
1512 -- Build_Exception_Handler --
1513 -----------------------------
1515 function Build_Exception_Handler
1516 (Data : Finalization_Exception_Data;
1517 For_Library : Boolean := False) return Node_Id
1520 Proc_To_Call : Entity_Id;
1525 pragma Assert (Present (Data.Raised_Id));
1527 if Exception_Extra_Info
1528 or else (For_Library and not Restricted_Profile)
1530 if Exception_Extra_Info then
1534 -- Get_Current_Excep.all
1537 Make_Function_Call (Data.Loc,
1539 Make_Explicit_Dereference (Data.Loc,
1542 (RTE (RE_Get_Current_Excep), Data.Loc)));
1549 Except := Make_Null (Data.Loc);
1552 if For_Library and then not Restricted_Profile then
1553 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1554 Actuals := New_List (Except);
1557 Proc_To_Call := RTE (RE_Save_Occurrence);
1559 -- The dereference occurs only when Exception_Extra_Info is true,
1560 -- and therefore Except is not null.
1564 New_Occurrence_Of (Data.E_Id, Data.Loc),
1565 Make_Explicit_Dereference (Data.Loc, Except));
1571 -- if not Raised_Id then
1572 -- Raised_Id := True;
1574 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1576 -- Save_Library_Occurrence (Get_Current_Excep.all);
1581 Make_If_Statement (Data.Loc,
1583 Make_Op_Not (Data.Loc,
1584 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1586 Then_Statements => New_List (
1587 Make_Assignment_Statement (Data.Loc,
1588 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1589 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1591 Make_Procedure_Call_Statement (Data.Loc,
1593 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1594 Parameter_Associations => Actuals))));
1599 -- Raised_Id := True;
1602 Make_Assignment_Statement (Data.Loc,
1603 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1604 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1612 Make_Exception_Handler (Data.Loc,
1613 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1614 Statements => Stmts);
1615 end Build_Exception_Handler;
1617 -----------------------------------
1618 -- Build_Finalization_Collection --
1619 -----------------------------------
1621 procedure Build_Finalization_Collection
1623 For_Lib_Level : Boolean := False;
1624 For_Private : Boolean := False;
1625 Context_Scope : Entity_Id := Empty;
1626 Insertion_Node : Node_Id := Empty)
1628 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1629 -- Finalization collections built for named access types are associated
1630 -- with the full view (if applicable) as a consequence of freezing. The
1631 -- full view criteria does not apply to anonymous access types because
1632 -- those cannot have a private and a full view.
1634 -- Start of processing for Build_Finalization_Collection
1637 -- Nothing to do if the circumstances do not allow for a finalization
1640 if not Allows_Finalization_Collection (Typ) then
1643 -- Various machinery such as freezing may have already created a
1644 -- finalization collection.
1646 elsif Present (Finalization_Collection (Ptr_Typ)) then
1651 Actions : constant List_Id := New_List;
1652 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1654 Fin_Coll_Id : Entity_Id;
1655 Pool_Id : Entity_Id;
1658 -- Source access types use fixed names since the collection will be
1659 -- inserted in the same source unit only once. The only exception to
1660 -- this are instances using the same access type as generic actual.
1662 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1664 Make_Defining_Identifier (Loc,
1665 Chars => New_External_Name (Chars (Ptr_Typ), "FC"));
1667 -- Internally generated access types use temporaries as their names
1668 -- due to possible collision with identical names coming from other
1672 Fin_Coll_Id := Make_Temporary (Loc, 'F');
1675 Set_Finalization_Collection (Ptr_Typ, Fin_Coll_Id);
1678 -- <Ptr_Typ>FC : aliased Finalization_Collection;
1681 Make_Object_Declaration (Loc,
1682 Defining_Identifier => Fin_Coll_Id,
1683 Aliased_Present => True,
1684 Object_Definition =>
1685 New_Occurrence_Of (RTE (RE_Finalization_Collection), Loc)));
1687 if Debug_Generated_Code then
1688 Set_Debug_Info_Needed (Fin_Coll_Id);
1691 -- Set the associated pool and primitive Finalize_Address of the new
1692 -- finalization collection.
1694 -- The access type has a user-defined storage pool, use it
1696 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1697 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1699 -- Otherwise the default choice is the global storage pool
1702 Pool_Id := RTE (RE_Global_Pool_Object);
1703 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1706 -- A finalization collection created for an access designating a type
1707 -- with private components is inserted before a context-dependent
1712 -- At this point both the scope of the context and the insertion
1713 -- mode must be known.
1715 pragma Assert (Present (Context_Scope));
1716 pragma Assert (Present (Insertion_Node));
1718 Push_Scope (Context_Scope);
1720 -- Treat use clauses as declarations and insert directly in front
1723 if Nkind (Insertion_Node) in
1724 N_Use_Package_Clause | N_Use_Type_Clause
1726 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1728 Insert_Actions (Insertion_Node, Actions);
1733 -- The finalization collection belongs to an access type related
1734 -- to a build-in-place function call used to initialize a library
1735 -- level object. The collection must be inserted in front of the
1736 -- access type declaration denoted by Insertion_Node.
1738 elsif For_Lib_Level then
1739 pragma Assert (Present (Insertion_Node));
1740 Insert_Actions (Insertion_Node, Actions);
1742 -- Otherwise the finalization collection and its initialization
1743 -- become a part of the freeze node.
1746 Append_Freeze_Actions (Ptr_Typ, Actions);
1749 Analyze_List (Actions);
1751 -- When the type the finalization collection is being generated for
1752 -- was created to store a 'Old object, then mark it as such so its
1753 -- finalization can be delayed until after postconditions have been
1756 if Stores_Attribute_Old_Prefix (Ptr_Typ) then
1757 Set_Stores_Attribute_Old_Prefix (Fin_Coll_Id);
1760 end Build_Finalization_Collection;
1762 ---------------------
1763 -- Build_Finalizer --
1764 ---------------------
1766 procedure Build_Finalizer
1768 Clean_Stmts : List_Id;
1769 Mark_Id : Entity_Id;
1770 Defer_Abort : Boolean;
1771 Fin_Id : out Entity_Id)
1773 Acts_As_Clean : constant Boolean :=
1776 (Present (Clean_Stmts)
1777 and then Is_Non_Empty_List (Clean_Stmts));
1779 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1780 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1781 For_Package : constant Boolean :=
1782 For_Package_Body or else For_Package_Spec;
1783 Loc : constant Source_Ptr := Sloc (N);
1785 -- NOTE: Local variable declarations are conservative and do not create
1786 -- structures right from the start. Entities and lists are created once
1787 -- it has been established that N has at least one controlled object.
1790 -- Holds the number of controlled objects encountered so far
1792 Decls : List_Id := No_List;
1793 -- Declarative region of N (if available). If N is a package declaration
1794 -- Decls denotes the visible declarations.
1796 Finalizer_Data : Finalization_Exception_Data;
1797 -- Data for the exception
1799 Finalizer_Decls : List_Id := No_List;
1800 -- Local variable declarations
1802 Finalization_Master : Entity_Id;
1803 -- The Finalization Master object
1805 Finalizer_Stmts : List_Id := No_List;
1806 -- The statement list of the finalizer body
1808 Has_Strict_Ctrl_Objs : Boolean := False;
1809 -- A general flag which indicates whether N has at least one controlled
1810 -- object with strict semantics for finalization.
1812 Has_Tagged_Types : Boolean := False;
1813 -- A general flag which indicates whether N has at least one library-
1814 -- level tagged type declaration.
1816 HSS : Node_Id := Empty;
1817 -- The sequence of statements of N (if available)
1819 Prev_At_End : Entity_Id := Empty;
1820 -- The previous at end procedure of the handled statements block of N
1822 Priv_Decls : List_Id := No_List;
1823 -- The private declarations of N if N is a package declaration
1825 Spec_Id : Entity_Id := Empty;
1826 Stmts : List_Id := No_List;
1828 Tagged_Type_Stmts : List_Id := No_List;
1829 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1830 -- tagged types found in N.
1832 -----------------------
1833 -- Local subprograms --
1834 -----------------------
1836 procedure Build_Components;
1837 -- Create all entites and initialize all lists used in the creation of
1840 procedure Create_Finalizer;
1841 -- Create the spec and body of the finalizer and insert them in the
1842 -- proper place in the tree depending on the context.
1844 function Has_Ctrl_Objs return Boolean is (Count > 0);
1845 -- Return true if N contains a least one controlled object
1847 function New_Finalizer_Name
1848 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
1849 -- Create a fully qualified name of a package spec or body finalizer.
1850 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1852 procedure Process_Declarations
1854 Preprocess : Boolean := False);
1855 -- Inspect a list of declarations or statements which may contain
1856 -- objects that need finalization. When flag Preprocess is set, the
1857 -- routine will simply count the total number of controlled objects in
1858 -- Decls and set Count accordingly.
1860 procedure Process_Object_Declaration
1862 Is_Protected : Boolean := False);
1863 -- Generate all the machinery associated with the finalization of a
1864 -- single object. Flag Is_Protected is set when Decl denotes a simple
1865 -- protected object.
1867 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1868 -- Generate all the code necessary to unregister the external tag of a
1871 ----------------------
1872 -- Build_Components --
1873 ----------------------
1875 procedure Build_Components is
1876 Constraints : List_Id;
1877 Master_Decl : Node_Id;
1878 Master_Name : Name_Id;
1881 pragma Assert (Present (Decls));
1883 -- If the context contains controlled objects with strict semantics
1884 -- for finalization, then we create the finalization master, unless
1885 -- there is a single such object: in this common case, we'll directly
1886 -- finalize the object.
1888 if Has_Strict_Ctrl_Objs then
1890 if For_Package_Spec then
1892 New_External_Name (Name_uMaster, Suffix => "_spec");
1893 elsif For_Package_Body then
1895 New_External_Name (Name_uMaster, Suffix => "_body");
1897 Master_Name := New_Internal_Name ('M');
1900 Finalization_Master :=
1901 Make_Defining_Identifier (Loc, Master_Name);
1903 -- The master is statically parameterized by the context
1905 Constraints := New_List;
1906 Append_To (Constraints,
1907 New_Occurrence_Of (Boolean_Literals (Exceptions_OK), Loc));
1908 Append_To (Constraints,
1910 (Boolean_Literals (Exception_Extra_Info), Loc));
1911 Append_To (Constraints,
1912 New_Occurrence_Of (Boolean_Literals (For_Package), Loc));
1915 Make_Object_Declaration (Loc,
1916 Defining_Identifier => Finalization_Master,
1917 Object_Definition =>
1918 Make_Subtype_Indication (Loc,
1921 (RTE (RE_Finalization_Master), Loc),
1923 Make_Index_Or_Discriminant_Constraint (Loc,
1924 Constraints => Constraints)));
1926 Prepend_To (Decls, Master_Decl);
1927 Analyze (Master_Decl, Suppress => All_Checks);
1930 if Exceptions_OK then
1931 Finalizer_Decls := New_List;
1932 Build_Object_Declarations
1933 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1937 -- If the context requires additional cleanup, the finalization
1938 -- machinery is added after the cleanup code.
1940 if Acts_As_Clean then
1941 Finalizer_Stmts := Clean_Stmts;
1943 Finalizer_Stmts := New_List;
1946 if Has_Tagged_Types then
1947 Tagged_Type_Stmts := New_List;
1949 end Build_Components;
1951 ----------------------
1952 -- Create_Finalizer --
1953 ----------------------
1955 procedure Create_Finalizer is
1956 Body_Id : Entity_Id;
1962 -- Step 1: Creation of the finalizer name
1964 -- Packages must use a distinct name for their finalizers since the
1965 -- binder will have to generate calls to them by name. The name is
1966 -- of the following form:
1968 -- xx__yy__finalize_[spec|body]
1971 Fin_Id := Make_Defining_Identifier
1972 (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
1973 Set_Has_Qualified_Name (Fin_Id);
1974 Set_Has_Fully_Qualified_Name (Fin_Id);
1976 -- The default name is _finalizer
1980 Make_Defining_Identifier (Loc,
1981 Chars => New_External_Name (Name_uFinalizer));
1982 Set_Is_Finalizer (Fin_Id);
1984 -- The visibility semantics of At_End handlers force a strange
1985 -- separation of spec and body for stack-related finalizers:
1987 -- declare : Enclosing_Scope
1988 -- procedure _finalizer;
1990 -- <controlled objects>
1991 -- procedure _finalizer is
1997 -- Both spec and body are within the same construct and scope, but
1998 -- the body is part of the handled sequence of statements. This
1999 -- placement confuses the elaboration mechanism on targets where
2000 -- At_End handlers are expanded into "when all others" handlers:
2003 -- when all others =>
2004 -- _finalizer; -- appears to require elab checks
2009 -- Since the compiler guarantees that the body of a _finalizer is
2010 -- always inserted in the same construct where the At_End handler
2011 -- resides, there is no need for elaboration checks.
2013 Set_Kill_Elaboration_Checks (Fin_Id);
2015 -- Inlining the finalizer produces a substantial speedup at -O2.
2016 -- It is inlined by default at -O3. Either way, it is called
2017 -- exactly twice (once on the normal path, and once for
2018 -- exceptions/abort), so this won't bloat the code too much.
2020 Set_Is_Inlined (Fin_Id);
2023 if Debug_Generated_Code then
2024 Set_Debug_Info_Needed (Fin_Id);
2027 -- Step 2: Creation of the finalizer specification
2030 -- procedure Fin_Id;
2033 Make_Subprogram_Declaration (Loc,
2035 Make_Procedure_Specification (Loc,
2036 Defining_Unit_Name => Fin_Id));
2039 Set_Is_Exported (Fin_Id);
2040 Set_Interface_Name (Fin_Id,
2041 Make_String_Literal (Loc,
2042 Strval => Get_Name_String (Chars (Fin_Id))));
2045 -- Step 3: Creation of the finalizer body
2047 -- Add the library-level tagged type unregistration machinery before
2048 -- the finalization circuitry. This ensures that external tags will
2049 -- be removed even if a finalization exception occurs at some point.
2051 if Has_Tagged_Types then
2052 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
2055 -- Add a call to the previous At_End handler if it exists. The call
2056 -- must always precede the finalization circuitry.
2058 if Present (Prev_At_End) then
2059 Prepend_To (Finalizer_Stmts,
2060 Make_Procedure_Call_Statement (Loc, Prev_At_End));
2062 -- Clear the At_End handler since we have already generated the
2063 -- proper replacement call for it.
2065 Set_At_End_Proc (HSS, Empty);
2068 -- If there are no controlled objects to be finalized, generate;
2070 -- procedure Fin_Id is
2072 -- Abort_Defer; -- Added if abort is allowed
2073 -- <call to Prev_At_End> -- Added if exists
2074 -- <tag unregistration> -- Added if Has_Tagged_Types
2075 -- <cleanup statements> -- Added if Acts_As_Clean
2076 -- <stack release> -- Added if Mark_Id exists
2077 -- Abort_Undefer; -- Added if abort is allowed
2080 -- If there are strict controlled objects to be finalized, generate:
2082 -- procedure Fin_Id is
2083 -- Abort : constant Boolean := Triggered_By_Abort;
2084 -- E : Exception_Occurrence;
2085 -- Raised : Boolean := False;
2087 -- Abort_Defer; -- Added if abort is allowed
2088 -- <call to Prev_At_End> -- Added if exists
2089 -- <tag unregistration> -- Added if Has_Tagged_Types
2090 -- <cleanup statements> -- Added if Acts_As_Clean
2091 -- <finalization statements>
2092 -- <stack release> -- Added if Mark_Id exists
2093 -- Abort_Undefer; -- Added if abort is allowed
2094 -- <exception propagation>
2097 -- If there are only controlled objects with relaxed semantics for
2098 -- finalization, only the <finalization statements> are generated.
2100 if Has_Strict_Ctrl_Objs and then Count > 1 then
2102 Make_Procedure_Call_Statement (Loc,
2104 New_Occurrence_Of (RTE (RE_Finalize_Master), Loc),
2105 Parameter_Associations =>
2106 New_List (New_Occurrence_Of (Finalization_Master, Loc)));
2108 -- For CodePeer, the exception handlers normally generated here
2109 -- generate complex flowgraphs which result in capacity problems.
2110 -- Omitting these handlers for CodePeer is justified as follows:
2112 -- If a handler is dead, then omitting it is surely ok
2114 -- If a handler is live, then CodePeer should flag the
2115 -- potentially-exception-raising construct that causes it
2116 -- to be live. That is what we are interested in, not what
2117 -- happens after the exception is raised.
2119 if Exceptions_OK and not CodePeer_Mode then
2121 Make_Block_Statement (Loc,
2122 Handled_Statement_Sequence =>
2123 Make_Handled_Sequence_Of_Statements (Loc,
2124 Statements => New_List (Fin_Call),
2126 Exception_Handlers => New_List (
2127 Build_Exception_Handler
2128 (Finalizer_Data, For_Package))));
2131 Append_To (Finalizer_Stmts, Fin_Call);
2134 -- Release the secondary stack
2136 if Present (Mark_Id) then
2138 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
2141 -- If the context is a build-in-place function, the secondary
2142 -- stack must be released, unless the build-in-place function
2143 -- itself is returning on the secondary stack. Generate:
2145 -- if BIP_Alloc_Form /= Secondary_Stack then
2146 -- SS_Release (Mark_Id);
2149 -- Note that if the function returns on the secondary stack,
2150 -- then the responsibility of reclaiming the space is always
2151 -- left to the caller (recursively if needed).
2153 if Nkind (N) = N_Subprogram_Body then
2155 Spec_Id : constant Entity_Id :=
2156 Unique_Defining_Entity (N);
2157 BIP_SS : constant Boolean :=
2158 Is_Build_In_Place_Function (Spec_Id)
2159 and then Needs_BIP_Alloc_Form (Spec_Id);
2163 Make_If_Statement (Loc,
2168 (Build_In_Place_Formal
2169 (Spec_Id, BIP_Alloc_Form), Loc),
2171 Make_Integer_Literal (Loc,
2173 (BIP_Allocation_Form'Pos
2174 (Secondary_Stack)))),
2176 Then_Statements => New_List (Release));
2181 Append_To (Finalizer_Stmts, Release);
2185 -- Protect the statements with abort defer/undefer. This is only when
2186 -- aborts are allowed and the cleanup statements require deferral or
2187 -- there are controlled objects to be finalized. Note that the abort
2188 -- defer/undefer pair does not require an extra block because the
2189 -- finalization exception is caught in its corresponding finalization
2190 -- block. As a result, the call to Abort_Defer always takes place.
2192 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
2193 Prepend_To (Finalizer_Stmts,
2194 Build_Runtime_Call (Loc, RE_Abort_Defer));
2196 Append_To (Finalizer_Stmts,
2197 Build_Runtime_Call (Loc, RE_Abort_Undefer));
2200 -- The local exception does not need to be reraised for library-level
2201 -- finalizers. Note that this action must be carried out after object
2202 -- cleanup, secondary stack release, and abort undeferral. Generate:
2204 -- if Raised and then not Abort then
2205 -- Raise_From_Controlled_Operation (E);
2208 if Has_Strict_Ctrl_Objs and Exceptions_OK and not For_Package then
2209 Append_To (Finalizer_Stmts,
2210 Build_Raise_Statement (Finalizer_Data));
2213 -- Create the body of the finalizer
2215 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
2217 if Debug_Generated_Code then
2218 Set_Debug_Info_Needed (Body_Id);
2222 Set_Has_Qualified_Name (Body_Id);
2223 Set_Has_Fully_Qualified_Name (Body_Id);
2227 Make_Subprogram_Body (Loc,
2229 Make_Procedure_Specification (Loc,
2230 Defining_Unit_Name => Body_Id),
2231 Declarations => Finalizer_Decls,
2232 Handled_Statement_Sequence =>
2233 Make_Handled_Sequence_Of_Statements (Loc,
2234 Statements => Finalizer_Stmts));
2236 -- Step 4: Spec and body insertion, analysis
2240 -- If a package spec has private declarations, both the finalizer
2241 -- spec and body are inserted at the end of this list.
2243 if For_Package_Spec and then Present (Priv_Decls) then
2244 Append_To (Priv_Decls, Fin_Spec);
2245 Append_To (Priv_Decls, Fin_Body);
2247 -- Otherwise, and for a package body, both the finalizer spec and
2248 -- body are inserted at the end of the package declarations.
2251 Append_To (Decls, Fin_Spec);
2252 Append_To (Decls, Fin_Body);
2258 -- Insert the spec for the finalizer. The At_End handler must be
2259 -- able to call the body which resides in a nested structure.
2262 -- procedure Fin_Id; -- Spec
2264 -- <objects and possibly statements>
2265 -- procedure Fin_Id is ... -- Body
2268 -- Fin_Id; -- At_End handler
2271 pragma Assert (Present (Decls));
2273 Append_To (Decls, Fin_Spec);
2275 -- When the finalizer acts solely as a cleanup routine, the body
2276 -- is inserted right after the spec.
2278 if Acts_As_Clean and not Has_Ctrl_Objs then
2279 Insert_After (Fin_Spec, Fin_Body);
2281 -- In other cases the body is inserted after the last statement
2284 -- Manually freeze the spec. This is somewhat of a hack because
2285 -- a subprogram is frozen when its body is seen and the freeze
2286 -- node appears right before the body. However, in this case,
2287 -- the spec must be frozen earlier since the At_End handler
2288 -- must be able to call it.
2291 -- procedure Fin_Id; -- Spec
2292 -- [Fin_Id] -- Freeze node
2296 -- Fin_Id; -- At_End handler
2299 Ensure_Freeze_Node (Fin_Id);
2300 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2301 Set_Is_Frozen (Fin_Id);
2303 Append_To (Stmts, Fin_Body);
2307 Analyze (Fin_Spec, Suppress => All_Checks);
2308 Analyze (Fin_Body, Suppress => All_Checks);
2310 -- Never consider that the finalizer procedure is enabled Ghost, even
2311 -- when the corresponding unit is Ghost, as this would lead to an
2312 -- an external name with a ___ghost_ prefix that the binder cannot
2313 -- generate, as it has no knowledge of the Ghost status of units.
2315 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2316 end Create_Finalizer;
2318 ------------------------
2319 -- New_Finalizer_Name --
2320 ------------------------
2322 function New_Finalizer_Name
2323 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
2325 procedure New_Finalizer_Name (Id : Entity_Id);
2326 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2327 -- has a non-standard scope, process the scope first.
2329 ------------------------
2330 -- New_Finalizer_Name --
2331 ------------------------
2333 procedure New_Finalizer_Name (Id : Entity_Id) is
2335 if Scope (Id) = Standard_Standard then
2336 Get_Name_String (Chars (Id));
2339 New_Finalizer_Name (Scope (Id));
2340 Add_Str_To_Name_Buffer ("__");
2341 Get_Name_String_And_Append (Chars (Id));
2343 end New_Finalizer_Name;
2345 -- Start of processing for New_Finalizer_Name
2348 -- Create the fully qualified name of the enclosing scope
2350 New_Finalizer_Name (Spec_Id);
2353 -- __finalize_[spec|body]
2355 Add_Str_To_Name_Buffer ("__finalize_");
2358 Add_Str_To_Name_Buffer ("spec");
2360 Add_Str_To_Name_Buffer ("body");
2364 end New_Finalizer_Name;
2366 --------------------------
2367 -- Process_Declarations --
2368 --------------------------
2370 procedure Process_Declarations
2372 Preprocess : Boolean := False)
2374 procedure Process_Package_Body (Decl : Node_Id);
2375 -- Process an N_Package_Body node
2377 procedure Processing_Actions
2379 Is_Protected : Boolean := False;
2380 Strict : Boolean := False);
2381 -- Depending on the mode of operation of Process_Declarations, either
2382 -- increment the controlled object count or process the declaration.
2383 -- The Flag Is_Protected is set when the declaration denotes a simple
2384 -- protected object. The flag Strict is true when the declaration is
2385 -- for a controlled object with strict semantics for finalization.
2387 --------------------------
2388 -- Process_Package_Body --
2389 --------------------------
2391 procedure Process_Package_Body (Decl : Node_Id) is
2393 -- Do not inspect an ignored Ghost package body because all
2394 -- code found within will not appear in the final tree.
2396 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2399 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then
2400 Process_Declarations (Declarations (Decl), Preprocess);
2402 end Process_Package_Body;
2404 ------------------------
2405 -- Processing_Actions --
2406 ------------------------
2408 procedure Processing_Actions
2410 Is_Protected : Boolean := False;
2411 Strict : Boolean := False)
2414 -- Library-level tagged type
2416 if Nkind (Decl) = N_Full_Type_Declaration then
2418 Has_Tagged_Types := True;
2420 -- Unregister tagged type, unless No_Tagged_Type_Registration
2423 elsif not Restriction_Active (No_Tagged_Type_Registration) then
2424 Process_Tagged_Type_Declaration (Decl);
2427 -- Controlled object declaration
2433 Has_Strict_Ctrl_Objs := True;
2437 Process_Object_Declaration (Decl, Is_Protected);
2440 end Processing_Actions;
2447 Obj_Typ : Entity_Id;
2448 Pack_Id : Entity_Id;
2453 -- Start of processing for Process_Declarations
2456 if Is_Empty_List (Decls) then
2460 -- Process all declarations in reverse order and be prepared for them
2461 -- to be moved during the processing.
2463 Decl := Last_Non_Pragma (Decls);
2464 while Present (Decl) loop
2465 Prev := Prev_Non_Pragma (Decl);
2467 -- Library-level tagged types
2469 if Nkind (Decl) = N_Full_Type_Declaration then
2470 Typ := Defining_Identifier (Decl);
2472 -- Ignored Ghost types do not need any cleanup actions because
2473 -- they will not appear in the final tree.
2475 if Is_Ignored_Ghost_Entity (Typ) then
2478 elsif Is_Tagged_Type (Typ)
2479 and then Is_Library_Level_Entity (Typ)
2480 and then Convention (Typ) = Convention_Ada
2481 and then Present (Access_Disp_Table (Typ))
2482 and then not Is_Abstract_Type (Typ)
2483 and then not No_Run_Time_Mode
2484 and then not Restriction_Active (No_Tagged_Type_Registration)
2485 and then RTE_Available (RE_Register_Tag)
2487 Processing_Actions (Decl);
2490 -- Regular object declarations
2492 elsif Nkind (Decl) = N_Object_Declaration then
2493 Obj_Id := Defining_Identifier (Decl);
2494 Obj_Typ := Base_Type (Etype (Obj_Id));
2495 Expr := Expression (Decl);
2497 -- Bypass any form of processing for objects which have their
2498 -- finalization disabled. This applies only to objects at the
2501 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2504 -- Finalization of transient objects is treated separately in
2505 -- order to handle sensitive cases. These include:
2507 -- * Conditional expressions
2508 -- * Expressions with actions
2509 -- * Transient scopes
2511 elsif Is_Finalized_Transient (Obj_Id) then
2514 -- Finalization of specific objects is also treated separately
2516 elsif Is_Ignored_For_Finalization (Obj_Id) then
2519 -- Conversely, if one of the above cases created a Master_Node,
2520 -- finalization actions are required for the associated object.
2522 elsif Ekind (Obj_Id) = E_Variable
2523 and then Is_RTE (Obj_Typ, RE_Master_Node)
2525 Processing_Actions (Decl);
2527 -- Ignored Ghost objects do not need any cleanup actions
2528 -- because they will not appear in the final tree.
2530 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2533 -- The object is of the form:
2534 -- Obj : [constant] Typ [:= Expr];
2536 -- Do not process the incomplete view of a deferred constant.
2537 -- Note that an object initialized by means of a BIP function
2538 -- call may appear as a deferred constant after expansion
2539 -- activities. These kinds of objects must be finalized.
2541 elsif not Is_Imported (Obj_Id)
2542 and then Needs_Finalization (Obj_Typ)
2543 and then not (Ekind (Obj_Id) = E_Constant
2544 and then not Has_Completion (Obj_Id)
2545 and then No (BIP_Initialization_Call (Obj_Id)))
2548 (Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ));
2550 -- The object is of the form:
2551 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2553 -- Obj : Access_Typ :=
2554 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2556 elsif Is_Access_Type (Obj_Typ)
2557 and then Needs_Finalization
2558 (Available_View (Designated_Type (Obj_Typ)))
2559 and then Present (Expr)
2561 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2563 (Is_Non_BIP_Func_Call (Expr)
2564 and then not Is_Related_To_Func_Return (Obj_Id)))
2568 Strict => not Has_Relaxed_Finalization
2569 (Available_View (Designated_Type (Obj_Typ))));
2571 -- Simple protected objects which use the type System.Tasking.
2572 -- Protected_Objects.Protection to manage their locks should
2573 -- be treated as controlled since they require manual cleanup.
2574 -- but not for restricted run-time libraries (Ravenscar), see
2575 -- also Cleanup_Protected_Object.
2577 -- The only exception is illustrated in the following example:
2580 -- type Ctrl is new Controlled ...
2581 -- procedure Finalize (Obj : in out Ctrl);
2585 -- package body Pkg is
2586 -- protected Prot is
2587 -- procedure Do_Something (Obj : in out Ctrl);
2590 -- protected body Prot is
2591 -- procedure Do_Something (Obj : in out Ctrl) is ...
2594 -- procedure Finalize (Obj : in out Ctrl) is
2596 -- Prot.Do_Something (Obj);
2600 -- Since for the most part entities in package bodies depend on
2601 -- those in package specs, Prot's lock should be cleaned up
2602 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2603 -- This act however attempts to invoke Do_Something and fails
2604 -- because the lock has disappeared.
2606 elsif Ekind (Obj_Id) = E_Variable
2607 and then not In_Library_Level_Package_Body (Obj_Id)
2608 and then Has_Simple_Protected_Object (Obj_Typ)
2609 and then not Restricted_Profile
2612 (Decl, Is_Protected => True, Strict => True);
2615 -- Inspect the freeze node of an access-to-controlled type and
2616 -- look for a delayed finalization collection. This case arises
2617 -- when the freeze actions are inserted at a later time than the
2618 -- expansion of the context. Since Build_Finalizer is never called
2619 -- on a single construct twice, the collection would be ultimately
2620 -- left out and never finalized. This is also needed for freeze
2621 -- actions of designated types themselves, since in some cases the
2622 -- finalization collection is associated with a designated type's
2623 -- freeze node rather than that of the access type (see handling
2624 -- for freeze actions in Build_Finalization_Collection).
2626 elsif Nkind (Decl) = N_Freeze_Entity
2627 and then Present (Actions (Decl))
2629 Typ := Entity (Decl);
2631 -- Freeze nodes for ignored Ghost types do not need cleanup
2632 -- actions because they will never appear in the final tree.
2634 if Is_Ignored_Ghost_Entity (Typ) then
2637 elsif (Is_Access_Object_Type (Typ)
2638 and then Needs_Finalization
2639 (Available_View (Designated_Type (Typ))))
2640 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2642 -- Freeze nodes are considered to be identical to packages
2643 -- and blocks in terms of nesting. The difference is that
2644 -- a finalization collection created inside the freeze node
2645 -- is at the same nesting level as the node itself.
2647 Process_Declarations (Actions (Decl), Preprocess);
2650 -- Nested package declarations, avoid generics
2652 elsif Nkind (Decl) = N_Package_Declaration then
2653 Pack_Id := Defining_Entity (Decl);
2654 Spec := Specification (Decl);
2656 -- Do not inspect an ignored Ghost package because all code
2657 -- found within will not appear in the final tree.
2659 if Is_Ignored_Ghost_Entity (Pack_Id) then
2662 elsif Ekind (Pack_Id) /= E_Generic_Package then
2663 Process_Declarations
2664 (Private_Declarations (Spec), Preprocess);
2665 Process_Declarations
2666 (Visible_Declarations (Spec), Preprocess);
2669 -- Nested package bodies, avoid generics
2671 elsif Nkind (Decl) = N_Package_Body then
2672 Process_Package_Body (Decl);
2674 elsif Nkind (Decl) = N_Package_Body_Stub
2675 and then Present (Library_Unit (Decl))
2677 Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl))));
2682 end Process_Declarations;
2684 --------------------------------
2685 -- Process_Object_Declaration --
2686 --------------------------------
2688 procedure Process_Object_Declaration
2690 Is_Protected : Boolean := False)
2692 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2693 Loc : constant Source_Ptr := Sloc (Decl);
2697 Master_Node_Attach : Node_Id;
2698 Master_Node_Decl : Node_Id;
2699 Master_Node_Id : Entity_Id;
2700 Master_Node_Ins : Node_Id;
2701 Master_Node_Loc : Source_Ptr;
2703 Obj_Typ : Entity_Id;
2705 -- Start of processing for Process_Object_Declaration
2708 -- Handle the object type and the reference to the object. Note
2709 -- that objects having simple protected components or of a CW type
2710 -- must retain their original type for the processing below to work.
2712 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2713 Obj_Typ := Etype (Obj_Id);
2714 if not Is_Protected and then not Is_Class_Wide_Type (Obj_Typ) then
2715 Obj_Typ := Base_Type (Obj_Typ);
2718 if Is_Access_Type (Obj_Typ) then
2719 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2720 Obj_Typ := Available_View (Designated_Type (Obj_Typ));
2723 -- If the object is a Master_Node, then nothing to do, unless there
2724 -- is no or a single controlled object with strict semantics, in
2725 -- which case we move its declaration, call marker (if any) and
2726 -- initialization call, and also mark it to avoid double processing.
2728 if Is_RTE (Obj_Typ, RE_Master_Node) then
2729 Master_Node_Id := Obj_Id;
2731 if not Has_Strict_Ctrl_Objs or else Count = 1 then
2732 if Nkind (Next (Decl)) = N_Call_Marker then
2733 Prepend_To (Decls, Remove_Next (Next (Decl)));
2735 Prepend_To (Decls, Remove_Next (Decl));
2737 Prepend_To (Decls, Decl);
2738 Set_Is_Ignored_For_Finalization (Obj_Id);
2741 -- Create the declaration of the Master_Node for the object and
2742 -- insert it before the declaration of the object itself, unless
2743 -- there is no or a single controlled object with strict semantics,
2744 -- because it will effectively play the role of a degenerated master
2745 -- and therefore needs to be inserted at the same place the master
2748 else pragma Assert (No (Finalization_Master_Node (Obj_Id)));
2749 -- In the latter case, use the Sloc the master would have had
2751 if not Has_Strict_Ctrl_Objs or else Count = 1 then
2752 Master_Node_Loc := Sloc (N);
2754 Master_Node_Loc := Loc;
2758 Make_Defining_Identifier (Master_Node_Loc,
2759 Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN"));
2761 Make_Master_Node_Declaration (Master_Node_Loc,
2762 Master_Node_Id, Obj_Id);
2764 Push_Scope (Scope (Obj_Id));
2765 if not Has_Strict_Ctrl_Objs or else Count = 1 then
2766 Prepend_To (Decls, Master_Node_Decl);
2768 Insert_Before (Decl, Master_Node_Decl);
2770 Analyze (Master_Node_Decl);
2773 -- Mark the Master_Node to avoid double processing
2775 Set_Is_Ignored_For_Finalization (Master_Node_Id);
2778 -- Attach the Master_Node after all initialization has been done. The
2779 -- place of insertion depends on the context.
2781 if Ekind (Obj_Id) in E_Constant | E_Variable then
2783 -- The object is initialized by a build-in-place function call.
2784 -- The Master_Node insertion point is after the function call.
2786 if Present (BIP_Initialization_Call (Obj_Id)) then
2787 Master_Node_Ins := BIP_Initialization_Call (Obj_Id);
2789 -- The object is initialized by an aggregate. The Master_Node
2790 -- insertion point is after the last aggregate assignment.
2792 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
2793 Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id);
2795 -- In other cases the Master_Node is inserted after the last call
2796 -- to either [Deep_]Initialize or the type-specific init proc.
2799 Master_Node_Ins := Find_Last_Init (Decl);
2802 -- In all other cases the Master_Node is inserted after the last call
2803 -- to either [Deep_]Initialize or the type-specific init proc.
2806 Master_Node_Ins := Find_Last_Init (Decl);
2809 -- If the Initialize function is null or trivial, the call will have
2810 -- been replaced with a null statement and we place the attachment
2811 -- of the Master_Node after the declaration of the object itself.
2813 if No (Master_Node_Ins) then
2814 Master_Node_Ins := Decl;
2817 -- Processing for simple protected objects. Such objects require
2818 -- manual finalization of their lock managers. Generate:
2820 -- procedure obj_typ_nnFD (v : system__address) is
2821 -- type Ptr_Typ is access all Obj_Typ;
2822 -- Rnn : Obj_Typ renames Ptr_Typ!(v).all;
2824 -- $system__tasking__protected_objects__finalize_protection
2825 -- (Obj_TypV!(Rnn)._object);
2829 -- end obj_typ_nnFD;
2832 or else (Has_Simple_Protected_Object (Obj_Typ)
2833 and then No (Finalize_Address (Obj_Typ)))
2836 Param : constant Entity_Id :=
2837 Make_Defining_Identifier (Loc, Name_V);
2838 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
2839 Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
2840 Ren_Ref : constant Node_Id := New_Occurrence_Of (Ren_Id, Loc);
2844 Fin_Stmts : List_Id := No_List;
2848 Set_Etype (Ren_Ref, Obj_Typ);
2850 if Is_Simple_Protected_Type (Obj_Typ) then
2851 Fin_Call := Cleanup_Protected_Object (Decl, Ren_Ref);
2853 if Present (Fin_Call) then
2854 Fin_Stmts := New_List (Fin_Call);
2857 elsif Is_Array_Type (Obj_Typ) then
2858 Fin_Stmts := Cleanup_Array (Decl, Ren_Ref, Obj_Typ);
2861 Fin_Stmts := Cleanup_Record (Decl, Ren_Ref, Obj_Typ);
2864 if No (Fin_Stmts) then
2869 Make_Handled_Sequence_Of_Statements (Loc,
2870 Statements => Fin_Stmts);
2872 if Exceptions_OK then
2873 Set_Exception_Handlers (HSS, New_List (
2874 Make_Exception_Handler (Loc,
2875 Exception_Choices => New_List (
2876 Make_Others_Choice (Loc)),
2877 Statements => New_List (
2878 Make_Null_Statement (Loc)))));
2882 Make_Defining_Identifier (Loc,
2883 Make_TSS_Name_Local (Obj_Typ, TSS_Finalize_Address));
2886 Make_Subprogram_Body (Loc,
2888 Make_Procedure_Specification (Loc,
2889 Defining_Unit_Name => Fin_Id,
2891 Parameter_Specifications => New_List (
2892 Make_Parameter_Specification (Loc,
2893 Defining_Identifier => Param,
2895 New_Occurrence_Of (RTE (RE_Address), Loc)))),
2897 Declarations => New_List (
2898 Make_Full_Type_Declaration (Loc,
2899 Defining_Identifier => Ptr_Typ,
2901 Make_Access_To_Object_Definition (Loc,
2902 All_Present => True,
2903 Subtype_Indication =>
2904 New_Occurrence_Of (Obj_Typ, Loc))),
2906 Make_Object_Renaming_Declaration (Loc,
2907 Defining_Identifier => Ren_Id,
2909 New_Occurrence_Of (Obj_Typ, Loc),
2911 Make_Explicit_Dereference (Loc,
2913 Unchecked_Convert_To
2914 (Ptr_Typ, New_Occurrence_Of (Param, Loc))))),
2916 Handled_Statement_Sequence => HSS);
2918 Push_Scope (Scope (Obj_Id));
2919 Insert_After_And_Analyze
2920 (Master_Node_Ins, Fin_Body, Suppress => All_Checks);
2923 Master_Node_Ins := Fin_Body;
2926 -- If the object's subtype is an array that has a constrained first
2927 -- subtype and is not this first subtype, we need to build a special
2928 -- Finalize_Address primitive for the object's subtype because the
2929 -- Finalize_Address primitive of the base type has been tailored to
2930 -- the first subtype (see Make_Finalize_Address_Stmts). Generate:
2932 -- procedure obj_typ_nnFD (v : system__address) is
2933 -- type Ptr_Typ is access all Obj_Typ;
2935 -- obj_typBDF (Ptr_Typ!(v).all, f => true);
2936 -- end obj_typ_nnFD;
2938 elsif Is_Array_Type (Etype (Obj_Id))
2939 and then Is_Constrained (First_Subtype (Etype (Obj_Id)))
2940 and then Etype (Obj_Id) /= First_Subtype (Etype (Obj_Id))
2943 Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P');
2944 Param : constant Entity_Id :=
2945 Make_Defining_Identifier (Loc, Name_V);
2950 Obj_Typ := Etype (Obj_Id);
2953 Make_Defining_Identifier (Loc,
2955 (Obj_Typ, TSS_Finalize_Address));
2958 Make_Subprogram_Body (Loc,
2960 Make_Procedure_Specification (Loc,
2961 Defining_Unit_Name => Fin_Id,
2962 Parameter_Specifications => New_List (
2963 Make_Parameter_Specification (Loc,
2964 Defining_Identifier => Param,
2966 New_Occurrence_Of (RTE (RE_Address), Loc)))),
2968 Declarations => New_List (
2969 Make_Full_Type_Declaration (Loc,
2970 Defining_Identifier => Ptr_Typ,
2972 Make_Access_To_Object_Definition (Loc,
2973 All_Present => True,
2974 Subtype_Indication =>
2975 New_Occurrence_Of (Obj_Typ, Loc)))),
2977 Handled_Statement_Sequence =>
2978 Make_Handled_Sequence_Of_Statements (Loc,
2979 Statements => New_List (
2982 Make_Explicit_Dereference (Loc,
2984 Unchecked_Convert_To (Ptr_Typ,
2985 Make_Identifier (Loc, Name_V))),
2988 Push_Scope (Scope (Obj_Id));
2989 Insert_After_And_Analyze
2990 (Master_Node_Ins, Fin_Body, Suppress => All_Checks);
2993 Master_Node_Ins := Fin_Body;
2997 Fin_Id := Finalize_Address (Obj_Typ);
2999 if No (Fin_Id) and then Ekind (Obj_Typ) = E_Class_Wide_Subtype then
3000 Fin_Id := TSS (Obj_Typ, TSS_Finalize_Address);
3004 -- Now build the attachment call that will initialize the object's
3005 -- Master_Node using the object's address and type's finalization
3006 -- procedure and then attach the Master_Node to the master, unless
3007 -- there is no or a single controlled object with strict semantics.
3009 if not Has_Strict_Ctrl_Objs or else Count = 1 then
3010 -- Finalize_Address is not generated in CodePeer mode because the
3011 -- body contains address arithmetic. So we don't want to generate
3012 -- the attach in this case. Ditto if the object is a Master_Node.
3014 if CodePeer_Mode or else Obj_Id = Master_Node_Id then
3015 Master_Node_Attach := Make_Null_Statement (Loc);
3018 Master_Node_Attach :=
3019 Make_Procedure_Call_Statement (Loc,
3021 New_Occurrence_Of (RTE (RE_Attach_Object_To_Node), Loc),
3022 Parameter_Associations => New_List (
3023 Make_Address_For_Finalize (Loc, Obj_Ref, Obj_Typ),
3024 Make_Attribute_Reference (Loc,
3025 Prefix => New_Occurrence_Of (Fin_Id, Loc),
3026 Attribute_Name => Name_Unrestricted_Access),
3027 New_Occurrence_Of (Master_Node_Id, Loc)));
3029 Set_Finalize_Address_For_Node (Master_Node_Id, Fin_Id);
3032 -- We also generate the direct finalization call here
3034 Fin_Call := Make_Finalize_Call_For_Node (Loc, Master_Node_Id);
3036 -- For CodePeer, the exception handlers normally generated here
3037 -- generate complex flowgraphs which result in capacity problems.
3038 -- Omitting these handlers for CodePeer is justified as follows:
3040 -- If a handler is dead, then omitting it is surely ok
3042 -- If a handler is live, then CodePeer should flag the
3043 -- potentially-exception-raising construct that causes it
3044 -- to be live. That is what we are interested in, not what
3045 -- happens after the exception is raised.
3047 if Has_Strict_Ctrl_Objs
3048 and then Exceptions_OK
3049 and then not CodePeer_Mode
3052 Make_Block_Statement (Loc,
3053 Handled_Statement_Sequence =>
3054 Make_Handled_Sequence_Of_Statements (Loc,
3055 Statements => New_List (Fin_Call),
3057 Exception_Handlers => New_List (
3058 Build_Exception_Handler
3059 (Finalizer_Data, For_Package))));
3062 Append_To (Finalizer_Stmts, Fin_Call);
3065 -- If the object is a Master_Node, we just need to chain it
3067 if Obj_Id = Master_Node_Id then
3068 Master_Node_Attach :=
3069 Make_Procedure_Call_Statement (Loc,
3071 New_Occurrence_Of (RTE (RE_Chain_Node_To_Master), Loc),
3072 Parameter_Associations => New_List (
3073 Make_Attribute_Reference (Loc,
3074 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3075 Attribute_Name => Name_Unrestricted_Access),
3076 New_Occurrence_Of (Finalization_Master, Loc)));
3078 -- Finalize_Address is not generated in CodePeer mode because the
3079 -- body contains address arithmetic. So we don't want to generate
3080 -- the attach in this case.
3082 elsif CodePeer_Mode then
3083 Master_Node_Attach := Make_Null_Statement (Loc);
3086 Master_Node_Attach :=
3087 Make_Procedure_Call_Statement (Loc,
3089 New_Occurrence_Of (RTE (RE_Attach_Object_To_Master), Loc),
3090 Parameter_Associations => New_List (
3091 Make_Address_For_Finalize (Loc, Obj_Ref, Obj_Typ),
3092 Make_Attribute_Reference (Loc,
3093 Prefix => New_Occurrence_Of (Fin_Id, Loc),
3094 Attribute_Name => Name_Unrestricted_Access),
3095 Make_Attribute_Reference (Loc,
3097 New_Occurrence_Of (Master_Node_Id, Loc),
3098 Attribute_Name => Name_Unrestricted_Access),
3099 New_Occurrence_Of (Finalization_Master, Loc)));
3103 Insert_After_And_Analyze
3104 (Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks);
3105 end Process_Object_Declaration;
3107 -------------------------------------
3108 -- Process_Tagged_Type_Declaration --
3109 -------------------------------------
3111 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3112 Typ : constant Entity_Id := Defining_Identifier (Decl);
3113 DT_Ptr : constant Entity_Id :=
3114 Node (First_Elmt (Access_Disp_Table (Typ)));
3117 -- Ada.Tags.Unregister_Tag (<Typ>P);
3119 Append_To (Tagged_Type_Stmts,
3120 Make_Procedure_Call_Statement (Loc,
3122 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3123 Parameter_Associations => New_List (
3124 New_Occurrence_Of (DT_Ptr, Loc))));
3125 end Process_Tagged_Type_Declaration;
3127 -- Start of processing for Build_Finalizer
3132 -- Do not perform this expansion in SPARK mode because it is not
3135 if GNATprove_Mode then
3139 -- Step 1: Extract all lists which may contain controlled objects or
3140 -- library-level tagged types.
3142 if For_Package_Spec then
3143 Decls := Visible_Declarations (Specification (N));
3144 Priv_Decls := Private_Declarations (Specification (N));
3146 -- Retrieve the package spec id
3148 Spec_Id := Defining_Unit_Name (Specification (N));
3150 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3151 Spec_Id := Defining_Identifier (Spec_Id);
3154 -- Accept statement, block, entry body, package body, protected body,
3155 -- subprogram body or task body.
3158 Decls := Declarations (N);
3159 HSS := Handled_Statement_Sequence (N);
3161 if Present (HSS) then
3162 if Present (Statements (HSS)) then
3163 Stmts := Statements (HSS);
3166 if Present (At_End_Proc (HSS)) then
3167 Prev_At_End := At_End_Proc (HSS);
3171 -- Retrieve the package spec id for package bodies
3173 if For_Package_Body then
3174 Spec_Id := Corresponding_Spec (N);
3178 -- We do not need to process nested packages since they are handled by
3179 -- the finalizer of the enclosing scope, including at library level.
3180 -- And we do not build two finalizers for an instance without body that
3181 -- is a library unit (see Analyze_Package_Instantiation).
3184 and then (not Is_Compilation_Unit (Spec_Id)
3185 or else (Is_Generic_Instance (Spec_Id)
3186 and then Package_Instantiation (Spec_Id) = N))
3191 -- Step 2: Object [pre]processing
3194 -- For package specs and bodies, we are invoked from the Standard
3195 -- scope, so we need to push the specs onto the scope stack first.
3197 Push_Scope (Spec_Id);
3199 -- Preprocess the visible declarations now in order to obtain the
3200 -- correct number of controlled object by the time the private
3201 -- declarations are processed.
3203 Process_Declarations (Decls, Preprocess => True);
3205 -- From all the possible contexts, only package specifications may
3206 -- have private declarations.
3208 if For_Package_Spec then
3209 Process_Declarations (Priv_Decls, Preprocess => True);
3212 -- The current context may lack controlled objects, but require some
3213 -- other form of completion (task termination for instance). In such
3214 -- cases, the finalizer must be created and carry the additional
3217 if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
3221 -- The preprocessing has determined that the context has controlled
3222 -- objects or library-level tagged types.
3224 if Has_Ctrl_Objs or else Has_Tagged_Types then
3226 -- Private declarations are processed first in order to preserve
3227 -- possible dependencies between public and private objects.
3229 if For_Package_Spec then
3230 Process_Declarations (Priv_Decls);
3233 Process_Declarations (Decls);
3239 -- Preprocess both declarations and statements
3241 Process_Declarations (Decls, Preprocess => True);
3242 Process_Declarations (Stmts, Preprocess => True);
3244 -- At this point it is known that N has controlled objects. Ensure
3245 -- that N has a declarative list since the finalizer spec will be
3248 if Has_Ctrl_Objs and then No (Decls) then
3249 Set_Declarations (N, New_List);
3250 Decls := Declarations (N);
3253 -- The current context may lack controlled objects, but require some
3254 -- other form of completion (task termination for instance). In such
3255 -- cases, the finalizer must be created and carry the additional
3258 if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
3262 if Has_Ctrl_Objs or else Has_Tagged_Types then
3263 Process_Declarations (Stmts);
3264 Process_Declarations (Decls);
3268 -- Step 3: Finalizer creation
3270 if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
3274 -- Pop the scope that was pushed above for package specs and bodies
3279 end Build_Finalizer;
3281 --------------------------
3282 -- Build_Finalizer_Call --
3283 --------------------------
3285 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3287 -- Do not perform this expansion in SPARK mode because we do not create
3288 -- finalizers in the first place.
3290 if GNATprove_Mode then
3294 -- If the construct to be cleaned up is a protected subprogram body, the
3295 -- finalizer call needs to be associated with the block that wraps the
3296 -- unprotected version of the subprogram. The following illustrates this
3299 -- procedure Prot_SubpP is
3300 -- procedure finalizer is
3302 -- Service_Entries (Prot_Obj);
3309 -- Prot_SubpN (Prot_Obj);
3316 Loc : constant Source_Ptr := Sloc (N);
3318 Is_Protected_Subp_Body : constant Boolean :=
3319 Nkind (N) = N_Subprogram_Body
3320 and then Is_Protected_Subprogram_Body (N);
3321 -- True if N is the protected version of a subprogram that belongs to
3322 -- a protected type.
3324 HSS : constant Node_Id :=
3325 (if Is_Protected_Subp_Body
3326 then Handled_Statement_Sequence
3327 (Last (Statements (Handled_Statement_Sequence (N))))
3328 else Handled_Statement_Sequence (N));
3330 -- We attach the At_End_Proc to the HSS if this is an accept
3331 -- statement or extended return statement. Also in the case of
3332 -- a protected subprogram, because if Service_Entries raises an
3333 -- exception, we do not lock the PO, so we also do not want to
3336 Use_HSS : constant Boolean :=
3337 Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement
3338 or else Is_Protected_Subp_Body;
3340 At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N);
3342 pragma Assert (No (At_End_Proc (At_End_Proc_Bearer)));
3343 Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc));
3344 -- Attach reference to finalizer to tree, for LLVM use
3345 Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer);
3346 Analyze (At_End_Proc (At_End_Proc_Bearer));
3347 Expand_At_End_Handler (At_End_Proc_Bearer, Empty);
3349 end Build_Finalizer_Call;
3351 ---------------------
3352 -- Build_Late_Proc --
3353 ---------------------
3355 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3357 for Final_Prim in Name_Of'Range loop
3358 if Name_Of (Final_Prim) = Nam then
3361 (Prim => Final_Prim,
3363 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3366 end Build_Late_Proc;
3368 -------------------------------
3369 -- Build_Object_Declarations --
3370 -------------------------------
3372 procedure Build_Object_Declarations
3373 (Data : out Finalization_Exception_Data;
3376 For_Package : Boolean := False)
3381 -- This variable captures an unused dummy internal entity, see the
3382 -- comment associated with its use.
3385 pragma Assert (Decls /= No_List);
3387 -- Always set the proper location as it may be needed even when
3388 -- exception propagation is forbidden.
3392 if Restriction_Active (No_Exception_Propagation) then
3393 Data.Abort_Id := Empty;
3395 Data.Raised_Id := Empty;
3399 Data.Raised_Id := Make_Temporary (Loc, 'R');
3401 -- In certain scenarios, finalization can be triggered by an abort. If
3402 -- the finalization itself fails and raises an exception, the resulting
3403 -- Program_Error must be supressed and replaced by an abort signal. In
3404 -- order to detect this scenario, save the state of entry into the
3405 -- finalization code.
3407 -- This is not needed for library-level finalizers as they are called by
3408 -- the environment task and cannot be aborted.
3410 if not For_Package then
3411 if Abort_Allowed then
3412 Data.Abort_Id := Make_Temporary (Loc, 'A');
3415 -- Abort_Id : constant Boolean := <A_Expr>;
3418 Make_Object_Declaration (Loc,
3419 Defining_Identifier => Data.Abort_Id,
3420 Constant_Present => True,
3421 Object_Definition =>
3422 New_Occurrence_Of (Standard_Boolean, Loc),
3424 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3426 -- Abort is not required
3429 -- Generate a dummy entity to ensure that the internal symbols are
3430 -- in sync when a unit is compiled with and without aborts.
3432 Dummy := Make_Temporary (Loc, 'A');
3433 Data.Abort_Id := Empty;
3436 -- Library-level finalizers
3439 Data.Abort_Id := Empty;
3442 if Exception_Extra_Info then
3443 Data.E_Id := Make_Temporary (Loc, 'E');
3446 -- E_Id : Exception_Occurrence;
3449 Make_Object_Declaration (Loc,
3450 Defining_Identifier => Data.E_Id,
3451 Object_Definition =>
3452 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3453 Set_No_Initialization (Decl);
3455 Append_To (Decls, Decl);
3462 -- Raised_Id : Boolean := False;
3465 Make_Object_Declaration (Loc,
3466 Defining_Identifier => Data.Raised_Id,
3467 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3468 Expression => New_Occurrence_Of (Standard_False, Loc)));
3470 if Debug_Generated_Code then
3471 Set_Debug_Info_Needed (Data.Raised_Id);
3473 end Build_Object_Declarations;
3475 ---------------------------
3476 -- Build_Raise_Statement --
3477 ---------------------------
3479 function Build_Raise_Statement
3480 (Data : Finalization_Exception_Data) return Node_Id
3486 -- Standard run-time use the specialized routine
3487 -- Raise_From_Controlled_Operation.
3489 if Exception_Extra_Info
3490 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3493 Make_Procedure_Call_Statement (Data.Loc,
3496 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3497 Parameter_Associations =>
3498 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3500 -- Restricted run-time: exception messages are not supported and hence
3501 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3506 Make_Raise_Program_Error (Data.Loc,
3507 Reason => PE_Finalize_Raised_Exception);
3512 -- Raised_Id and then not Abort_Id
3516 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3518 if Present (Data.Abort_Id) then
3519 Expr := Make_And_Then (Data.Loc,
3522 Make_Op_Not (Data.Loc,
3523 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3528 -- if Raised_Id and then not Abort_Id then
3529 -- Raise_From_Controlled_Operation (E_Id);
3531 -- raise Program_Error; -- restricted runtime
3535 Make_If_Statement (Data.Loc,
3537 Then_Statements => New_List (Stmt));
3538 end Build_Raise_Statement;
3540 -----------------------------
3541 -- Build_Record_Deep_Procs --
3542 -----------------------------
3544 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3548 (Prim => Initialize_Case,
3550 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3552 if not Is_Inherently_Limited_Type (Typ) then
3555 (Prim => Adjust_Case,
3557 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3560 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3561 -- suppressed since these routine will not be used.
3563 if not Restriction_Active (No_Finalization) then
3566 (Prim => Finalize_Case,
3568 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3570 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3572 if not CodePeer_Mode then
3575 (Prim => Address_Case,
3577 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3580 end Build_Record_Deep_Procs;
3586 function Cleanup_Array
3589 Typ : Entity_Id) return List_Id
3591 Loc : constant Source_Ptr := Sloc (N);
3592 Index_List : constant List_Id := New_List;
3594 function Free_Component return List_Id;
3595 -- Generate the code to finalize the task or protected subcomponents
3596 -- of a single component of the array.
3598 function Free_One_Dimension (Dim : Int) return List_Id;
3599 -- Generate a loop over one dimension of the array
3601 --------------------
3602 -- Free_Component --
3603 --------------------
3605 function Free_Component return List_Id is
3606 Stmts : List_Id := New_List;
3608 C_Typ : constant Entity_Id := Component_Type (Typ);
3611 -- Component type is known to contain tasks or protected objects
3614 Make_Indexed_Component (Loc,
3615 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3616 Expressions => Index_List);
3618 Set_Etype (Tsk, C_Typ);
3620 if Is_Task_Type (C_Typ) then
3621 Append_To (Stmts, Cleanup_Task (N, Tsk));
3623 elsif Is_Simple_Protected_Type (C_Typ) then
3624 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3626 elsif Is_Record_Type (C_Typ) then
3627 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3629 elsif Is_Array_Type (C_Typ) then
3630 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3636 ------------------------
3637 -- Free_One_Dimension --
3638 ------------------------
3640 function Free_One_Dimension (Dim : Int) return List_Id is
3644 if Dim > Number_Dimensions (Typ) then
3645 return Free_Component;
3647 -- Here we generate the required loop
3650 Index := Make_Temporary (Loc, 'J');
3651 Append (New_Occurrence_Of (Index, Loc), Index_List);
3654 Make_Implicit_Loop_Statement (N,
3655 Identifier => Empty,
3657 Make_Iteration_Scheme (Loc,
3658 Loop_Parameter_Specification =>
3659 Make_Loop_Parameter_Specification (Loc,
3660 Defining_Identifier => Index,
3661 Discrete_Subtype_Definition =>
3662 Make_Attribute_Reference (Loc,
3663 Prefix => Duplicate_Subexpr (Obj),
3664 Attribute_Name => Name_Range,
3665 Expressions => New_List (
3666 Make_Integer_Literal (Loc, Dim))))),
3667 Statements => Free_One_Dimension (Dim + 1)));
3669 end Free_One_Dimension;
3671 -- Start of processing for Cleanup_Array
3674 return Free_One_Dimension (1);
3677 --------------------
3678 -- Cleanup_Record --
3679 --------------------
3681 function Cleanup_Record
3684 Typ : Entity_Id) return List_Id
3686 Loc : constant Source_Ptr := Sloc (N);
3687 Stmts : constant List_Id := New_List;
3688 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3694 if Has_Discriminants (U_Typ)
3695 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3696 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3699 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3701 -- For now, do not attempt to free a component that may appear in a
3702 -- variant, and instead issue a warning. Doing this "properly" would
3703 -- require building a case statement and would be quite a mess. Note
3704 -- that the RM only requires that free "work" for the case of a task
3705 -- access value, so already we go way beyond this in that we deal
3706 -- with the array case and non-discriminated record cases.
3709 ("task/protected object in variant record will not be freed??", N);
3710 return New_List (Make_Null_Statement (Loc));
3713 Comp := First_Component (U_Typ);
3714 while Present (Comp) loop
3715 if Chars (Comp) /= Name_uParent
3716 and then (Has_Task (Etype (Comp))
3717 or else Has_Simple_Protected_Object (Etype (Comp)))
3720 Make_Selected_Component (Loc,
3721 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3722 Selector_Name => New_Occurrence_Of (Comp, Loc));
3723 Set_Etype (Tsk, Etype (Comp));
3725 if Is_Task_Type (Etype (Comp)) then
3726 Append_To (Stmts, Cleanup_Task (N, Tsk));
3728 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3729 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3731 elsif Is_Record_Type (Etype (Comp)) then
3733 -- Recurse, by generating the prefix of the argument to the
3734 -- eventual cleanup call.
3736 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3738 elsif Is_Array_Type (Etype (Comp)) then
3739 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3743 Next_Component (Comp);
3749 ------------------------------
3750 -- Cleanup_Protected_Object --
3751 ------------------------------
3753 function Cleanup_Protected_Object
3755 Ref : Node_Id) return Node_Id
3757 Loc : constant Source_Ptr := Sloc (N);
3760 -- For restricted run-time libraries (Ravenscar), tasks are
3761 -- non-terminating, and protected objects can only appear at library
3762 -- level, so we do not want finalization of protected objects.
3764 if Restricted_Profile then
3769 Make_Procedure_Call_Statement (Loc,
3771 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
3772 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3774 end Cleanup_Protected_Object;
3780 function Cleanup_Task
3782 Ref : Node_Id) return Node_Id
3784 Loc : constant Source_Ptr := Sloc (N);
3787 -- For restricted run-time libraries (Ravenscar), tasks are
3788 -- non-terminating and they can only appear at library level,
3789 -- so we do not want finalization of task objects.
3791 if Restricted_Profile then
3796 Make_Procedure_Call_Statement (Loc,
3798 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
3799 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3803 --------------------------------------
3804 -- Check_Unnesting_Elaboration_Code --
3805 --------------------------------------
3807 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
3808 Loc : constant Source_Ptr := Sloc (N);
3809 Block_Elab_Proc : Entity_Id := Empty;
3811 procedure Set_Block_Elab_Proc;
3812 -- Create a defining identifier for a procedure that will replace
3813 -- a block with nested subprograms (unless it has already been created,
3814 -- in which case this is a no-op).
3816 procedure Set_Block_Elab_Proc is
3818 if No (Block_Elab_Proc) then
3819 Block_Elab_Proc := Make_Temporary (Loc, 'I');
3821 end Set_Block_Elab_Proc;
3823 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
3824 -- Find entities in the elaboration code of a library package body that
3825 -- contain or represent a subprogram body. A body can appear within a
3826 -- block or a loop or can appear by itself if generated for an object
3827 -- declaration that involves controlled actions. The first such entity
3828 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
3829 -- that will be used to reset the scopes of all entities that become
3830 -- local to the new elaboration procedure. This is needed for subsequent
3831 -- unnesting actions, which depend on proper setting of the Scope links
3832 -- to determine the nesting level of each subprogram.
3834 --------------------------------------
3835 -- Reset_Scopes_To_Block_Elab_Proc --
3836 --------------------------------------
3837 Maybe_Reset_Scopes_For_Decl : constant Elist_Id := New_Elmt_List;
3839 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
3846 while Present (Stat) loop
3847 case Nkind (Stat) is
3848 when N_Block_Statement =>
3849 if Present (Identifier (Stat)) then
3850 Id := Entity (Identifier (Stat));
3852 -- The Scope of this block needs to be reset to the new
3853 -- procedure if the block contains nested subprograms.
3855 if Present (Id) and then Contains_Subprogram (Id) then
3856 Set_Block_Elab_Proc;
3857 Set_Scope (Id, Block_Elab_Proc);
3861 when N_Loop_Statement =>
3862 Id := Entity (Identifier (Stat));
3864 if Present (Id) and then Contains_Subprogram (Id) then
3865 if Scope (Id) = Current_Scope then
3866 Set_Block_Elab_Proc;
3867 Set_Scope (Id, Block_Elab_Proc);
3871 -- We traverse the loop's statements as well, which may
3872 -- include other block (etc.) statements that need to have
3873 -- their Scope set to Block_Elab_Proc. (Is this really the
3874 -- case, or do such nested blocks refer to the loop scope
3875 -- rather than the loop's enclosing scope???.)
3877 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
3879 when N_If_Statement =>
3880 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
3881 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
3883 Node := First (Elsif_Parts (Stat));
3884 while Present (Node) loop
3885 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node));
3889 when N_Case_Statement =>
3890 Node := First (Alternatives (Stat));
3891 while Present (Node) loop
3892 Reset_Scopes_To_Block_Elab_Proc (Statements (Node));
3896 -- Reset the Scope of a subprogram and object declaration
3897 -- occurring at the top level
3899 when N_Subprogram_Body =>
3900 Id := Defining_Entity (Stat);
3902 Set_Block_Elab_Proc;
3903 Set_Scope (Id, Block_Elab_Proc);
3905 when N_Object_Declaration
3906 | N_Object_Renaming_Declaration =>
3907 Id := Defining_Entity (Stat);
3908 if No (Block_Elab_Proc) then
3909 Append_Elmt (Id, Maybe_Reset_Scopes_For_Decl);
3911 Set_Scope (Id, Block_Elab_Proc);
3921 -- If we are creating an Elab procedure, move all the gathered
3922 -- declarations in its scope.
3924 if Present (Block_Elab_Proc) then
3925 while not Is_Empty_Elmt_List (Maybe_Reset_Scopes_For_Decl) loop
3928 (Last_Elmt (Maybe_Reset_Scopes_For_Decl)), Block_Elab_Proc);
3929 Remove_Last_Elmt (Maybe_Reset_Scopes_For_Decl);
3932 end Reset_Scopes_To_Block_Elab_Proc;
3936 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
3937 Elab_Body : Node_Id;
3938 Elab_Call : Node_Id;
3940 -- Start of processing for Check_Unnesting_Elaboration_Code
3943 if Present (H_Seq) then
3944 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
3946 -- There may be subprograms declared in the exception handlers
3947 -- of the current body.
3949 if Present (Exception_Handlers (H_Seq)) then
3951 Handler : Node_Id := First (Exception_Handlers (H_Seq));
3953 while Present (Handler) loop
3954 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
3961 if Present (Block_Elab_Proc) then
3963 Make_Subprogram_Body (Loc,
3965 Make_Procedure_Specification (Loc,
3966 Defining_Unit_Name => Block_Elab_Proc),
3967 Declarations => New_List,
3968 Handled_Statement_Sequence =>
3969 Relocate_Node (Handled_Statement_Sequence (N)));
3972 Make_Procedure_Call_Statement (Loc,
3973 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
3975 Append_To (Declarations (N), Elab_Body);
3976 Analyze (Elab_Body);
3977 Set_Has_Nested_Subprogram (Block_Elab_Proc);
3979 Set_Handled_Statement_Sequence (N,
3980 Make_Handled_Sequence_Of_Statements (Loc,
3981 Statements => New_List (Elab_Call)));
3983 Analyze (Elab_Call);
3985 -- Could we reset the scopes of entities associated with the new
3986 -- procedure here via a loop over entities rather than doing it in
3987 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
3990 end Check_Unnesting_Elaboration_Code;
3992 ---------------------------------------
3993 -- Check_Unnesting_In_Decls_Or_Stmts --
3994 ---------------------------------------
3996 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
3997 Decl_Or_Stmt : Node_Id;
4000 if Unnest_Subprogram_Mode
4001 and then Present (Decls_Or_Stmts)
4003 Decl_Or_Stmt := First (Decls_Or_Stmts);
4004 while Present (Decl_Or_Stmt) loop
4005 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4006 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4008 Unnest_Block (Decl_Or_Stmt);
4010 -- If-statements may contain subprogram bodies at the outer level
4011 -- of their statement lists, and the subprograms may make up-level
4012 -- references (such as to objects declared in the same statement
4013 -- list). Unlike block and loop cases, however, we don't have an
4014 -- entity on which to test the Contains_Subprogram flag, so
4015 -- Unnest_If_Statement must traverse the statement lists to
4016 -- determine whether there are nested subprograms present.
4018 elsif Nkind (Decl_Or_Stmt) = N_If_Statement then
4019 Unnest_If_Statement (Decl_Or_Stmt);
4021 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4023 Id : constant Entity_Id :=
4024 Entity (Identifier (Decl_Or_Stmt));
4027 -- When a top-level loop within declarations of a library
4028 -- package spec or body contains nested subprograms, we wrap
4029 -- it in a procedure to handle possible up-level references
4030 -- to entities associated with the loop (such as loop
4033 if Present (Id) and then Contains_Subprogram (Id) then
4034 Unnest_Loop (Decl_Or_Stmt);
4038 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration then
4039 Check_Unnesting_In_Decls_Or_Stmts
4040 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4041 Check_Unnesting_In_Decls_Or_Stmts
4042 (Private_Declarations (Specification (Decl_Or_Stmt)));
4044 elsif Nkind (Decl_Or_Stmt) = N_Package_Body then
4045 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4046 if Present (Statements
4047 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4049 Check_Unnesting_In_Decls_Or_Stmts (Statements
4050 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4051 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4055 Next (Decl_Or_Stmt);
4058 end Check_Unnesting_In_Decls_Or_Stmts;
4060 ---------------------------------
4061 -- Check_Unnesting_In_Handlers --
4062 ---------------------------------
4064 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4065 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4068 if Present (Stmt_Seq)
4069 and then Present (Exception_Handlers (Stmt_Seq))
4072 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4074 while Present (Handler) loop
4075 if Present (Statements (Handler)) then
4076 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4083 end Check_Unnesting_In_Handlers;
4085 ------------------------------
4086 -- Check_Visibly_Controlled --
4087 ------------------------------
4089 procedure Check_Visibly_Controlled
4090 (Prim : Final_Primitives;
4092 E : in out Entity_Id;
4093 Cref : in out Node_Id)
4095 Parent_Type : Entity_Id;
4099 if Is_Derived_Type (Typ)
4100 and then Comes_From_Source (E)
4101 and then No (Overridden_Operation (E))
4103 -- We know that the explicit operation on the type does not override
4104 -- the inherited operation of the parent, and that the derivation
4105 -- is from a private type that is not visibly controlled.
4107 Parent_Type := Etype (Typ);
4108 Op := Find_Controlled_Prim_Op (Parent_Type, Name_Of (Prim));
4110 if Present (Op) then
4113 -- Wrap the object to be initialized into the proper
4114 -- unchecked conversion, to be compatible with the operation
4117 if Nkind (Cref) = N_Unchecked_Type_Conversion then
4118 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
4120 Cref := Unchecked_Convert_To (Parent_Type, Cref);
4124 end Check_Visibly_Controlled;
4126 --------------------------
4127 -- Contains_Subprogram --
4128 --------------------------
4130 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
4134 E := First_Entity (Blk);
4136 -- The compiler may generate loops with a declare block containing
4137 -- nested procedures used for finalization. Recursively search for
4138 -- subprograms in such constructs.
4140 if Ekind (Blk) = E_Loop
4141 and then Parent_Kind (Blk) = N_Loop_Statement
4144 Stmt : Node_Id := First (Statements (Parent (Blk)));
4146 while Present (Stmt) loop
4147 if Nkind (Stmt) = N_Block_Statement then
4149 Id : constant Entity_Id :=
4150 Entity (Identifier (Stmt));
4152 if Contains_Subprogram (Id) then
4162 while Present (E) loop
4163 if Is_Subprogram (E) then
4166 elsif Ekind (E) in E_Block | E_Loop
4167 and then Contains_Subprogram (E)
4176 end Contains_Subprogram;
4182 function Convert_View
4185 Typ : Entity_Id) return Node_Id
4187 Ftyp : constant Entity_Id := Etype (First_Formal (Proc));
4192 if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
4193 Atyp := Entity (Subtype_Mark (Arg));
4194 elsif Present (Etype (Arg)) then
4195 Atyp := Etype (Arg);
4200 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
4201 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
4203 elsif Present (Atyp)
4204 and then Atyp /= Ftyp
4205 and then (Is_Private_Type (Ftyp)
4206 or else Is_Private_Type (Atyp)
4207 or else Is_Private_Type (Base_Type (Atyp)))
4208 and then Implementation_Base_Type (Atyp) =
4209 Implementation_Base_Type (Ftyp)
4211 return Unchecked_Convert_To (Ftyp, Arg);
4213 -- If the argument is already a conversion, as generated by
4214 -- Make_Init_Call, set the target type to the type of the formal
4215 -- directly, to avoid spurious typing problems.
4217 elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion
4218 and then not Is_Class_Wide_Type (Atyp)
4220 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4221 Set_Etype (Arg, Ftyp);
4224 -- Otherwise, introduce a conversion when the designated object
4225 -- has a type derived from the formal of the controlled routine.
4227 elsif Is_Private_Type (Ftyp)
4228 and then Present (Atyp)
4229 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4231 return Unchecked_Convert_To (Ftyp, Arg);
4238 -------------------------------
4239 -- Establish_Transient_Scope --
4240 -------------------------------
4242 -- This procedure is called each time a transient block has to be inserted
4243 -- that is to say for each call to a function with unconstrained or tagged
4244 -- result. It creates a new scope on the scope stack in order to enclose
4245 -- all transient variables generated.
4247 procedure Establish_Transient_Scope
4249 Manage_Sec_Stack : Boolean)
4251 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4252 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4254 function Find_Enclosing_Transient_Scope return Int;
4255 -- Examine the scope stack looking for the nearest enclosing transient
4256 -- scope within the innermost enclosing package or subprogram. Return
4257 -- its index in the table or else -1 if no such scope exists.
4259 function Find_Transient_Context (N : Node_Id) return Node_Id;
4260 -- Locate a suitable context for arbitrary node N which may need to be
4261 -- serviced by a transient scope. Return Empty if no suitable context
4264 procedure Delegate_Sec_Stack_Management;
4265 -- Move the management of the secondary stack to the nearest enclosing
4268 procedure Create_Transient_Scope (Context : Node_Id);
4269 -- Place a new scope on the scope stack in order to service construct
4270 -- Context. Context is the node found by Find_Transient_Context. The
4271 -- new scope may also manage the secondary stack.
4273 ----------------------------
4274 -- Create_Transient_Scope --
4275 ----------------------------
4277 procedure Create_Transient_Scope (Context : Node_Id) is
4278 Loc : constant Source_Ptr := Sloc (N);
4280 Iter_Loop : Entity_Id;
4281 Trans_Scop : constant Entity_Id :=
4282 New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4285 Set_Etype (Trans_Scop, Standard_Void_Type);
4287 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4290 Push_Scope (Trans_Scop);
4291 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context;
4292 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := True;
4294 -- The transient scope must also manage the secondary stack
4296 if Manage_Sec_Stack then
4297 Set_Uses_Sec_Stack (Trans_Scop);
4298 Check_Restriction (No_Secondary_Stack, N);
4300 -- The expansion of iterator loops generates references to objects
4301 -- in order to extract elements from a container:
4303 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4304 -- Obj : <object type> renames Ref.all.Element.all;
4306 -- These references are controlled and returned on the secondary
4307 -- stack. A new reference is created at each iteration of the loop
4308 -- and as a result it must be finalized and the space occupied by
4309 -- it on the secondary stack reclaimed at the end of the current
4312 -- When the context that requires a transient scope is a call to
4313 -- routine Reference, the node to be wrapped is the source object:
4315 -- for Obj of Container loop
4317 -- Routine Wrap_Transient_Declaration however does not generate
4318 -- a physical block as wrapping a declaration will kill it too
4319 -- early. To handle this peculiar case, mark the related iterator
4320 -- loop as requiring the secondary stack. This signals the
4321 -- finalization machinery to manage the secondary stack (see
4322 -- routine Process_Statements_For_Controlled_Objects).
4324 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4326 if Present (Iter_Loop) then
4327 Set_Uses_Sec_Stack (Iter_Loop);
4331 if Debug_Flag_W then
4332 Write_Str (" <Transient>");
4335 end Create_Transient_Scope;
4337 -----------------------------------
4338 -- Delegate_Sec_Stack_Management --
4339 -----------------------------------
4341 procedure Delegate_Sec_Stack_Management is
4343 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4345 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4347 -- Prevent the search from going too far or within the scope
4348 -- space of another unit.
4350 if Scope.Entity = Standard_Standard then
4353 -- No transient scope should be encountered during the
4354 -- traversal because Establish_Transient_Scope should have
4355 -- already handled this case.
4357 elsif Scope.Is_Transient then
4358 raise Program_Error;
4360 -- The construct that requires secondary stack management is
4361 -- always enclosed by a package or subprogram scope.
4363 elsif Is_Package_Or_Subprogram (Scope.Entity) then
4364 Set_Uses_Sec_Stack (Scope.Entity);
4365 Check_Restriction (No_Secondary_Stack, N);
4372 -- At this point no suitable scope was found. This should never occur
4373 -- because a construct is always enclosed by a compilation unit which
4376 pragma Assert (False);
4377 end Delegate_Sec_Stack_Management;
4379 ------------------------------------
4380 -- Find_Enclosing_Transient_Scope --
4381 ------------------------------------
4383 function Find_Enclosing_Transient_Scope return Int is
4385 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4387 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4389 -- Prevent the search from going too far or within the scope
4390 -- space of another unit.
4392 if Scope.Entity = Standard_Standard
4393 or else Is_Package_Or_Subprogram (Scope.Entity)
4397 elsif Scope.Is_Transient then
4404 end Find_Enclosing_Transient_Scope;
4406 ----------------------------
4407 -- Find_Transient_Context --
4408 ----------------------------
4410 function Find_Transient_Context (N : Node_Id) return Node_Id is
4411 Curr : Node_Id := N;
4412 Prev : Node_Id := Empty;
4415 while Present (Curr) loop
4416 case Nkind (Curr) is
4420 -- Declarations act as a boundary for a transient scope even if
4421 -- they are not wrapped, see Wrap_Transient_Declaration.
4423 when N_Object_Declaration
4424 | N_Object_Renaming_Declaration
4425 | N_Subtype_Declaration
4431 -- Statements and statement-like constructs act as a boundary
4432 -- for a transient scope.
4434 when N_Accept_Alternative
4435 | N_Attribute_Definition_Clause
4437 | N_Case_Statement_Alternative
4439 | N_Delay_Alternative
4440 | N_Delay_Until_Statement
4441 | N_Delay_Relative_Statement
4442 | N_Discriminant_Association
4444 | N_Entry_Body_Formal_Part
4447 | N_Iteration_Scheme
4448 | N_Terminate_Alternative
4450 pragma Assert (Present (Prev));
4453 when N_Assignment_Statement =>
4456 when N_Entry_Call_Statement
4457 | N_Procedure_Call_Statement
4459 -- When an entry or procedure call acts as the alternative
4460 -- of a conditional or timed entry call, the proper context
4461 -- is that of the alternative.
4463 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
4464 and then Nkind (Parent (Parent (Curr))) in
4465 N_Conditional_Entry_Call | N_Timed_Entry_Call
4467 return Parent (Parent (Curr));
4469 -- General case for entry or procedure calls
4477 -- Pragma Check is not a valid transient context in
4478 -- GNATprove mode because the pragma must remain unchanged.
4481 and then Get_Pragma_Id (Curr) = Pragma_Check
4485 -- General case for pragmas
4491 when N_Raise_Statement =>
4494 when N_Simple_Return_Statement =>
4496 Fun_Id : constant Entity_Id :=
4497 Return_Applies_To (Return_Statement_Entity (Curr));
4500 -- A transient context that must manage the secondary
4501 -- stack cannot be a return statement of a function that
4502 -- itself requires secondary stack management, because
4503 -- the function's result would be reclaimed too early.
4504 -- And returns of thunks never require transient scopes.
4506 if (Manage_Sec_Stack
4507 and then Needs_Secondary_Stack (Etype (Fun_Id)))
4508 or else Is_Thunk (Fun_Id)
4512 -- General case for return statements
4521 when N_Attribute_Reference =>
4522 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
4526 -- An Ada 2012 iterator specification is not a valid context
4527 -- because Analyze_Iterator_Specification already employs
4528 -- special processing for it.
4530 when N_Iterator_Specification =>
4533 when N_Loop_Parameter_Specification =>
4535 -- An iteration scheme is not a valid context because
4536 -- routine Analyze_Iteration_Scheme already employs
4537 -- special processing.
4539 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
4542 return Parent (Curr);
4547 -- The following nodes represent "dummy contexts" which do not
4548 -- need to be wrapped.
4550 when N_Component_Declaration
4551 | N_Discriminant_Specification
4552 | N_Parameter_Specification
4556 -- If the traversal leaves a scope without having been able to
4557 -- find a construct to wrap, something is going wrong, but this
4558 -- can happen in error situations that are not detected yet
4559 -- (such as a dynamic string in a pragma Export).
4561 when N_Block_Statement
4564 | N_Package_Declaration
4578 Curr := Parent (Curr);
4582 end Find_Transient_Context;
4584 ------------------------------
4585 -- Is_Package_Or_Subprogram --
4586 ------------------------------
4588 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4590 return Ekind (Id) in E_Entry
4595 | E_Subprogram_Body;
4596 end Is_Package_Or_Subprogram;
4600 Trans_Idx : constant Int := Find_Enclosing_Transient_Scope;
4603 -- Start of processing for Establish_Transient_Scope
4606 -- Do not create a new transient scope if there is already an enclosing
4607 -- transient scope within the innermost enclosing package or subprogram.
4609 if Trans_Idx >= 0 then
4611 -- If the transient scope was requested for purposes of managing the
4612 -- secondary stack, then the existing scope must perform this task,
4613 -- unless the node to be wrapped is a return statement of a function
4614 -- that requires secondary stack management, because the function's
4615 -- result would be reclaimed too early (see Find_Transient_Context).
4617 if Manage_Sec_Stack then
4619 SE : Scope_Stack_Entry renames Scope_Stack.Table (Trans_Idx);
4622 if Nkind (SE.Node_To_Be_Wrapped) /= N_Simple_Return_Statement
4624 Needs_Secondary_Stack
4627 (Return_Statement_Entity (SE.Node_To_Be_Wrapped))))
4629 Set_Uses_Sec_Stack (SE.Entity);
4637 -- Find the construct that must be serviced by a new transient scope, if
4640 Context := Find_Transient_Context (N);
4642 if Present (Context) then
4643 if Nkind (Context) = N_Assignment_Statement then
4645 -- An assignment statement with suppressed controlled semantics
4646 -- does not need a transient scope because finalization is not
4647 -- desirable at this point. Note that No_Ctrl_Actions is also
4648 -- set for non-controlled assignments to suppress dispatching
4651 if No_Ctrl_Actions (Context)
4652 and then Needs_Finalization (Etype (Name (Context)))
4654 -- When a controlled component is initialized by a function
4655 -- call, the result on the secondary stack is always assigned
4656 -- to the component. Signal the nearest suitable scope that it
4657 -- is safe to manage the secondary stack.
4659 if Manage_Sec_Stack and then Within_Init_Proc then
4660 Delegate_Sec_Stack_Management;
4663 -- Otherwise the assignment is a normal transient context and thus
4664 -- requires a transient scope.
4667 Create_Transient_Scope (Context);
4673 Create_Transient_Scope (Context);
4676 end Establish_Transient_Scope;
4678 ----------------------------
4679 -- Expand_Cleanup_Actions --
4680 ----------------------------
4682 procedure Expand_Cleanup_Actions (N : Node_Id) is
4684 (Nkind (N) in N_Block_Statement
4688 | N_Extended_Return_Statement);
4690 Scop : constant Entity_Id := Current_Scope;
4692 Is_Asynchronous_Call : constant Boolean :=
4693 Nkind (N) = N_Block_Statement
4694 and then Is_Asynchronous_Call_Block (N);
4695 Is_Master : constant Boolean :=
4696 Nkind (N) /= N_Extended_Return_Statement
4697 and then Nkind (N) /= N_Entry_Body
4698 and then Is_Task_Master (N);
4699 Is_Protected_Subp_Body : constant Boolean :=
4700 Nkind (N) = N_Subprogram_Body
4701 and then Is_Protected_Subprogram_Body (N);
4702 Is_Task_Allocation : constant Boolean :=
4703 Nkind (N) = N_Block_Statement
4704 and then Is_Task_Allocation_Block (N);
4705 Is_Task_Body : constant Boolean :=
4706 Nkind (Original_Node (N)) = N_Task_Body;
4708 -- We mark the secondary stack if it is used in this construct, and
4709 -- we're not returning a function result on the secondary stack, except
4710 -- that a build-in-place function that might or might not return on the
4711 -- secondary stack always needs a mark. A run-time test is required in
4712 -- the case where the build-in-place function has a BIP_Alloc extra
4713 -- parameter (see Create_Finalizer).
4715 Needs_Sec_Stack_Mark : constant Boolean :=
4716 (Uses_Sec_Stack (Scop)
4718 not Sec_Stack_Needed_For_Return (Scop))
4720 (Is_Build_In_Place_Function (Scop)
4721 and then Needs_BIP_Alloc_Form (Scop));
4723 Needs_Custom_Cleanup : constant Boolean :=
4724 Nkind (N) = N_Block_Statement
4725 and then Present (Cleanup_Actions (N));
4727 Actions_Required : constant Boolean :=
4728 Requires_Cleanup_Actions (N, True)
4729 or else Is_Asynchronous_Call
4731 or else Is_Protected_Subp_Body
4732 or else Is_Task_Allocation
4733 or else Is_Task_Body
4734 or else Needs_Sec_Stack_Mark
4735 or else Needs_Custom_Cleanup;
4740 -- Start of processing for Expand_Cleanup_Actions
4743 -- The current construct does not need any form of servicing
4745 if not Actions_Required then
4749 -- If an extended return statement contains something like
4753 -- where F is a build-in-place function call returning a controlled
4754 -- type, then a temporary object will be implicitly declared as part
4755 -- of the statement list, and this will need cleanup. In such cases,
4758 -- return Result : T := ... do
4759 -- <statements> -- possibly with handlers
4764 -- return Result : T := ... do
4765 -- declare -- no declarations
4767 -- <statements> -- possibly with handlers
4768 -- end; -- no handlers
4771 -- So Expand_Cleanup_Actions will end up being called recursively on the
4774 if Nkind (N) = N_Extended_Return_Statement then
4776 Block : constant Node_Id :=
4777 Make_Block_Statement (Sloc (N),
4778 Declarations => Empty_List,
4779 Handled_Statement_Sequence =>
4780 Handled_Statement_Sequence (N));
4782 Set_Handled_Statement_Sequence (N,
4783 Make_Handled_Sequence_Of_Statements (Sloc (N),
4784 Statements => New_List (Block)));
4789 -- Analysis of the block did all the work
4794 if Needs_Custom_Cleanup then
4795 Cln := Cleanup_Actions (N);
4800 if No (Declarations (N)) then
4801 Set_Declarations (N, New_List);
4806 Mark : Entity_Id := Empty;
4809 -- If we are generating expanded code for debugging purposes, use the
4810 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4811 -- be updated subsequently to reference the proper line in .dg files.
4812 -- If we are not debugging generated code, use No_Location instead,
4813 -- so that no debug information is generated for the cleanup code.
4814 -- This makes the behavior of the NEXT command in GDB monotonic, and
4815 -- makes the placement of breakpoints more accurate.
4817 if Debug_Generated_Code then
4823 -- A task activation call has already been built for a task
4824 -- allocation block.
4826 if not Is_Task_Allocation then
4827 Build_Task_Activation_Call (N);
4831 Establish_Task_Master (N);
4834 -- If secondary stack is in use, generate:
4836 -- Mnn : constant Mark_Id := SS_Mark;
4838 if Needs_Sec_Stack_Mark then
4839 Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks
4840 Mark := Make_Temporary (Loc, 'M');
4843 Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark);
4845 Prepend_To (Declarations (N), Mark_Call);
4846 Analyze (Mark_Call);
4850 -- Generate finalization calls for all controlled objects appearing
4851 -- in the statements of N. Add context specific cleanup for various
4856 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
4858 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
4862 if Present (Fin_Id) then
4863 Build_Finalizer_Call (N, Fin_Id);
4866 end Expand_Cleanup_Actions;
4868 ---------------------------
4869 -- Expand_N_Package_Body --
4870 ---------------------------
4872 -- Add call to Activate_Tasks if body is an activator (actual processing
4873 -- is in chapter 9).
4875 -- Generate subprogram descriptor for elaboration routine
4877 -- Encode entity names in package body
4879 procedure Expand_N_Package_Body (N : Node_Id) is
4880 Id : constant Entity_Id := Defining_Entity (N);
4881 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
4886 -- This is done only for non-generic packages
4888 if Ekind (Spec_Id) = E_Package then
4889 -- Build dispatch tables of library-level tagged types for bodies
4890 -- that are not compilation units (see Analyze_Compilation_Unit),
4891 -- except for instances because they have no N_Compilation_Unit.
4893 if Tagged_Type_Expansion
4894 and then Is_Library_Level_Entity (Spec_Id)
4895 and then (not Is_Compilation_Unit (Spec_Id)
4896 or else Is_Generic_Instance (Spec_Id))
4898 Build_Static_Dispatch_Tables (N);
4901 Push_Scope (Spec_Id);
4903 Expand_CUDA_Package (N);
4905 Build_Task_Activation_Call (N);
4907 -- Verify the run-time semantics of pragma Initial_Condition at the
4908 -- end of the body statements.
4910 Expand_Pragma_Initial_Condition (Spec_Id, N);
4912 -- If this is a library-level package and unnesting is enabled,
4913 -- check for the presence of blocks with nested subprograms occurring
4914 -- in elaboration code, and generate procedures to encapsulate the
4915 -- blocks in case the nested subprograms make up-level references.
4917 if Unnest_Subprogram_Mode
4919 Is_Library_Level_Entity (Current_Scope)
4921 Check_Unnesting_Elaboration_Code (N);
4922 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
4923 Check_Unnesting_In_Handlers (N);
4929 Set_Elaboration_Flag (N, Spec_Id);
4930 Set_In_Package_Body (Spec_Id, False);
4932 -- Set to encode entity names in package body before gigi is called
4934 Qualify_Entity_Names (N);
4936 if Ekind (Spec_Id) /= E_Generic_Package
4937 and then not Delay_Cleanups (Id)
4941 Clean_Stmts => No_List,
4943 Defer_Abort => False,
4946 if Present (Fin_Id) then
4947 Set_Finalizer (Defining_Entity (N), Fin_Id);
4950 end Expand_N_Package_Body;
4952 ----------------------------------
4953 -- Expand_N_Package_Declaration --
4954 ----------------------------------
4956 -- Add call to Activate_Tasks if there are tasks declared and the package
4957 -- has no body. Note that in Ada 83 this may result in premature activation
4958 -- of some tasks, given that we cannot tell whether a body will eventually
4961 procedure Expand_N_Package_Declaration (N : Node_Id) is
4962 Id : constant Entity_Id := Defining_Entity (N);
4963 Spec : constant Node_Id := Specification (N);
4967 No_Body : Boolean := False;
4968 -- True in the case of a package declaration that is a compilation
4969 -- unit and for which no associated body will be compiled in this
4973 -- Case of a package declaration other than a compilation unit
4975 if Nkind (Parent (N)) /= N_Compilation_Unit then
4978 -- Case of a compilation unit that does not require a body
4980 elsif not Body_Required (Parent (N))
4981 and then not Unit_Requires_Body (Id)
4985 -- Special case of generating calling stubs for a remote call interface
4986 -- package: even though the package declaration requires one, the body
4987 -- won't be processed in this compilation (so any stubs for RACWs
4988 -- declared in the package must be generated here, along with the spec).
4990 elsif Parent (N) = Cunit (Main_Unit)
4991 and then Is_Remote_Call_Interface (Id)
4992 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
4997 -- For a nested instance, delay processing until freeze point
4999 if Has_Delayed_Freeze (Id)
5000 and then Nkind (Parent (N)) /= N_Compilation_Unit
5005 -- For a package declaration that implies no associated body, generate
5006 -- task activation call and RACW supporting bodies now (since we won't
5007 -- have a specific separate compilation unit for that).
5012 -- Generate RACW subprogram bodies
5014 if Has_RACW (Id) then
5015 Decls := Private_Declarations (Spec);
5018 Decls := Visible_Declarations (Spec);
5023 Set_Visible_Declarations (Spec, Decls);
5026 Append_RACW_Bodies (Decls, Id);
5027 Analyze_List (Decls);
5030 -- Generate task activation call as last step of elaboration
5032 if Present (Activation_Chain_Entity (N)) then
5033 Build_Task_Activation_Call (N);
5036 -- Verify the run-time semantics of pragma Initial_Condition at the
5037 -- end of the private declarations when the package lacks a body.
5039 Expand_Pragma_Initial_Condition (Id, N);
5044 -- Build dispatch tables of library-level tagged types for instances
5045 -- that are not compilation units (see Analyze_Compilation_Unit).
5047 if Tagged_Type_Expansion
5048 and then Is_Library_Level_Entity (Id)
5049 and then Is_Generic_Instance (Id)
5050 and then not Is_Compilation_Unit (Id)
5052 Build_Static_Dispatch_Tables (N);
5055 -- Note: it is not necessary to worry about generating a subprogram
5056 -- descriptor, since the only way to get exception handlers into a
5057 -- package spec is to include instantiations, and that would cause
5058 -- generation of subprogram descriptors to be delayed in any case.
5060 -- Set to encode entity names in package spec before gigi is called
5062 Qualify_Entity_Names (N);
5064 if Ekind (Id) /= E_Generic_Package
5065 and then not Delay_Cleanups (Id)
5069 Clean_Stmts => No_List,
5071 Defer_Abort => False,
5074 if Present (Fin_Id) then
5075 Set_Finalizer (Id, Fin_Id);
5079 -- If this is a library-level package and unnesting is enabled,
5080 -- check for the presence of blocks with nested subprograms occurring
5081 -- in elaboration code, and generate procedures to encapsulate the
5082 -- blocks in case the nested subprograms make up-level references.
5084 if Unnest_Subprogram_Mode
5085 and then Is_Library_Level_Entity (Current_Scope)
5087 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5088 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5090 end Expand_N_Package_Declaration;
5092 ---------------------------------
5093 -- Has_Simple_Protected_Object --
5094 ---------------------------------
5096 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5098 if Has_Task (T) then
5101 elsif Is_Simple_Protected_Type (T) then
5104 elsif Is_Array_Type (T) then
5105 return Has_Simple_Protected_Object (Component_Type (T));
5107 elsif Is_Record_Type (T) then
5112 Comp := First_Component (T);
5113 while Present (Comp) loop
5114 if Has_Simple_Protected_Object (Etype (Comp)) then
5118 Next_Component (Comp);
5127 end Has_Simple_Protected_Object;
5129 ------------------------------------
5130 -- Insert_Actions_In_Scope_Around --
5131 ------------------------------------
5133 procedure Insert_Actions_In_Scope_Around
5136 Manage_SS : Boolean)
5138 Act_Before : constant List_Id :=
5139 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5140 Act_After : constant List_Id :=
5141 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5142 Act_Cleanup : constant List_Id :=
5143 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5144 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5145 -- Last), but this was incorrect as Process_Transients_In_Scope may
5146 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5148 procedure Process_Transients_In_Scope
5149 (First_Object : Node_Id;
5150 Last_Object : Node_Id;
5151 Related_Node : Node_Id);
5152 -- Find all transient objects in the list First_Object .. Last_Object
5153 -- and generate finalization actions for them. Related_Node denotes the
5154 -- node which created all transient objects.
5156 ---------------------------------
5157 -- Process_Transients_In_Scope --
5158 ---------------------------------
5160 procedure Process_Transients_In_Scope
5161 (First_Object : Node_Id;
5162 Last_Object : Node_Id;
5163 Related_Node : Node_Id)
5165 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5166 -- Return Abandon if arbitrary node denotes a subprogram call
5168 function Has_Subprogram_Call is
5169 new Traverse_Func (Is_Subprogram_Call);
5171 procedure Process_Transient_In_Scope
5172 (Obj_Decl : Node_Id;
5173 Insert_Nod : Node_Id;
5174 Must_Export : Boolean);
5175 -- Generate finalization actions for a single transient object
5176 -- denoted by object declaration Obj_Decl.
5178 ------------------------
5179 -- Is_Subprogram_Call --
5180 ------------------------
5182 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5184 -- A regular procedure or function call
5186 if Nkind (N) in N_Subprogram_Call then
5191 -- Heavy expansion may relocate function calls outside the related
5192 -- node. Inspect the original node to detect the initial placement
5195 elsif Is_Rewrite_Substitution (N) then
5196 return Has_Subprogram_Call (Original_Node (N));
5198 -- Generalized indexing always involves a function call
5200 elsif Nkind (N) = N_Indexed_Component
5201 and then Present (Generalized_Indexing (N))
5210 end Is_Subprogram_Call;
5212 --------------------------------
5213 -- Process_Transient_In_Scope --
5214 --------------------------------
5216 procedure Process_Transient_In_Scope
5217 (Obj_Decl : Node_Id;
5218 Insert_Nod : Node_Id;
5219 Must_Export : Boolean)
5221 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5222 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5224 Master_Node_Id : Entity_Id;
5225 Master_Node_Decl : Node_Id;
5227 Obj_Typ : Entity_Id;
5230 -- If the object needs to be exported to the outer finalizer,
5231 -- create the declaration of the Master_Node for the object,
5232 -- which will later be picked up by Build_Finalizer.
5235 Master_Node_Id := Make_Temporary (Loc, 'N');
5237 Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id);
5238 Insert_Before_And_Analyze (Obj_Decl, Master_Node_Decl);
5240 -- Generate the attachment of the object to the Master_Node
5242 Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id);
5244 -- Then add the finalization call for the object
5246 Insert_After_And_Analyze (Insert_Nod,
5247 Make_Finalize_Call_For_Node (Loc, Master_Node_Id));
5249 -- Otherwise generate a direct finalization call for the object
5252 -- Handle the object type and the reference to the object
5254 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
5255 Obj_Typ := Base_Type (Etype (Obj_Id));
5257 if Is_Access_Type (Obj_Typ) then
5258 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
5259 Obj_Typ := Available_View (Designated_Type (Obj_Typ));
5262 Insert_After_And_Analyze (Insert_Nod,
5263 Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Obj_Typ));
5266 -- Mark the transient object to avoid double finalization
5268 Set_Is_Finalized_Transient (Obj_Id);
5269 end Process_Transient_In_Scope;
5273 Insert_Nod : Node_Id;
5274 -- Insertion node for the finalization actions
5276 Must_Export : Boolean;
5277 -- Flag denoting whether the context requires transient object
5278 -- export to the outer finalizer.
5282 -- Start of processing for Process_Transients_In_Scope
5285 -- The expansion performed by this routine is as follows:
5287 -- Ctrl_Trans_Obj_1MN : Master_Node;
5288 -- Ctrl_Trans_Obj_1 : ...;
5290 -- Ctrl_Trans_Obj_NMN : Master_Node;
5291 -- Ctrl_Trans_Obj_N : ...;
5293 -- Finalize_Object (Ctrl_Trans_Obj_NMN);
5295 -- Finalize_Object (Ctrl_Trans_Obj_1MN);
5297 -- Recognize a scenario where the transient context is an object
5298 -- declaration initialized by a build-in-place function call:
5300 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5302 -- The rough expansion of the above is:
5304 -- Temp : ... := Ctrl_Func_Call;
5306 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5308 -- The finalization of any transient object must happen after the
5309 -- build-in-place function call is executed.
5311 if Nkind (N) = N_Object_Declaration
5312 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5314 Must_Export := True;
5315 Insert_Nod := BIP_Initialization_Call (Defining_Identifier (N));
5317 -- Search the context for at least one subprogram call. If found, the
5318 -- machinery exports all transient objects to the enclosing finalizer
5319 -- due to the possibility of abnormal call termination.
5322 Must_Export := Has_Subprogram_Call (N) = Abandon;
5323 Insert_Nod := Last_Object;
5326 Insert_List_After_And_Analyze (Insert_Nod, Act_Cleanup);
5328 -- Examine all the objects in the list First_Object .. Last_Object
5329 -- but skip the node to be wrapped because it is not transient as
5330 -- far as this scope is concerned.
5332 Obj_Decl := First_Object;
5333 while Present (Obj_Decl) loop
5334 if Obj_Decl /= Related_Node
5335 and then Nkind (Obj_Decl) = N_Object_Declaration
5336 and then Analyzed (Obj_Decl)
5337 and then Is_Finalizable_Transient (Obj_Decl, N)
5339 Process_Transient_In_Scope (Obj_Decl, Insert_Nod, Must_Export);
5342 exit when Obj_Decl = Last_Object;
5346 end Process_Transients_In_Scope;
5350 Loc : constant Source_Ptr := Sloc (N);
5351 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5352 First_Obj : Node_Id;
5354 Mark_Id : Entity_Id;
5357 -- Start of processing for Insert_Actions_In_Scope_Around
5360 -- Nothing to do if the scope does not manage the secondary stack or
5361 -- does not contain meaningful actions for insertion.
5364 and then No (Act_Before)
5365 and then No (Act_After)
5366 and then No (Act_Cleanup)
5371 -- If the node to be wrapped is the trigger of an asynchronous select,
5372 -- it is not part of a statement list. The actions must be inserted
5373 -- before the select itself, which is part of some list of statements.
5374 -- Note that the triggering alternative includes the triggering
5375 -- statement and an optional statement list. If the node to be
5376 -- wrapped is part of that list, the normal insertion applies.
5378 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5379 and then not Is_List_Member (Node_To_Wrap)
5381 Target := Parent (Parent (Node_To_Wrap));
5386 First_Obj := Target;
5389 -- Add all actions associated with a transient scope into the main tree.
5390 -- There are several scenarios here:
5392 -- +--- Before ----+ +----- After ---+
5393 -- 1) First_Obj ....... Target ........ Last_Obj
5395 -- 2) First_Obj ....... Target
5397 -- 3) Target ........ Last_Obj
5399 -- Flag declarations are inserted before the first object
5401 if Present (Act_Before) then
5402 First_Obj := First (Act_Before);
5403 Insert_List_Before (Target, Act_Before);
5406 -- Finalization calls are inserted after the last object
5408 if Present (Act_After) then
5409 Last_Obj := Last (Act_After);
5410 Insert_List_After (Target, Act_After);
5413 -- Mark and release the secondary stack when the context warrants it
5416 Mark_Id := Make_Temporary (Loc, 'M');
5419 -- Mnn : constant Mark_Id := SS_Mark;
5421 Insert_Before_And_Analyze
5422 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5425 -- SS_Release (Mnn);
5427 Insert_After_And_Analyze
5428 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5431 -- If we are handling cleanups, check for transient objects associated
5432 -- with Target and generate the required finalization actions for them.
5435 Process_Transients_In_Scope
5436 (First_Object => First_Obj,
5437 Last_Object => Last_Obj,
5438 Related_Node => Target);
5441 -- Reset the action lists
5444 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
5446 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
5450 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
5452 end Insert_Actions_In_Scope_Around;
5454 ------------------------------
5455 -- Is_Simple_Protected_Type --
5456 ------------------------------
5458 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5461 Is_Protected_Type (T)
5462 and then not Uses_Lock_Free (T)
5463 and then not Has_Entries (T)
5464 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5465 end Is_Simple_Protected_Type;
5467 -------------------------------
5468 -- Make_Address_For_Finalize --
5469 -------------------------------
5471 function Make_Address_For_Finalize
5474 Obj_Typ : Entity_Id) return Node_Id
5480 Make_Attribute_Reference (Loc,
5482 Attribute_Name => Name_Address);
5484 -- If the type of a constrained array has an unconstrained first
5485 -- subtype, its Finalize_Address primitive expects the address of
5486 -- an object with a dope vector (see Make_Finalize_Address_Stmts).
5487 -- This is achieved by setting Is_Constr_Array_Subt_With_Bounds,
5488 -- but the address of the object is still that of its elements,
5489 -- so we need to shift it.
5491 if Is_Array_Type (Obj_Typ)
5492 and then not Is_Constrained (First_Subtype (Obj_Typ))
5494 -- Shift the address from the start of the elements to the
5495 -- start of the dope vector:
5497 -- V - (Obj_Typ'Descriptor_Size / Storage_Unit)
5500 Make_Function_Call (Loc,
5502 Make_Expanded_Name (Loc,
5503 Chars => Name_Op_Subtract,
5506 (RTU_Entity (System_Storage_Elements), Loc),
5508 Make_Identifier (Loc, Name_Op_Subtract)),
5509 Parameter_Associations => New_List (
5511 Make_Op_Divide (Loc,
5513 Make_Attribute_Reference (Loc,
5514 Prefix => New_Occurrence_Of (Obj_Typ, Loc),
5515 Attribute_Name => Name_Descriptor_Size),
5517 Make_Integer_Literal (Loc, System_Storage_Unit))));
5521 end Make_Address_For_Finalize;
5523 -----------------------
5524 -- Make_Adjust_Call --
5525 -----------------------
5527 function Make_Adjust_Call
5530 Skip_Self : Boolean := False) return Node_Id
5532 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5533 Adj_Id : Entity_Id := Empty;
5540 -- Recover the proper type which contains Deep_Adjust
5542 if Is_Class_Wide_Type (Typ) then
5543 Utyp := Root_Type (Typ);
5548 Utyp := Underlying_Type (Base_Type (Utyp));
5549 Set_Assignment_OK (Ref);
5551 -- Deal with untagged derivation of private views
5553 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
5554 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5555 Ref := Unchecked_Convert_To (Utyp, Ref);
5556 Set_Assignment_OK (Ref);
5559 -- When dealing with the completion of a private type, use the base
5562 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
5563 pragma Assert (Is_Private_Type (Typ));
5565 Utyp := Base_Type (Utyp);
5566 Ref := Unchecked_Convert_To (Utyp, Ref);
5569 -- The underlying type may not be present due to a missing full view. In
5570 -- this case freezing did not take place and there is no [Deep_]Adjust
5571 -- primitive to call.
5576 elsif Skip_Self then
5577 if Has_Controlled_Component (Utyp) then
5578 if Is_Tagged_Type (Utyp) then
5579 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5581 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5585 -- Class-wide types, interfaces and types with controlled components
5587 elsif Is_Class_Wide_Type (Typ)
5588 or else Is_Interface (Typ)
5589 or else Has_Controlled_Component (Utyp)
5591 if Is_Tagged_Type (Utyp) then
5592 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5594 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5597 -- Derivations from [Limited_]Controlled
5599 elsif Is_Controlled (Utyp) then
5600 Adj_Id := Find_Controlled_Prim_Op (Utyp, Name_Adjust);
5604 elsif Is_Tagged_Type (Utyp) then
5605 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5608 raise Program_Error;
5611 if Present (Adj_Id) then
5612 -- The object reference may need another conversion depending on the
5613 -- type of the formal and that of the actual.
5615 if not Is_Class_Wide_Type (Typ) then
5616 Ref := Convert_View (Adj_Id, Ref, Typ);
5623 Skip_Self => Skip_Self);
5627 end Make_Adjust_Call;
5635 Proc_Id : Entity_Id;
5637 Skip_Self : Boolean := False) return Node_Id
5639 Params : constant List_Id := New_List (Param);
5642 -- Do not apply the controlled action to the object itself by signaling
5643 -- the related routine to avoid self.
5646 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
5650 Make_Procedure_Call_Statement (Loc,
5651 Name => New_Occurrence_Of (Proc_Id, Loc),
5652 Parameter_Associations => Params);
5655 --------------------------
5656 -- Make_Deep_Array_Body --
5657 --------------------------
5659 function Make_Deep_Array_Body
5660 (Prim : Final_Primitives;
5661 Typ : Entity_Id) return List_Id
5663 function Build_Adjust_Or_Finalize_Statements
5664 (Typ : Entity_Id) return List_Id;
5665 -- Create the statements necessary to adjust or finalize an array of
5666 -- controlled elements. Generate:
5669 -- Abort : constant Boolean := Triggered_By_Abort;
5671 -- Abort : constant Boolean := False; -- no abort
5673 -- E : Exception_Occurrence;
5674 -- Raised : Boolean := False;
5677 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5678 -- ^-- in the finalization case
5680 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5682 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5686 -- if not Raised then
5688 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5695 -- if Raised and then not Abort then
5696 -- Raise_From_Controlled_Operation (E);
5700 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
5701 -- Create the statements necessary to initialize an array of controlled
5702 -- elements. Include a mechanism to carry out partial finalization if an
5703 -- exception occurs. Generate:
5706 -- Counter : Integer := 0;
5709 -- for J1 in V'Range (1) loop
5711 -- for JN in V'Range (N) loop
5713 -- [Deep_]Initialize (V (J1, ..., JN));
5715 -- Counter := Counter + 1;
5720 -- Abort : constant Boolean := Triggered_By_Abort;
5722 -- Abort : constant Boolean := False; -- no abort
5723 -- E : Exception_Occurrence;
5724 -- Raised : Boolean := False;
5731 -- V'Length (N) - Counter;
5733 -- for F1 in reverse V'Range (1) loop
5735 -- for FN in reverse V'Range (N) loop
5736 -- if Counter > 0 then
5737 -- Counter := Counter - 1;
5740 -- [Deep_]Finalize (V (F1, ..., FN));
5744 -- if not Raised then
5746 -- Save_Occurrence (E,
5747 -- Get_Current_Excep.all.all);
5756 -- if Raised and then not Abort then
5757 -- Raise_From_Controlled_Operation (E);
5766 function New_References_To
5768 Loc : Source_Ptr) return List_Id;
5769 -- Given a list of defining identifiers, return a list of references to
5770 -- the original identifiers, in the same order as they appear.
5772 -----------------------------------------
5773 -- Build_Adjust_Or_Finalize_Statements --
5774 -----------------------------------------
5776 function Build_Adjust_Or_Finalize_Statements
5777 (Typ : Entity_Id) return List_Id
5779 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5780 Index_List : constant List_Id := New_List;
5781 Loc : constant Source_Ptr := Sloc (Typ);
5782 Num_Dims : constant Int := Number_Dimensions (Typ);
5784 procedure Build_Indexes;
5785 -- Generate the indexes used in the dimension loops
5791 procedure Build_Indexes is
5793 -- Generate the following identifiers:
5794 -- Jnn - for initialization
5796 for Dim in 1 .. Num_Dims loop
5797 Append_To (Index_List,
5798 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5804 Final_Decls : List_Id := No_List;
5805 Final_Data : Finalization_Exception_Data;
5809 Core_Loop : Node_Id;
5812 Loop_Id : Entity_Id;
5815 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5818 Final_Decls := New_List;
5821 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
5824 Make_Indexed_Component (Loc,
5825 Prefix => Make_Identifier (Loc, Name_V),
5826 Expressions => New_References_To (Index_List, Loc));
5827 Set_Etype (Comp_Ref, Comp_Typ);
5830 -- [Deep_]Adjust (V (J1, ..., JN))
5832 if Prim = Adjust_Case then
5833 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5836 -- [Deep_]Finalize (V (J1, ..., JN))
5838 else pragma Assert (Prim = Finalize_Case);
5839 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5842 if Present (Call) then
5844 -- Generate the block which houses the adjust or finalize call:
5847 -- <adjust or finalize call>
5851 -- if not Raised then
5853 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5857 if Exceptions_OK then
5859 Make_Block_Statement (Loc,
5860 Handled_Statement_Sequence =>
5861 Make_Handled_Sequence_Of_Statements (Loc,
5862 Statements => New_List (Call),
5863 Exception_Handlers => New_List (
5864 Build_Exception_Handler (Final_Data))));
5869 -- Generate the dimension loops starting from the innermost one
5871 -- for Jnn in [reverse] V'Range (Dim) loop
5875 J := Last (Index_List);
5877 while Present (J) and then Dim > 0 loop
5883 Make_Loop_Statement (Loc,
5885 Make_Iteration_Scheme (Loc,
5886 Loop_Parameter_Specification =>
5887 Make_Loop_Parameter_Specification (Loc,
5888 Defining_Identifier => Loop_Id,
5889 Discrete_Subtype_Definition =>
5890 Make_Attribute_Reference (Loc,
5891 Prefix => Make_Identifier (Loc, Name_V),
5892 Attribute_Name => Name_Range,
5893 Expressions => New_List (
5894 Make_Integer_Literal (Loc, Dim))),
5897 Prim = Finalize_Case)),
5899 Statements => New_List (Core_Loop),
5900 End_Label => Empty);
5905 -- Generate the block which contains the core loop, declarations
5906 -- of the abort flag, the exception occurrence, the raised flag
5907 -- and the conditional raise:
5910 -- Abort : constant Boolean := Triggered_By_Abort;
5912 -- Abort : constant Boolean := False; -- no abort
5914 -- E : Exception_Occurrence;
5915 -- Raised : Boolean := False;
5920 -- if Raised and then not Abort then
5921 -- Raise_From_Controlled_Operation (E);
5925 Stmts := New_List (Core_Loop);
5927 if Exceptions_OK then
5928 Append_To (Stmts, Build_Raise_Statement (Final_Data));
5932 Make_Block_Statement (Loc,
5933 Declarations => Final_Decls,
5934 Handled_Statement_Sequence =>
5935 Make_Handled_Sequence_Of_Statements (Loc,
5936 Statements => Stmts));
5938 -- Otherwise previous errors or a missing full view may prevent the
5939 -- proper freezing of the component type. If this is the case, there
5940 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
5943 Block := Make_Null_Statement (Loc);
5946 return New_List (Block);
5947 end Build_Adjust_Or_Finalize_Statements;
5949 ---------------------------------
5950 -- Build_Initialize_Statements --
5951 ---------------------------------
5953 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
5954 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5955 Final_List : constant List_Id := New_List;
5956 Index_List : constant List_Id := New_List;
5957 Loc : constant Source_Ptr := Sloc (Typ);
5958 Num_Dims : constant Int := Number_Dimensions (Typ);
5960 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
5961 -- Generate the following assignment:
5962 -- Counter := V'Length (1) *
5964 -- V'Length (N) - Counter;
5966 -- Counter_Id denotes the entity of the counter.
5968 function Build_Finalization_Call return Node_Id;
5969 -- Generate a deep finalization call for an array element
5971 procedure Build_Indexes;
5972 -- Generate the initialization and finalization indexes used in the
5975 function Build_Initialization_Call return Node_Id;
5976 -- Generate a deep initialization call for an array element
5978 ----------------------
5979 -- Build_Assignment --
5980 ----------------------
5982 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
5987 -- Start from the first dimension and generate:
5992 Make_Attribute_Reference (Loc,
5993 Prefix => Make_Identifier (Loc, Name_V),
5994 Attribute_Name => Name_Length,
5995 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
5997 -- Process the rest of the dimensions, generate:
5998 -- Expr * V'Length (N)
6001 while Dim <= Num_Dims loop
6003 Make_Op_Multiply (Loc,
6006 Make_Attribute_Reference (Loc,
6007 Prefix => Make_Identifier (Loc, Name_V),
6008 Attribute_Name => Name_Length,
6009 Expressions => New_List (
6010 Make_Integer_Literal (Loc, Dim))));
6016 -- Counter := Expr - Counter;
6019 Make_Assignment_Statement (Loc,
6020 Name => New_Occurrence_Of (Counter_Id, Loc),
6022 Make_Op_Subtract (Loc,
6024 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6025 end Build_Assignment;
6027 -----------------------------
6028 -- Build_Finalization_Call --
6029 -----------------------------
6031 function Build_Finalization_Call return Node_Id is
6032 Comp_Ref : constant Node_Id :=
6033 Make_Indexed_Component (Loc,
6034 Prefix => Make_Identifier (Loc, Name_V),
6035 Expressions => New_References_To (Final_List, Loc));
6038 Set_Etype (Comp_Ref, Comp_Typ);
6041 -- [Deep_]Finalize (V);
6043 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6044 end Build_Finalization_Call;
6050 procedure Build_Indexes is
6052 -- Generate the following identifiers:
6053 -- Jnn - for initialization
6054 -- Fnn - for finalization
6056 for Dim in 1 .. Num_Dims loop
6057 Append_To (Index_List,
6058 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6060 Append_To (Final_List,
6061 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6065 -------------------------------
6066 -- Build_Initialization_Call --
6067 -------------------------------
6069 function Build_Initialization_Call return Node_Id is
6070 Comp_Ref : constant Node_Id :=
6071 Make_Indexed_Component (Loc,
6072 Prefix => Make_Identifier (Loc, Name_V),
6073 Expressions => New_References_To (Index_List, Loc));
6076 Set_Etype (Comp_Ref, Comp_Typ);
6079 -- [Deep_]Initialize (V (J1, ..., JN));
6081 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6082 end Build_Initialization_Call;
6086 Counter_Id : Entity_Id;
6090 Final_Block : Node_Id;
6091 Final_Data : Finalization_Exception_Data;
6092 Final_Decls : List_Id := No_List;
6093 Final_Loop : Node_Id;
6094 Init_Block : Node_Id;
6095 Init_Call : Node_Id;
6096 Init_Loop : Node_Id;
6101 -- Start of processing for Build_Initialize_Statements
6104 Counter_Id := Make_Temporary (Loc, 'C');
6105 Final_Decls := New_List;
6108 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6110 -- Generate the block which houses the finalization call, the index
6111 -- guard and the handler which triggers Program_Error later on.
6113 -- if Counter > 0 then
6114 -- Counter := Counter - 1;
6117 -- [Deep_]Finalize (V (F1, ..., FN));
6120 -- if not Raised then
6122 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6127 Fin_Stmt := Build_Finalization_Call;
6129 if Present (Fin_Stmt) then
6130 if Exceptions_OK then
6132 Make_Block_Statement (Loc,
6133 Handled_Statement_Sequence =>
6134 Make_Handled_Sequence_Of_Statements (Loc,
6135 Statements => New_List (Fin_Stmt),
6136 Exception_Handlers => New_List (
6137 Build_Exception_Handler (Final_Data))));
6140 -- This is the core of the loop, the dimension iterators are added
6141 -- one by one in reverse.
6144 Make_If_Statement (Loc,
6147 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6148 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6150 Then_Statements => New_List (
6151 Make_Assignment_Statement (Loc,
6152 Name => New_Occurrence_Of (Counter_Id, Loc),
6154 Make_Op_Subtract (Loc,
6155 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6156 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6158 Else_Statements => New_List (Fin_Stmt));
6160 -- Generate all finalization loops starting from the innermost
6163 -- for Fnn in reverse V'Range (Dim) loop
6167 F := Last (Final_List);
6169 while Present (F) and then Dim > 0 loop
6175 Make_Loop_Statement (Loc,
6177 Make_Iteration_Scheme (Loc,
6178 Loop_Parameter_Specification =>
6179 Make_Loop_Parameter_Specification (Loc,
6180 Defining_Identifier => Loop_Id,
6181 Discrete_Subtype_Definition =>
6182 Make_Attribute_Reference (Loc,
6183 Prefix => Make_Identifier (Loc, Name_V),
6184 Attribute_Name => Name_Range,
6185 Expressions => New_List (
6186 Make_Integer_Literal (Loc, Dim))),
6188 Reverse_Present => True)),
6190 Statements => New_List (Final_Loop),
6191 End_Label => Empty);
6196 -- Generate the block which contains the finalization loops, the
6197 -- declarations of the abort flag, the exception occurrence, the
6198 -- raised flag and the conditional raise.
6201 -- Abort : constant Boolean := Triggered_By_Abort;
6203 -- Abort : constant Boolean := False; -- no abort
6205 -- E : Exception_Occurrence;
6206 -- Raised : Boolean := False;
6212 -- V'Length (N) - Counter;
6216 -- if Raised and then not Abort then
6217 -- Raise_From_Controlled_Operation (E);
6223 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6225 if Exceptions_OK then
6226 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6227 Append_To (Stmts, Make_Raise_Statement (Loc));
6231 Make_Block_Statement (Loc,
6232 Declarations => Final_Decls,
6233 Handled_Statement_Sequence =>
6234 Make_Handled_Sequence_Of_Statements (Loc,
6235 Statements => Stmts));
6237 -- Otherwise previous errors or a missing full view may prevent the
6238 -- proper freezing of the component type. If this is the case, there
6239 -- is no [Deep_]Finalize primitive to call.
6242 Final_Block := Make_Null_Statement (Loc);
6245 -- Generate the block which contains the initialization call and
6246 -- the partial finalization code.
6249 -- [Deep_]Initialize (V (J1, ..., JN));
6251 -- Counter := Counter + 1;
6255 -- <finalization code>
6258 Init_Call := Build_Initialization_Call;
6260 -- Only create finalization block if there is a nontrivial call
6261 -- to initialization or a Default_Initial_Condition check to be
6264 if (Present (Init_Call)
6265 and then Nkind (Init_Call) /= N_Null_Statement)
6268 and then not GNATprove_Mode
6269 and then Present (DIC_Procedure (Comp_Typ))
6270 and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
6273 Init_Stmts : constant List_Id := New_List;
6276 if Present (Init_Call) then
6277 Append_To (Init_Stmts, Init_Call);
6280 if Has_DIC (Comp_Typ)
6281 and then Present (DIC_Procedure (Comp_Typ))
6285 Build_DIC_Call (Loc,
6286 Make_Indexed_Component (Loc,
6287 Prefix => Make_Identifier (Loc, Name_V),
6288 Expressions => New_References_To (Index_List, Loc)),
6293 Make_Block_Statement (Loc,
6294 Handled_Statement_Sequence =>
6295 Make_Handled_Sequence_Of_Statements (Loc,
6296 Statements => Init_Stmts,
6297 Exception_Handlers => New_List (
6298 Make_Exception_Handler (Loc,
6299 Exception_Choices => New_List (
6300 Make_Others_Choice (Loc)),
6301 Statements => New_List (Final_Block)))));
6304 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6305 Make_Assignment_Statement (Loc,
6306 Name => New_Occurrence_Of (Counter_Id, Loc),
6309 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6310 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6312 -- Generate all initialization loops starting from the innermost
6315 -- for Jnn in V'Range (Dim) loop
6319 J := Last (Index_List);
6321 while Present (J) and then Dim > 0 loop
6327 Make_Loop_Statement (Loc,
6329 Make_Iteration_Scheme (Loc,
6330 Loop_Parameter_Specification =>
6331 Make_Loop_Parameter_Specification (Loc,
6332 Defining_Identifier => Loop_Id,
6333 Discrete_Subtype_Definition =>
6334 Make_Attribute_Reference (Loc,
6335 Prefix => Make_Identifier (Loc, Name_V),
6336 Attribute_Name => Name_Range,
6337 Expressions => New_List (
6338 Make_Integer_Literal (Loc, Dim))))),
6340 Statements => New_List (Init_Loop),
6341 End_Label => Empty);
6346 -- Generate the block which contains the counter variable and the
6347 -- initialization loops.
6350 -- Counter : Integer := 0;
6356 Make_Block_Statement (Loc,
6357 Declarations => New_List (
6358 Make_Object_Declaration (Loc,
6359 Defining_Identifier => Counter_Id,
6360 Object_Definition =>
6361 New_Occurrence_Of (Standard_Integer, Loc),
6362 Expression => Make_Integer_Literal (Loc, 0))),
6364 Handled_Statement_Sequence =>
6365 Make_Handled_Sequence_Of_Statements (Loc,
6366 Statements => New_List (Init_Loop)));
6368 if Debug_Generated_Code then
6369 Set_Debug_Info_Needed (Counter_Id);
6372 -- Otherwise previous errors or a missing full view may prevent the
6373 -- proper freezing of the component type. If this is the case, there
6374 -- is no [Deep_]Initialize primitive to call.
6377 Init_Block := Make_Null_Statement (Loc);
6380 return New_List (Init_Block);
6381 end Build_Initialize_Statements;
6383 -----------------------
6384 -- New_References_To --
6385 -----------------------
6387 function New_References_To
6389 Loc : Source_Ptr) return List_Id
6391 Refs : constant List_Id := New_List;
6396 while Present (Id) loop
6397 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6402 end New_References_To;
6404 -- Start of processing for Make_Deep_Array_Body
6408 when Address_Case =>
6409 return Make_Finalize_Address_Stmts (Typ);
6414 return Build_Adjust_Or_Finalize_Statements (Typ);
6416 when Initialize_Case =>
6417 return Build_Initialize_Statements (Typ);
6419 end Make_Deep_Array_Body;
6421 --------------------
6422 -- Make_Deep_Proc --
6423 --------------------
6425 function Make_Deep_Proc
6426 (Prim : Final_Primitives;
6428 Stmts : List_Id) return Entity_Id
6430 Loc : constant Source_Ptr := Sloc (Typ);
6432 Proc_Id : Entity_Id;
6435 -- Create the object formal, generate:
6436 -- V : System.Address
6438 if Prim = Address_Case then
6439 Formals := New_List (
6440 Make_Parameter_Specification (Loc,
6441 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6443 New_Occurrence_Of (RTE (RE_Address), Loc)));
6450 Formals := New_List (
6451 Make_Parameter_Specification (Loc,
6452 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6454 Out_Present => True,
6455 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6457 -- F : Boolean := True
6459 if Prim = Adjust_Case
6460 or else Prim = Finalize_Case
6463 Make_Parameter_Specification (Loc,
6464 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6466 New_Occurrence_Of (Standard_Boolean, Loc),
6468 New_Occurrence_Of (Standard_True, Loc)));
6473 Make_Defining_Identifier (Loc,
6474 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6477 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6480 -- exception -- Finalize and Adjust cases only
6481 -- raise Program_Error;
6482 -- end Deep_Initialize / Adjust / Finalize;
6486 -- procedure Finalize_Address (V : System.Address) is
6489 -- end Finalize_Address;
6492 Make_Subprogram_Body (Loc,
6494 Make_Procedure_Specification (Loc,
6495 Defining_Unit_Name => Proc_Id,
6496 Parameter_Specifications => Formals),
6498 Declarations => Empty_List,
6500 Handled_Statement_Sequence =>
6501 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
6503 -- If there are no calls to component initialization, indicate that
6504 -- the procedure is trivial, so prevent calls to it.
6506 if Is_Empty_List (Stmts)
6507 or else Nkind (First (Stmts)) = N_Null_Statement
6509 Set_Is_Trivial_Subprogram (Proc_Id);
6515 ---------------------------
6516 -- Make_Deep_Record_Body --
6517 ---------------------------
6519 function Make_Deep_Record_Body
6520 (Prim : Final_Primitives;
6522 Is_Local : Boolean := False) return List_Id
6524 Loc : constant Source_Ptr := Sloc (Typ);
6526 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
6527 -- Build the statements necessary to adjust a record type. The type may
6528 -- have discriminants and contain variant parts. Generate:
6532 -- [Deep_]Adjust (V.Comp_1);
6534 -- when Id : others =>
6535 -- if not Raised then
6537 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6542 -- [Deep_]Adjust (V.Comp_N);
6544 -- when Id : others =>
6545 -- if not Raised then
6547 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6552 -- Deep_Adjust (V._parent, False); -- If applicable
6554 -- when Id : others =>
6555 -- if not Raised then
6557 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6563 -- Adjust (V); -- If applicable
6566 -- if not Raised then
6568 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6573 -- if Raised and then not Abort then
6574 -- Raise_From_Controlled_Operation (E);
6578 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
6579 -- Build the statements necessary to finalize a record type. The type
6580 -- may have discriminants and contain variant parts. Generate:
6583 -- Abort : constant Boolean := Triggered_By_Abort;
6585 -- Abort : constant Boolean := False; -- no abort
6586 -- E : Exception_Occurrence;
6587 -- Raised : Boolean := False;
6592 -- Finalize (V); -- If applicable
6595 -- if not Raised then
6597 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6602 -- case Variant_1 is
6604 -- case State_Counter_N => -- If Is_Local is enabled
6614 -- <<LN>> -- If Is_Local is enabled
6616 -- [Deep_]Finalize (V.Comp_N);
6619 -- if not Raised then
6621 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6627 -- [Deep_]Finalize (V.Comp_1);
6630 -- if not Raised then
6632 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6638 -- case State_Counter_1 => -- If Is_Local is enabled
6644 -- Deep_Finalize (V._parent, False); -- If applicable
6646 -- when Id : others =>
6647 -- if not Raised then
6649 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6653 -- if Raised and then not Abort then
6654 -- Raise_From_Controlled_Operation (E);
6658 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
6659 -- Given a derived tagged type Typ, traverse all components, find field
6660 -- _parent and return its type.
6662 procedure Preprocess_Components
6664 Num_Comps : out Nat;
6665 Has_POC : out Boolean);
6666 -- Examine all components in component list Comps, count all controlled
6667 -- components and determine whether at least one of them is per-object
6668 -- constrained. Component _parent is always skipped.
6670 -----------------------------
6671 -- Build_Adjust_Statements --
6672 -----------------------------
6674 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
6675 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
6677 Finalizer_Data : Finalization_Exception_Data;
6679 function Process_Component_List_For_Adjust
6680 (Comps : Node_Id) return List_Id;
6681 -- Build all necessary adjust statements for a single component list
6683 ---------------------------------------
6684 -- Process_Component_List_For_Adjust --
6685 ---------------------------------------
6687 function Process_Component_List_For_Adjust
6688 (Comps : Node_Id) return List_Id
6690 Stmts : constant List_Id := New_List;
6692 procedure Process_Component_For_Adjust (Decl : Node_Id);
6693 -- Process the declaration of a single controlled component
6695 ----------------------------------
6696 -- Process_Component_For_Adjust --
6697 ----------------------------------
6699 procedure Process_Component_For_Adjust (Decl : Node_Id) is
6700 Id : constant Entity_Id := Defining_Identifier (Decl);
6701 Typ : constant Entity_Id := Etype (Id);
6707 -- [Deep_]Adjust (V.Id);
6711 -- if not Raised then
6713 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6720 Make_Selected_Component (Loc,
6721 Prefix => Make_Identifier (Loc, Name_V),
6722 Selector_Name => Make_Identifier (Loc, Chars (Id))),
6725 -- Guard against a missing [Deep_]Adjust when the component
6726 -- type was not properly frozen.
6728 if Present (Adj_Call) then
6729 if Exceptions_OK then
6731 Make_Block_Statement (Loc,
6732 Handled_Statement_Sequence =>
6733 Make_Handled_Sequence_Of_Statements (Loc,
6734 Statements => New_List (Adj_Call),
6735 Exception_Handlers => New_List (
6736 Build_Exception_Handler (Finalizer_Data))));
6739 Append_To (Stmts, Adj_Call);
6741 end Process_Component_For_Adjust;
6746 Decl_Id : Entity_Id;
6747 Decl_Typ : Entity_Id;
6752 -- Start of processing for Process_Component_List_For_Adjust
6755 -- Perform an initial check, determine the number of controlled
6756 -- components in the current list and whether at least one of them
6757 -- is per-object constrained.
6759 Preprocess_Components (Comps, Num_Comps, Has_POC);
6761 -- The processing in this routine is done in the following order:
6762 -- 1) Regular components
6763 -- 2) Per-object constrained components
6766 if Num_Comps > 0 then
6768 -- Process all regular components in order of declarations
6770 Decl := First_Non_Pragma (Component_Items (Comps));
6771 while Present (Decl) loop
6772 Decl_Id := Defining_Identifier (Decl);
6773 Decl_Typ := Etype (Decl_Id);
6775 -- Skip _parent as well as per-object constrained components
6777 if Chars (Decl_Id) /= Name_uParent
6778 and then Needs_Finalization (Decl_Typ)
6780 if Has_Access_Constraint (Decl_Id)
6781 and then No (Expression (Decl))
6785 Process_Component_For_Adjust (Decl);
6789 Next_Non_Pragma (Decl);
6792 -- Process all per-object constrained components in order of
6796 Decl := First_Non_Pragma (Component_Items (Comps));
6797 while Present (Decl) loop
6798 Decl_Id := Defining_Identifier (Decl);
6799 Decl_Typ := Etype (Decl_Id);
6803 if Chars (Decl_Id) /= Name_uParent
6804 and then Needs_Finalization (Decl_Typ)
6805 and then Has_Access_Constraint (Decl_Id)
6806 and then No (Expression (Decl))
6808 Process_Component_For_Adjust (Decl);
6811 Next_Non_Pragma (Decl);
6816 -- Process all variants, if any
6819 if Present (Variant_Part (Comps)) then
6821 Var_Alts : constant List_Id := New_List;
6825 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6826 while Present (Var) loop
6829 -- when <discrete choices> =>
6830 -- <adjust statements>
6832 Append_To (Var_Alts,
6833 Make_Case_Statement_Alternative (Loc,
6835 New_Copy_List (Discrete_Choices (Var)),
6837 Process_Component_List_For_Adjust (
6838 Component_List (Var))));
6840 Next_Non_Pragma (Var);
6844 -- case V.<discriminant> is
6845 -- when <discrete choices 1> =>
6846 -- <adjust statements 1>
6848 -- when <discrete choices N> =>
6849 -- <adjust statements N>
6853 Make_Case_Statement (Loc,
6855 Make_Selected_Component (Loc,
6856 Prefix => Make_Identifier (Loc, Name_V),
6858 Make_Identifier (Loc,
6859 Chars => Chars (Name (Variant_Part (Comps))))),
6860 Alternatives => Var_Alts);
6864 -- Add the variant case statement to the list of statements
6866 if Present (Var_Case) then
6867 Append_To (Stmts, Var_Case);
6870 -- If the component list did not have any controlled components
6871 -- nor variants, return null.
6873 if Is_Empty_List (Stmts) then
6874 Append_To (Stmts, Make_Null_Statement (Loc));
6878 end Process_Component_List_For_Adjust;
6882 Bod_Stmts : List_Id := No_List;
6883 Finalizer_Decls : List_Id := No_List;
6886 -- Start of processing for Build_Adjust_Statements
6889 Finalizer_Decls := New_List;
6890 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6892 if Nkind (Typ_Def) = N_Derived_Type_Definition then
6893 Rec_Def := Record_Extension_Part (Typ_Def);
6898 -- Create an adjust sequence for all record components
6900 if Present (Component_List (Rec_Def)) then
6902 Process_Component_List_For_Adjust (Component_List (Rec_Def));
6905 -- A derived record type must adjust all inherited components. This
6906 -- action poses the following problem:
6908 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6913 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6915 -- Deep_Adjust (Obj._parent);
6920 -- Adjusting the derived type will invoke Adjust of the parent and
6921 -- then that of the derived type. This is undesirable because both
6922 -- routines may modify shared components. Only the Adjust of the
6923 -- derived type should be invoked.
6925 -- To prevent this double adjustment of shared components,
6926 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6928 -- procedure Deep_Adjust
6929 -- (Obj : in out Some_Type;
6930 -- Flag : Boolean := True)
6938 -- When Deep_Adjust is invoked for field _parent, a value of False is
6939 -- provided for the flag:
6941 -- Deep_Adjust (Obj._parent, False);
6943 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
6945 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
6950 if Needs_Finalization (Par_Typ) then
6954 Make_Selected_Component (Loc,
6955 Prefix => Make_Identifier (Loc, Name_V),
6957 Make_Identifier (Loc, Name_uParent)),
6963 -- Deep_Adjust (V._parent, False);
6966 -- when Id : others =>
6967 -- if not Raised then
6969 -- Save_Occurrence (E,
6970 -- Get_Current_Excep.all.all);
6974 if Present (Call) then
6977 if Exceptions_OK then
6979 Make_Block_Statement (Loc,
6980 Handled_Statement_Sequence =>
6981 Make_Handled_Sequence_Of_Statements (Loc,
6982 Statements => New_List (Adj_Stmt),
6983 Exception_Handlers => New_List (
6984 Build_Exception_Handler (Finalizer_Data))));
6987 Prepend_To (Bod_Stmts, Adj_Stmt);
6993 -- Adjust the object. This action must be performed last after all
6994 -- components have been adjusted.
6996 if Is_Controlled (Typ) then
7002 Proc := Find_Controlled_Prim_Op (Typ, Name_Adjust);
7011 -- if not Raised then
7013 -- Save_Occurrence (E,
7014 -- Get_Current_Excep.all.all);
7019 if Present (Proc) then
7021 Make_Procedure_Call_Statement (Loc,
7022 Name => New_Occurrence_Of (Proc, Loc),
7023 Parameter_Associations => New_List (
7024 Make_Identifier (Loc, Name_V)));
7026 if Exceptions_OK then
7028 Make_Block_Statement (Loc,
7029 Handled_Statement_Sequence =>
7030 Make_Handled_Sequence_Of_Statements (Loc,
7031 Statements => New_List (Adj_Stmt),
7032 Exception_Handlers => New_List (
7033 Build_Exception_Handler
7034 (Finalizer_Data))));
7037 Append_To (Bod_Stmts,
7038 Make_If_Statement (Loc,
7039 Condition => Make_Identifier (Loc, Name_F),
7040 Then_Statements => New_List (Adj_Stmt)));
7045 -- At this point either all adjustment statements have been generated
7046 -- or the type is not controlled.
7048 if Is_Empty_List (Bod_Stmts) then
7049 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7055 -- Abort : constant Boolean := Triggered_By_Abort;
7057 -- Abort : constant Boolean := False; -- no abort
7059 -- E : Exception_Occurrence;
7060 -- Raised : Boolean := False;
7063 -- <adjust statements>
7065 -- if Raised and then not Abort then
7066 -- Raise_From_Controlled_Operation (E);
7071 if Exceptions_OK then
7072 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7077 Make_Block_Statement (Loc,
7080 Handled_Statement_Sequence =>
7081 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7083 end Build_Adjust_Statements;
7085 -------------------------------
7086 -- Build_Finalize_Statements --
7087 -------------------------------
7089 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7090 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7093 Finalizer_Data : Finalization_Exception_Data;
7094 Last_POC_Call : Node_Id := Empty;
7096 function Process_Component_List_For_Finalize
7098 In_Variant_Part : Boolean := False) return List_Id;
7099 -- Build all necessary finalization statements for a single component
7100 -- list. The statements may include a jump circuitry if flag Is_Local
7101 -- is enabled. In_Variant_Part indicates whether this is a recursive
7104 -----------------------------------------
7105 -- Process_Component_List_For_Finalize --
7106 -----------------------------------------
7108 function Process_Component_List_For_Finalize
7110 In_Variant_Part : Boolean := False) return List_Id
7112 procedure Process_Component_For_Finalize
7117 Num_Comps : in out Nat);
7118 -- Process the declaration of a single controlled component. If
7119 -- flag Is_Local is enabled, create the corresponding label and
7120 -- jump circuitry. Alts is the list of case alternatives, Decls
7121 -- is the top level declaration list where labels are declared
7122 -- and Stmts is the list of finalization actions. Num_Comps
7123 -- denotes the current number of components needing finalization.
7125 ------------------------------------
7126 -- Process_Component_For_Finalize --
7127 ------------------------------------
7129 procedure Process_Component_For_Finalize
7134 Num_Comps : in out Nat)
7136 Id : constant Entity_Id := Defining_Identifier (Decl);
7137 Typ : constant Entity_Id := Etype (Id);
7144 Label_Id : Entity_Id;
7151 Make_Identifier (Loc,
7152 Chars => New_External_Name ('L', Num_Comps));
7153 Set_Entity (Label_Id,
7154 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7155 Label := Make_Label (Loc, Label_Id);
7158 Make_Implicit_Label_Declaration (Loc,
7159 Defining_Identifier => Entity (Label_Id),
7160 Label_Construct => Label));
7167 Make_Case_Statement_Alternative (Loc,
7168 Discrete_Choices => New_List (
7169 Make_Integer_Literal (Loc, Num_Comps)),
7171 Statements => New_List (
7172 Make_Goto_Statement (Loc,
7174 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7179 Append_To (Stmts, Label);
7181 -- Decrease the number of components to be processed.
7182 -- This action yields a new Label_Id in future calls.
7184 Num_Comps := Num_Comps - 1;
7189 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7191 -- begin -- Exception handlers allowed
7192 -- [Deep_]Finalize (V.Id);
7195 -- if not Raised then
7197 -- Save_Occurrence (E,
7198 -- Get_Current_Excep.all.all);
7205 Make_Selected_Component (Loc,
7206 Prefix => Make_Identifier (Loc, Name_V),
7207 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7210 -- Guard against a missing [Deep_]Finalize when the component
7211 -- type was not properly frozen.
7213 if Present (Fin_Call) then
7214 if Exceptions_OK then
7216 Make_Block_Statement (Loc,
7217 Handled_Statement_Sequence =>
7218 Make_Handled_Sequence_Of_Statements (Loc,
7219 Statements => New_List (Fin_Call),
7220 Exception_Handlers => New_List (
7221 Build_Exception_Handler (Finalizer_Data))));
7224 Append_To (Stmts, Fin_Call);
7226 end Process_Component_For_Finalize;
7231 Counter_Id : Entity_Id := Empty;
7233 Decl_Id : Entity_Id;
7234 Decl_Typ : Entity_Id;
7237 Jump_Block : Node_Id;
7239 Label_Id : Entity_Id;
7244 -- Start of processing for Process_Component_List_For_Finalize
7247 -- Perform an initial check, look for controlled and per-object
7248 -- constrained components.
7250 Preprocess_Components (Comps, Num_Comps, Has_POC);
7252 -- Create a state counter to service the current component list.
7253 -- This step is performed before the variants are inspected in
7254 -- order to generate the same state counter names as those from
7255 -- Build_Initialize_Statements.
7257 if Num_Comps > 0 and then Is_Local then
7258 Counter := Counter + 1;
7261 Make_Defining_Identifier (Loc,
7262 Chars => New_External_Name ('C', Counter));
7265 -- Process the component in the following order:
7267 -- 2) Per-object constrained components
7268 -- 3) Regular components
7270 -- Start with the variant parts
7273 if Present (Variant_Part (Comps)) then
7275 Var_Alts : constant List_Id := New_List;
7279 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7280 while Present (Var) loop
7283 -- when <discrete choices> =>
7284 -- <finalize statements>
7286 Append_To (Var_Alts,
7287 Make_Case_Statement_Alternative (Loc,
7289 New_Copy_List (Discrete_Choices (Var)),
7291 Process_Component_List_For_Finalize (
7292 Component_List (Var),
7293 In_Variant_Part => True)));
7295 Next_Non_Pragma (Var);
7299 -- case V.<discriminant> is
7300 -- when <discrete choices 1> =>
7301 -- <finalize statements 1>
7303 -- when <discrete choices N> =>
7304 -- <finalize statements N>
7308 Make_Case_Statement (Loc,
7310 Make_Selected_Component (Loc,
7311 Prefix => Make_Identifier (Loc, Name_V),
7313 Make_Identifier (Loc,
7314 Chars => Chars (Name (Variant_Part (Comps))))),
7315 Alternatives => Var_Alts);
7319 -- The current component list does not have a single controlled
7320 -- component, however it may contain variants. Return the case
7321 -- statement for the variants or nothing.
7323 if Num_Comps = 0 then
7324 if Present (Var_Case) then
7325 return New_List (Var_Case);
7327 return New_List (Make_Null_Statement (Loc));
7331 -- Prepare all lists
7337 -- Process all per-object constrained components in reverse order
7340 Decl := Last_Non_Pragma (Component_Items (Comps));
7341 while Present (Decl) loop
7342 Decl_Id := Defining_Identifier (Decl);
7343 Decl_Typ := Etype (Decl_Id);
7347 if Chars (Decl_Id) /= Name_uParent
7348 and then Needs_Finalization (Decl_Typ)
7349 and then Has_Access_Constraint (Decl_Id)
7350 and then No (Expression (Decl))
7352 Process_Component_For_Finalize
7353 (Decl, Alts, Decls, Stmts, Num_Comps);
7356 Prev_Non_Pragma (Decl);
7360 if not In_Variant_Part then
7361 Last_POC_Call := Last (Stmts);
7362 -- In the case of a type extension, the deep-finalize call
7363 -- for the _Parent component will be inserted here.
7366 -- Process the rest of the components in reverse order
7368 Decl := Last_Non_Pragma (Component_Items (Comps));
7369 while Present (Decl) loop
7370 Decl_Id := Defining_Identifier (Decl);
7371 Decl_Typ := Etype (Decl_Id);
7375 if Chars (Decl_Id) /= Name_uParent
7376 and then Needs_Finalization (Decl_Typ)
7378 -- Skip per-object constrained components since they were
7379 -- handled in the above step.
7381 if Has_Access_Constraint (Decl_Id)
7382 and then No (Expression (Decl))
7386 Process_Component_For_Finalize
7387 (Decl, Alts, Decls, Stmts, Num_Comps);
7391 Prev_Non_Pragma (Decl);
7396 -- LN : label; -- If Is_Local is enabled
7401 -- case CounterX is .
7411 -- <<LN>> -- If Is_Local is enabled
7413 -- [Deep_]Finalize (V.CompY);
7415 -- when Id : others =>
7416 -- if not Raised then
7418 -- Save_Occurrence (E,
7419 -- Get_Current_Excep.all.all);
7423 -- <<L0>> -- If Is_Local is enabled
7428 -- Add the declaration of default jump location L0, its
7429 -- corresponding alternative and its place in the statements.
7431 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7432 Set_Entity (Label_Id,
7433 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7434 Label := Make_Label (Loc, Label_Id);
7436 Append_To (Decls, -- declaration
7437 Make_Implicit_Label_Declaration (Loc,
7438 Defining_Identifier => Entity (Label_Id),
7439 Label_Construct => Label));
7441 Append_To (Alts, -- alternative
7442 Make_Case_Statement_Alternative (Loc,
7443 Discrete_Choices => New_List (
7444 Make_Others_Choice (Loc)),
7446 Statements => New_List (
7447 Make_Goto_Statement (Loc,
7448 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7450 Append_To (Stmts, Label); -- statement
7452 -- Create the jump block
7455 Make_Case_Statement (Loc,
7456 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7457 Alternatives => Alts));
7461 Make_Block_Statement (Loc,
7462 Declarations => Decls,
7463 Handled_Statement_Sequence =>
7464 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7466 if Present (Var_Case) then
7467 return New_List (Var_Case, Jump_Block);
7469 return New_List (Jump_Block);
7471 end Process_Component_List_For_Finalize;
7475 Bod_Stmts : List_Id := No_List;
7476 Finalizer_Decls : List_Id := No_List;
7479 -- Start of processing for Build_Finalize_Statements
7482 Finalizer_Decls := New_List;
7483 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7485 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7486 Rec_Def := Record_Extension_Part (Typ_Def);
7491 -- Create a finalization sequence for all record components
7493 if Present (Component_List (Rec_Def)) then
7495 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7498 -- A derived record type must finalize all inherited components. This
7499 -- action poses the following problem:
7501 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7506 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7508 -- Deep_Finalize (Obj._parent);
7513 -- Finalizing the derived type will invoke Finalize of the parent and
7514 -- then that of the derived type. This is undesirable because both
7515 -- routines may modify shared components. Only the Finalize of the
7516 -- derived type should be invoked.
7518 -- To prevent this double adjustment of shared components,
7519 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7521 -- procedure Deep_Finalize
7522 -- (Obj : in out Some_Type;
7523 -- Flag : Boolean := True)
7531 -- When Deep_Finalize is invoked for field _parent, a value of False
7532 -- is provided for the flag:
7534 -- Deep_Finalize (Obj._parent, False);
7536 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7538 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7543 if Needs_Finalization (Par_Typ) then
7547 Make_Selected_Component (Loc,
7548 Prefix => Make_Identifier (Loc, Name_V),
7550 Make_Identifier (Loc, Name_uParent)),
7556 -- Deep_Finalize (V._parent, False);
7559 -- when Id : others =>
7560 -- if not Raised then
7562 -- Save_Occurrence (E,
7563 -- Get_Current_Excep.all.all);
7567 if Present (Call) then
7570 if Exceptions_OK then
7572 Make_Block_Statement (Loc,
7573 Handled_Statement_Sequence =>
7574 Make_Handled_Sequence_Of_Statements (Loc,
7575 Statements => New_List (Fin_Stmt),
7576 Exception_Handlers => New_List (
7577 Build_Exception_Handler
7578 (Finalizer_Data))));
7581 -- The intended component finalization order is
7582 -- 1) POC components of extension
7583 -- 2) _Parent component
7584 -- 3) non-POC components of extension.
7586 -- With this "finalize the parent part in the middle"
7587 -- ordering, we can avoid the need for making two
7588 -- calls to the parent's subprogram in the way that
7589 -- is necessary for Init_Procs. This does have the
7590 -- peculiar (but legal) consequence that the parent's
7591 -- non-POC components are finalized before the
7592 -- non-POC extension components. This violates the
7593 -- usual "finalize in reverse declaration order"
7594 -- principle, but that's ok (see RM 7.6.1(9)).
7596 -- Last_POC_Call should be non-empty if the extension
7597 -- has at least one POC. Interactions with variant
7598 -- parts are incorrectly ignored.
7600 if Present (Last_POC_Call) then
7601 Insert_After (Last_POC_Call, Fin_Stmt);
7603 -- At this point, we could look for the common case
7604 -- where there are no POC components anywhere in
7605 -- sight (inherited or not) and, in that common case,
7606 -- call Append_To instead of Prepend_To. That would
7607 -- result in finalizing the parent part after, rather
7608 -- than before, the extension components. That might
7609 -- be more intuitive (as discussed in preceding
7610 -- comment), but it is not required.
7611 Prepend_To (Bod_Stmts, Fin_Stmt);
7618 -- Finalize the object. This action must be performed first before
7619 -- all components have been finalized.
7621 if Is_Controlled (Typ) and then not Is_Local then
7627 Proc := Find_Controlled_Prim_Op (Typ, Name_Finalize);
7636 -- if not Raised then
7638 -- Save_Occurrence (E,
7639 -- Get_Current_Excep.all.all);
7644 if Present (Proc) then
7646 Make_Procedure_Call_Statement (Loc,
7647 Name => New_Occurrence_Of (Proc, Loc),
7648 Parameter_Associations => New_List (
7649 Make_Identifier (Loc, Name_V)));
7651 if Exceptions_OK then
7653 Make_Block_Statement (Loc,
7654 Handled_Statement_Sequence =>
7655 Make_Handled_Sequence_Of_Statements (Loc,
7656 Statements => New_List (Fin_Stmt),
7657 Exception_Handlers => New_List (
7658 Build_Exception_Handler
7659 (Finalizer_Data))));
7662 Prepend_To (Bod_Stmts,
7663 Make_If_Statement (Loc,
7664 Condition => Make_Identifier (Loc, Name_F),
7665 Then_Statements => New_List (Fin_Stmt)));
7670 -- At this point either all finalization statements have been
7671 -- generated or the type is not controlled.
7673 if No (Bod_Stmts) then
7674 return New_List (Make_Null_Statement (Loc));
7678 -- Abort : constant Boolean := Triggered_By_Abort;
7680 -- Abort : constant Boolean := False; -- no abort
7682 -- E : Exception_Occurrence;
7683 -- Raised : Boolean := False;
7686 -- <finalize statements>
7688 -- if Raised and then not Abort then
7689 -- Raise_From_Controlled_Operation (E);
7694 if Exceptions_OK then
7695 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7700 Make_Block_Statement (Loc,
7703 Handled_Statement_Sequence =>
7704 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7706 end Build_Finalize_Statements;
7708 -----------------------
7709 -- Parent_Field_Type --
7710 -----------------------
7712 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
7716 Field := First_Entity (Typ);
7717 while Present (Field) loop
7718 if Chars (Field) = Name_uParent then
7719 return Etype (Field);
7722 Next_Entity (Field);
7725 -- A derived tagged type should always have a parent field
7727 raise Program_Error;
7728 end Parent_Field_Type;
7730 ---------------------------
7731 -- Preprocess_Components --
7732 ---------------------------
7734 procedure Preprocess_Components
7736 Num_Comps : out Nat;
7737 Has_POC : out Boolean)
7747 Decl := First_Non_Pragma (Component_Items (Comps));
7748 while Present (Decl) loop
7749 Id := Defining_Identifier (Decl);
7752 -- Skip field _parent
7754 if Chars (Id) /= Name_uParent
7755 and then Needs_Finalization (Typ)
7757 Num_Comps := Num_Comps + 1;
7759 if Has_Access_Constraint (Id)
7760 and then No (Expression (Decl))
7766 Next_Non_Pragma (Decl);
7768 end Preprocess_Components;
7770 -- Start of processing for Make_Deep_Record_Body
7774 when Address_Case =>
7775 return Make_Finalize_Address_Stmts (Typ);
7778 return Build_Adjust_Statements (Typ);
7780 when Finalize_Case =>
7781 return Build_Finalize_Statements (Typ);
7783 when Initialize_Case =>
7784 if Is_Controlled (Typ) then
7786 Make_Procedure_Call_Statement (Loc,
7789 (Find_Controlled_Prim_Op (Typ, Name_Initialize), Loc),
7790 Parameter_Associations => New_List (
7791 Make_Identifier (Loc, Name_V))));
7796 end Make_Deep_Record_Body;
7798 ----------------------
7799 -- Make_Final_Call --
7800 ----------------------
7802 function Make_Final_Call
7805 Skip_Self : Boolean := False) return Node_Id
7807 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7809 Prot_Typ : Entity_Id := Empty;
7810 Fin_Id : Entity_Id := Empty;
7817 -- Recover the proper type which contains [Deep_]Finalize
7819 if Is_Class_Wide_Type (Typ) then
7820 Utyp := Root_Type (Typ);
7823 elsif Is_Concurrent_Type (Typ) then
7824 Utyp := Corresponding_Record_Type (Typ);
7826 Ref := Convert_Concurrent (Ref, Typ);
7828 elsif Is_Private_Type (Typ)
7829 and then Present (Underlying_Type (Typ))
7830 and then Is_Concurrent_Type (Underlying_Type (Typ))
7832 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
7834 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
7841 Utyp := Underlying_Type (Base_Type (Utyp));
7842 Set_Assignment_OK (Ref);
7844 -- Deal with untagged derivation of private views. If the parent type
7845 -- is a protected type, Deep_Finalize is found on the corresponding
7846 -- record of the ancestor.
7848 if Is_Untagged_Derivation (Typ) then
7849 if Is_Protected_Type (Typ) then
7850 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7852 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7854 if Is_Protected_Type (Utyp) then
7855 Utyp := Corresponding_Record_Type (Utyp);
7859 Ref := Unchecked_Convert_To (Utyp, Ref);
7860 Set_Assignment_OK (Ref);
7863 -- Deal with derived private types which do not inherit primitives from
7864 -- their parents. In this case, [Deep_]Finalize can be found in the full
7865 -- view of the parent type.
7868 and then Is_Tagged_Type (Utyp)
7869 and then Is_Derived_Type (Utyp)
7870 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
7871 and then Is_Private_Type (Etype (Utyp))
7872 and then Present (Full_View (Etype (Utyp)))
7874 Utyp := Full_View (Etype (Utyp));
7875 Ref := Unchecked_Convert_To (Utyp, Ref);
7876 Set_Assignment_OK (Ref);
7879 -- When dealing with the completion of a private type, use the base type
7882 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
7883 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
7885 Utyp := Base_Type (Utyp);
7886 Ref := Unchecked_Convert_To (Utyp, Ref);
7887 Set_Assignment_OK (Ref);
7890 -- Detect if Typ is a protected type or an expanded protected type and
7891 -- store the relevant type within Prot_Typ for later processing.
7893 if Is_Protected_Type (Typ) then
7896 elsif Ekind (Typ) = E_Record_Type
7897 and then Present (Corresponding_Concurrent_Type (Typ))
7898 and then Is_Protected_Type (Corresponding_Concurrent_Type (Typ))
7900 Prot_Typ := Corresponding_Concurrent_Type (Typ);
7903 -- The underlying type may not be present due to a missing full view. In
7904 -- this case freezing did not take place and there is no [Deep_]Finalize
7905 -- primitive to call.
7910 elsif Skip_Self then
7911 if Has_Controlled_Component (Utyp) then
7912 if Is_Tagged_Type (Utyp) then
7913 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7915 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7919 -- Class-wide types, interfaces and types with controlled components
7921 elsif Is_Class_Wide_Type (Typ)
7922 or else Is_Interface (Typ)
7923 or else Has_Controlled_Component (Utyp)
7925 if Is_Tagged_Type (Utyp) then
7926 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7928 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7931 -- Derivations from [Limited_]Controlled
7933 elsif Is_Controlled (Utyp) then
7934 Fin_Id := Find_Controlled_Prim_Op (Utyp, Name_Finalize);
7938 elsif Is_Tagged_Type (Utyp) then
7939 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7941 -- Protected types: these also require finalization even though they
7942 -- are not marked controlled explicitly.
7944 elsif Present (Prot_Typ) then
7945 -- Protected objects do not need to be finalized on restricted
7948 if Restricted_Profile then
7951 -- ??? Only handle the simple case for now. Will not support a record
7952 -- or array containing protected objects.
7954 elsif Is_Simple_Protected_Type (Prot_Typ) then
7955 Fin_Id := RTE (RE_Finalize_Protection);
7957 raise Program_Error;
7961 raise Program_Error;
7964 if Present (Fin_Id) then
7966 -- When finalizing a class-wide object, do not convert to the root
7967 -- type in order to produce a dispatching call.
7969 if Is_Class_Wide_Type (Typ) then
7972 -- Ensure that a finalization routine is at least decorated in order
7973 -- to inspect the object parameter.
7975 elsif Analyzed (Fin_Id)
7976 or else Ekind (Fin_Id) = E_Procedure
7978 -- In certain cases, such as the creation of Stream_Read, the
7979 -- visible entity of the type is its full view. Since Stream_Read
7980 -- will have to create an object of type Typ, the local object
7981 -- will be finalzed by the scope finalizer generated later on. The
7982 -- object parameter of Deep_Finalize will always use the private
7983 -- view of the type. To avoid such a clash between a private and a
7984 -- full view, perform an unchecked conversion of the object
7985 -- reference to the private view.
7988 Formal_Typ : constant Entity_Id :=
7989 Etype (First_Formal (Fin_Id));
7991 if Is_Private_Type (Formal_Typ)
7992 and then Present (Full_View (Formal_Typ))
7993 and then Full_View (Formal_Typ) = Utyp
7995 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
7999 Ref := Convert_View (Fin_Id, Ref, Typ);
8006 Skip_Self => Skip_Self);
8008 pragma Assert (Serious_Errors_Detected > 0
8009 or else not Has_Controlled_Component (Utyp));
8012 end Make_Final_Call;
8014 --------------------------------
8015 -- Make_Finalize_Address_Body --
8016 --------------------------------
8018 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8019 Is_Task : constant Boolean :=
8020 Ekind (Typ) = E_Record_Type
8021 and then Is_Concurrent_Record_Type (Typ)
8022 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8024 Loc : constant Source_Ptr := Sloc (Typ);
8025 Proc_Id : Entity_Id;
8029 -- The corresponding records of task types are not controlled by design.
8030 -- For the sake of completeness, create an empty Finalize_Address to be
8031 -- used in task class-wide allocations.
8036 -- Nothing to do if the type does not need finalization or already has
8037 -- a TSS entry for Finalize_Address. Skip class-wide subtypes that do
8038 -- not come from source, as they are usually generated for completeness
8039 -- and need no Finalize_Address.
8041 elsif not Needs_Finalization (Typ)
8042 or else Present (TSS (Typ, TSS_Finalize_Address))
8044 (Is_Class_Wide_Type (Typ)
8045 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8046 and then not Comes_From_Source (Root_Type (Typ)))
8051 -- Do not generate Finalize_Address routine for CodePeer
8053 if CodePeer_Mode then
8058 Make_Defining_Identifier (Loc,
8059 Make_TSS_Name (Typ, TSS_Finalize_Address));
8063 -- procedure <Typ>FD (V : System.Address) is
8065 -- null; -- for tasks
8067 -- declare -- for all other types
8068 -- type Pnn is access all Typ;
8069 -- for Pnn'Storage_Size use 0;
8071 -- [Deep_]Finalize (Pnn (V).all);
8076 Stmts := New_List (Make_Null_Statement (Loc));
8078 Stmts := Make_Finalize_Address_Stmts (Typ);
8082 Make_Subprogram_Body (Loc,
8084 Make_Procedure_Specification (Loc,
8085 Defining_Unit_Name => Proc_Id,
8087 Parameter_Specifications => New_List (
8088 Make_Parameter_Specification (Loc,
8089 Defining_Identifier =>
8090 Make_Defining_Identifier (Loc, Name_V),
8092 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8094 Declarations => No_List,
8096 Handled_Statement_Sequence =>
8097 Make_Handled_Sequence_Of_Statements (Loc,
8098 Statements => Stmts)));
8100 -- If the type has relaxed semantics for finalization, the indirect
8101 -- calls to Finalize_Address may be turned into direct ones and, in
8102 -- this case, inlining them is generally profitable.
8104 if Has_Relaxed_Finalization (Typ) then
8105 Set_Is_Inlined (Proc_Id);
8108 Set_TSS (Typ, Proc_Id);
8109 end Make_Finalize_Address_Body;
8111 ---------------------------------
8112 -- Make_Finalize_Address_Stmts --
8113 ---------------------------------
8115 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8116 Loc : constant Source_Ptr := Sloc (Typ);
8119 Desig_Typ : Entity_Id;
8120 Fin_Block : Node_Id;
8123 Ptr_Typ : Entity_Id;
8126 if Is_Array_Type (Typ) then
8127 if Is_Constrained (First_Subtype (Typ)) then
8128 Desig_Typ := First_Subtype (Typ);
8130 Desig_Typ := Base_Type (Typ);
8133 -- Class-wide types of constrained root types
8135 elsif Is_Class_Wide_Type (Typ)
8136 and then Has_Discriminants (Root_Type (Typ))
8138 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8141 Parent_Typ : Entity_Id;
8142 Parent_Utyp : Entity_Id;
8145 -- Climb the parent type chain looking for a non-constrained type
8147 Parent_Typ := Root_Type (Typ);
8148 while Parent_Typ /= Etype (Parent_Typ)
8149 and then Has_Discriminants (Parent_Typ)
8151 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8153 Parent_Typ := Etype (Parent_Typ);
8156 -- Handle views created for tagged types with unknown
8159 if Is_Underlying_Record_View (Parent_Typ) then
8160 Parent_Typ := Underlying_Record_View (Parent_Typ);
8163 Parent_Utyp := Underlying_Type (Parent_Typ);
8165 -- Handle views created for a synchronized private extension with
8166 -- known, non-defaulted discriminants. In that case, parent_typ
8167 -- will be the private extension, as it is the first "non
8168 -- -constrained" type in the parent chain. Unfortunately, the
8169 -- underlying type, being a protected or task type, is not the
8170 -- "real" type needing finalization. Rather, the "corresponding
8171 -- record type" should be the designated type here. In fact, TSS
8172 -- finalizer generation is specifically skipped for the nominal
8173 -- class-wide type of (the full view of) a concurrent type (see
8174 -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate
8175 -- the underlying record (Tprot_typeVC), we will end up trying to
8176 -- dispatch to prot_typeVDF from an incorrectly designated
8177 -- Tprot_typeC, which is, of course, not actually a member of
8178 -- prot_typeV'Class, and thus incompatible.
8180 if Ekind (Parent_Utyp) in Concurrent_Kind
8181 and then Present (Corresponding_Record_Type (Parent_Utyp))
8183 Parent_Utyp := Corresponding_Record_Type (Parent_Utyp);
8186 Desig_Typ := Class_Wide_Type (Parent_Utyp);
8196 -- type Ptr_Typ is access all Typ;
8197 -- for Ptr_Typ'Storage_Size use 0;
8199 Ptr_Typ := Make_Temporary (Loc, 'P');
8202 Make_Full_Type_Declaration (Loc,
8203 Defining_Identifier => Ptr_Typ,
8205 Make_Access_To_Object_Definition (Loc,
8206 All_Present => True,
8207 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8209 Make_Attribute_Definition_Clause (Loc,
8210 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8211 Chars => Name_Storage_Size,
8212 Expression => Make_Integer_Literal (Loc, 0)));
8214 Obj_Expr := Make_Identifier (Loc, Name_V);
8216 -- Unconstrained arrays require special processing in order to retrieve
8217 -- the elements. To achieve this, we have to skip the dope vector which
8218 -- lays in front of the elements and then use a thin pointer to perform
8219 -- the address-to-access conversion.
8221 if Is_Array_Type (Typ)
8222 and then not Is_Constrained (First_Subtype (Typ))
8225 Dope_Id : Entity_Id;
8228 -- Ensure that Ptr_Typ is a thin pointer; generate:
8229 -- for Ptr_Typ'Size use System.Address'Size;
8232 Make_Attribute_Definition_Clause (Loc,
8233 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8236 Make_Integer_Literal (Loc, System_Address_Size)));
8239 -- Dnn : constant Storage_Offset :=
8240 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8242 Dope_Id := Make_Temporary (Loc, 'D');
8245 Make_Object_Declaration (Loc,
8246 Defining_Identifier => Dope_Id,
8247 Constant_Present => True,
8248 Object_Definition =>
8249 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8251 Make_Op_Divide (Loc,
8253 Make_Attribute_Reference (Loc,
8254 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8255 Attribute_Name => Name_Descriptor_Size),
8257 Make_Integer_Literal (Loc, System_Storage_Unit))));
8259 -- Shift the address from the start of the dope vector to the
8260 -- start of the elements:
8265 Make_Function_Call (Loc,
8267 Make_Expanded_Name (Loc,
8268 Chars => Name_Op_Add,
8271 (RTU_Entity (System_Storage_Elements), Loc),
8273 Make_Identifier (Loc, Name_Op_Add)),
8274 Parameter_Associations => New_List (
8276 New_Occurrence_Of (Dope_Id, Loc)));
8283 Make_Explicit_Dereference (Loc,
8284 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8287 if Present (Fin_Call) then
8289 Make_Block_Statement (Loc,
8290 Declarations => Decls,
8291 Handled_Statement_Sequence =>
8292 Make_Handled_Sequence_Of_Statements (Loc,
8293 Statements => New_List (Fin_Call)));
8295 -- Otherwise previous errors or a missing full view may prevent the
8296 -- proper freezing of the designated type. If this is the case, there
8297 -- is no [Deep_]Finalize primitive to call.
8300 Fin_Block := Make_Null_Statement (Loc);
8303 return New_List (Fin_Block);
8304 end Make_Finalize_Address_Stmts;
8306 ---------------------------------
8307 -- Make_Finalize_Call_For_Node --
8308 ---------------------------------
8310 function Make_Finalize_Call_For_Node
8312 Node : Entity_Id) return Node_Id
8314 Fin_Id : constant Entity_Id := Finalize_Address_For_Node (Node);
8320 -- Finalize_Address is not generated in CodePeer mode because the
8321 -- body contains address arithmetic. So we don't want to generate
8322 -- the call in this case.
8324 if CodePeer_Mode then
8325 return Make_Null_Statement (Loc);
8328 -- The Finalize_Address primitive may be missing when the Master_Node
8329 -- is written down in the source code for testing purposes.
8331 if Present (Fin_Id) then
8333 Make_Attribute_Reference (Loc,
8334 Prefix => New_Occurrence_Of (Fin_Id, Loc),
8335 Attribute_Name => Name_Unrestricted_Access);
8339 Make_Selected_Component (Loc,
8340 Prefix => New_Occurrence_Of (Node, Loc),
8341 Selector_Name => Make_Identifier (Loc, Name_Finalize_Address));
8345 Make_Procedure_Call_Statement (Loc,
8347 New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
8348 Parameter_Associations => New_List (
8349 New_Occurrence_Of (Node, Loc),
8352 -- Present Finalize_Address procedure to the back end so that it can
8353 -- inline the call to the procedure made by Finalize_Object.
8355 if Present (Fin_Id) and then Is_Inlined (Fin_Id) then
8356 Add_Inlined_Body (Fin_Id, Fin_Call);
8360 end Make_Finalize_Call_For_Node;
8362 -------------------------------------
8363 -- Make_Handler_For_Ctrl_Operation --
8364 -------------------------------------
8368 -- when E : others =>
8369 -- Raise_From_Controlled_Operation (E);
8374 -- raise Program_Error [finalize raised exception];
8376 -- depending on whether Raise_From_Controlled_Operation is available
8378 function Make_Handler_For_Ctrl_Operation
8379 (Loc : Source_Ptr) return Node_Id
8382 -- Choice parameter (for the first case above)
8384 Raise_Node : Node_Id;
8385 -- Procedure call or raise statement
8388 -- Standard run-time: add choice parameter E and pass it to
8389 -- Raise_From_Controlled_Operation so that the original exception
8390 -- name and message can be recorded in the exception message for
8393 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8394 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8396 Make_Procedure_Call_Statement (Loc,
8399 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8400 Parameter_Associations => New_List (
8401 New_Occurrence_Of (E_Occ, Loc)));
8403 -- Restricted run-time: exception messages are not supported
8408 Make_Raise_Program_Error (Loc,
8409 Reason => PE_Finalize_Raised_Exception);
8413 Make_Implicit_Exception_Handler (Loc,
8414 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8415 Choice_Parameter => E_Occ,
8416 Statements => New_List (Raise_Node));
8417 end Make_Handler_For_Ctrl_Operation;
8419 --------------------
8420 -- Make_Init_Call --
8421 --------------------
8423 function Make_Init_Call
8425 Typ : Entity_Id) return Node_Id
8427 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8436 -- Deal with the type and object reference. Depending on the context, an
8437 -- object reference may need several conversions.
8439 if Is_Concurrent_Type (Typ) then
8441 Utyp := Corresponding_Record_Type (Typ);
8442 Ref := Convert_Concurrent (Ref, Typ);
8444 elsif Is_Private_Type (Typ)
8445 and then Present (Full_View (Typ))
8446 and then Is_Concurrent_Type (Underlying_Type (Typ))
8449 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8450 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8457 Utyp := Underlying_Type (Base_Type (Utyp));
8458 Set_Assignment_OK (Ref);
8460 -- Deal with untagged derivation of private views
8462 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8463 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8464 Ref := Unchecked_Convert_To (Utyp, Ref);
8466 -- The following is to prevent problems with UC see 1.156 RH ???
8468 Set_Assignment_OK (Ref);
8471 -- If the underlying_type is a subtype, then we are dealing with the
8472 -- completion of a private type. We need to access the base type and
8473 -- generate a conversion to it.
8475 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8476 pragma Assert (Is_Private_Type (Typ));
8477 Utyp := Base_Type (Utyp);
8478 Ref := Unchecked_Convert_To (Utyp, Ref);
8481 -- The underlying type may not be present due to a missing full view.
8482 -- In this case freezing did not take place and there is no suitable
8483 -- [Deep_]Initialize primitive to call.
8484 -- If Typ is protected then no additional processing is needed either.
8487 or else Is_Protected_Type (Typ)
8492 -- Select the appropriate version of initialize
8494 if Has_Controlled_Component (Utyp) then
8495 Proc := TSS (Utyp, TSS_Deep_Initialize);
8496 elsif Is_Mutably_Tagged_Type (Utyp) then
8497 Proc := Find_Controlled_Prim_Op (Etype (Utyp), Name_Initialize);
8498 Check_Visibly_Controlled (Initialize_Case, Etype (Typ), Proc, Ref);
8500 Proc := Find_Controlled_Prim_Op (Utyp, Name_Initialize);
8501 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8504 -- If initialization procedure for an array of controlled objects is
8505 -- trivial, do not generate a useless call to it.
8506 -- The initialization procedure may be missing altogether in the case
8507 -- of a derived container whose components have trivial initialization.
8510 or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8512 (not Comes_From_Source (Proc)
8513 and then Present (Alias (Proc))
8514 and then Is_Trivial_Subprogram (Alias (Proc)))
8519 -- The object reference may need another conversion depending on the
8520 -- type of the formal and that of the actual.
8522 Ref := Convert_View (Proc, Ref, Typ);
8525 -- [Deep_]Initialize (Ref);
8528 Make_Procedure_Call_Statement (Loc,
8529 Name => New_Occurrence_Of (Proc, Loc),
8530 Parameter_Associations => New_List (Ref));
8533 ------------------------------
8534 -- Make_Local_Deep_Finalize --
8535 ------------------------------
8537 function Make_Local_Deep_Finalize
8539 Nam : Entity_Id) return Node_Id
8541 Loc : constant Source_Ptr := Sloc (Typ);
8545 Formals := New_List (
8549 Make_Parameter_Specification (Loc,
8550 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8552 Out_Present => True,
8553 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8555 -- F : Boolean := True
8557 Make_Parameter_Specification (Loc,
8558 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8559 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8560 Expression => New_Occurrence_Of (Standard_True, Loc)));
8562 -- Add the necessary number of counters to represent the initialization
8563 -- state of an object.
8566 Make_Subprogram_Body (Loc,
8568 Make_Procedure_Specification (Loc,
8569 Defining_Unit_Name => Nam,
8570 Parameter_Specifications => Formals),
8572 Declarations => No_List,
8574 Handled_Statement_Sequence =>
8575 Make_Handled_Sequence_Of_Statements (Loc,
8576 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8577 end Make_Local_Deep_Finalize;
8579 ----------------------------------
8580 -- Make_Master_Node_Declaration --
8581 ----------------------------------
8583 function Make_Master_Node_Declaration
8585 Master_Node : Entity_Id;
8586 Obj : Entity_Id) return Node_Id
8589 Set_Finalization_Master_Node (Obj, Master_Node);
8592 Make_Object_Declaration (Loc,
8593 Defining_Identifier => Master_Node,
8594 Aliased_Present => True,
8595 Object_Definition =>
8596 New_Occurrence_Of (RTE (RE_Master_Node), Loc));
8597 end Make_Master_Node_Declaration;
8599 ----------------------------------------
8600 -- Make_Suppress_Object_Finalize_Call --
8601 ----------------------------------------
8603 function Make_Suppress_Object_Finalize_Call
8605 Obj : Entity_Id) return Node_Id
8607 Obj_Decl : constant Node_Id := Declaration_Node (Obj);
8609 Master_Node_Decl : Node_Id;
8610 Master_Node_Id : Entity_Id;
8613 -- Create the declaration of the Master_Node for the object and
8614 -- insert it before the declaration of the object itself.
8616 if Present (Finalization_Master_Node (Obj)) then
8617 Master_Node_Id := Finalization_Master_Node (Obj);
8620 Master_Node_Id := Make_Temporary (Loc, 'N');
8622 Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj);
8623 Insert_Before_And_Analyze (Obj_Decl, Master_Node_Decl);
8625 -- Generate the attachment of the object to the Master_Node
8627 Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id);
8629 -- Mark the object to avoid double finalization
8631 Set_Is_Ignored_For_Finalization (Obj);
8635 Make_Procedure_Call_Statement (Loc,
8637 New_Occurrence_Of (RTE (RE_Suppress_Object_Finalize_At_End), Loc),
8638 Parameter_Associations => New_List (
8639 New_Occurrence_Of (Master_Node_Id, Loc)));
8640 end Make_Suppress_Object_Finalize_Call;
8642 --------------------------
8643 -- Make_Transient_Block --
8644 --------------------------
8646 function Make_Transient_Block
8649 Par : Node_Id) return Node_Id
8651 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
8652 -- Determine whether scoping entity Id manages the secondary stack
8654 function Within_Loop_Statement (N : Node_Id) return Boolean;
8655 -- Return True when N appears within a loop and no block is containing N
8657 -----------------------
8658 -- Manages_Sec_Stack --
8659 -----------------------
8661 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
8665 -- An exception handler with a choice parameter utilizes a dummy
8666 -- block to provide a declarative region. Such a block should not
8667 -- be considered because it never manifests in the tree and can
8668 -- never release the secondary stack.
8672 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
8679 return Uses_Sec_Stack (Id);
8684 end Manages_Sec_Stack;
8686 ---------------------------
8687 -- Within_Loop_Statement --
8688 ---------------------------
8690 function Within_Loop_Statement (N : Node_Id) return Boolean is
8691 Par : Node_Id := Parent (N);
8694 while Nkind (Par) not in
8695 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
8696 N_Package_Specification | N_Proper_Body
8698 pragma Assert (Present (Par));
8699 Par := Parent (Par);
8702 return Nkind (Par) = N_Loop_Statement;
8703 end Within_Loop_Statement;
8707 Decls : constant List_Id := New_List;
8708 Instrs : constant List_Id := New_List (Action);
8709 Trans_Id : constant Entity_Id := Current_Scope;
8715 -- Start of processing for Make_Transient_Block
8718 -- Even though the transient block is tasked with managing the secondary
8719 -- stack, the block may forgo this functionality depending on how the
8720 -- secondary stack is managed by enclosing scopes.
8722 if Manages_Sec_Stack (Trans_Id) then
8724 -- Determine whether an enclosing scope already manages the secondary
8727 Scop := Scope (Trans_Id);
8728 while Present (Scop) loop
8730 -- It should not be possible to reach Standard without hitting one
8731 -- of the other cases first unless Standard was manually pushed.
8733 if Scop = Standard_Standard then
8736 -- The transient block is within a function which returns on the
8737 -- secondary stack. Take a conservative approach and assume that
8738 -- the value on the secondary stack is part of the result. Note
8739 -- that it is not possible to detect this dependency without flow
8740 -- analysis which the compiler does not have. Letting the object
8741 -- live longer than the transient block will not leak any memory
8742 -- because the caller will reclaim the total storage used by the
8745 elsif Ekind (Scop) = E_Function
8746 and then Sec_Stack_Needed_For_Return (Scop)
8748 Set_Uses_Sec_Stack (Trans_Id, False);
8751 -- The transient block must manage the secondary stack when the
8752 -- block appears within a loop in order to reclaim the memory at
8755 elsif Ekind (Scop) = E_Loop then
8758 -- Ditto when the block appears without a block that does not
8759 -- manage the secondary stack and is located within a loop.
8761 elsif Ekind (Scop) = E_Block
8762 and then not Manages_Sec_Stack (Scop)
8763 and then Present (Block_Node (Scop))
8764 and then Within_Loop_Statement (Block_Node (Scop))
8768 -- The transient block does not need to manage the secondary stack
8769 -- when there is an enclosing construct which already does that.
8770 -- This optimization saves on SS_Mark and SS_Release calls but may
8771 -- allow objects to live a little longer than required.
8773 -- The transient block must manage the secondary stack when switch
8774 -- -gnatd.s (strict management) is in effect.
8776 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
8777 Set_Uses_Sec_Stack (Trans_Id, False);
8780 -- Prevent the search from going too far because transient blocks
8781 -- are bounded by packages and subprogram scopes.
8783 elsif Ekind (Scop) in E_Entry
8793 Scop := Scope (Scop);
8797 -- Create the transient block. Set the parent now since the block itself
8798 -- is not part of the tree. The current scope is the E_Block entity that
8799 -- has been pushed by Establish_Transient_Scope.
8801 pragma Assert (Ekind (Trans_Id) = E_Block);
8804 Make_Block_Statement (Loc,
8805 Identifier => New_Occurrence_Of (Trans_Id, Loc),
8806 Declarations => Decls,
8807 Handled_Statement_Sequence =>
8808 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
8809 Has_Created_Identifier => True);
8810 Set_Parent (Block, Par);
8812 -- Insert actions stuck in the transient scopes as well as all freezing
8813 -- nodes needed by those actions. Do not insert cleanup actions here,
8814 -- they will be transferred to the newly created block.
8816 Insert_Actions_In_Scope_Around
8817 (Action, Clean => False, Manage_SS => False);
8819 Insert := Prev (Action);
8821 if Present (Insert) then
8822 Freeze_All (First_Entity (Trans_Id), Insert);
8825 -- Transfer cleanup actions to the newly created block
8828 Cleanup_Actions : List_Id
8829 renames Scope_Stack.Table (Scope_Stack.Last).
8830 Actions_To_Be_Wrapped (Cleanup);
8832 Set_Cleanup_Actions (Block, Cleanup_Actions);
8833 Cleanup_Actions := No_List;
8836 -- When the transient scope was established, we pushed the entry for the
8837 -- transient scope onto the scope stack, so that the scope was active
8838 -- for the installation of finalizable entities etc. Now we must remove
8839 -- this entry, since we have constructed a proper block.
8844 end Make_Transient_Block;
8846 ------------------------
8847 -- Node_To_Be_Wrapped --
8848 ------------------------
8850 function Node_To_Be_Wrapped return Node_Id is
8852 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
8853 end Node_To_Be_Wrapped;
8855 ----------------------------
8856 -- Store_Actions_In_Scope --
8857 ----------------------------
8859 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
8860 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
8861 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
8864 if Is_Empty_List (Actions) then
8867 if Is_List_Member (SE.Node_To_Be_Wrapped) then
8868 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
8870 Set_Parent (L, SE.Node_To_Be_Wrapped);
8875 elsif AK = Before then
8876 Insert_List_After_And_Analyze (Last (Actions), L);
8879 Insert_List_Before_And_Analyze (First (Actions), L);
8881 end Store_Actions_In_Scope;
8883 ----------------------------------
8884 -- Store_After_Actions_In_Scope --
8885 ----------------------------------
8887 procedure Store_After_Actions_In_Scope (L : List_Id) is
8889 Store_Actions_In_Scope (After, L);
8890 end Store_After_Actions_In_Scope;
8892 -----------------------------------
8893 -- Store_Before_Actions_In_Scope --
8894 -----------------------------------
8896 procedure Store_Before_Actions_In_Scope (L : List_Id) is
8898 Store_Actions_In_Scope (Before, L);
8899 end Store_Before_Actions_In_Scope;
8901 -----------------------------------
8902 -- Store_Cleanup_Actions_In_Scope --
8903 -----------------------------------
8905 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
8907 Store_Actions_In_Scope (Cleanup, L);
8908 end Store_Cleanup_Actions_In_Scope;
8914 procedure Unnest_Block (Decl : Node_Id) is
8915 Loc : constant Source_Ptr := Sloc (Decl);
8917 Local_Body : Node_Id;
8918 Local_Call : Node_Id;
8919 Local_Proc : Entity_Id;
8920 Local_Scop : Entity_Id;
8923 Local_Scop := Entity (Identifier (Decl));
8924 Ent := First_Entity (Local_Scop);
8926 Local_Proc := Make_Temporary (Loc, 'P');
8929 Make_Subprogram_Body (Loc,
8931 Make_Procedure_Specification (Loc,
8932 Defining_Unit_Name => Local_Proc),
8933 Declarations => Declarations (Decl),
8934 Handled_Statement_Sequence =>
8935 Handled_Statement_Sequence (Decl),
8936 At_End_Proc => New_Copy_Tree (At_End_Proc (Decl)));
8938 -- Handlers in the block may contain nested subprograms that require
8941 Check_Unnesting_In_Handlers (Local_Body);
8943 Rewrite (Decl, Local_Body);
8945 Set_Has_Nested_Subprogram (Local_Proc);
8948 Make_Procedure_Call_Statement (Loc,
8949 Name => New_Occurrence_Of (Local_Proc, Loc));
8951 Insert_After (Decl, Local_Call);
8952 Analyze (Local_Call);
8954 -- The new subprogram has the same scope as the original block
8956 Set_Scope (Local_Proc, Scope (Local_Scop));
8958 -- And the entity list of the new procedure is that of the block
8960 Set_First_Entity (Local_Proc, Ent);
8962 -- Reset the scopes of all the entities to the new procedure
8964 while Present (Ent) loop
8965 Set_Scope (Ent, Local_Proc);
8970 -------------------------
8971 -- Unnest_If_Statement --
8972 -------------------------
8974 procedure Unnest_If_Statement (If_Stmt : Node_Id) is
8976 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id);
8977 -- A list of statements (that may be a list associated with a then,
8978 -- elsif, or else part of an if-statement) is traversed at the top
8979 -- level to determine whether it contains a subprogram body, and if so,
8980 -- the statements will be replaced with a new procedure body containing
8981 -- the statements followed by a call to the procedure. The individual
8982 -- statements may also be blocks, loops, or other if statements that
8983 -- themselves may require contain nested subprograms needing unnesting.
8985 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is
8986 Subp_Found : Boolean := False;
8989 if Is_Empty_List (Stmts) then
8994 Stmt : Node_Id := First (Stmts);
8996 while Present (Stmt) loop
8997 if Nkind (Stmt) = N_Subprogram_Body then
9006 -- The statements themselves may be blocks, loops, etc. that in turn
9007 -- contain nested subprograms requiring an unnesting transformation.
9008 -- We perform this traversal after looking for subprogram bodies, to
9009 -- avoid considering procedures created for one of those statements
9010 -- (such as a block rewritten as a procedure) as a nested subprogram
9011 -- of the statement list (which could result in an unneeded wrapper
9014 Check_Unnesting_In_Decls_Or_Stmts (Stmts);
9016 -- If there was a top-level subprogram body in the statement list,
9017 -- then perform an unnesting transformation on the list by replacing
9018 -- the statements with a wrapper procedure body containing the
9019 -- original statements followed by a call to that procedure.
9022 Unnest_Statement_List (Stmts);
9024 end Check_Stmts_For_Subp_Unnesting;
9028 Then_Stmts : List_Id := Then_Statements (If_Stmt);
9029 Else_Stmts : List_Id := Else_Statements (If_Stmt);
9031 -- Start of processing for Unnest_If_Statement
9034 Check_Stmts_For_Subp_Unnesting (Then_Stmts);
9035 Set_Then_Statements (If_Stmt, Then_Stmts);
9037 if not Is_Empty_List (Elsif_Parts (If_Stmt)) then
9039 Elsif_Part : Node_Id :=
9040 First (Elsif_Parts (If_Stmt));
9041 Elsif_Stmts : List_Id;
9043 while Present (Elsif_Part) loop
9044 Elsif_Stmts := Then_Statements (Elsif_Part);
9046 Check_Stmts_For_Subp_Unnesting (Elsif_Stmts);
9047 Set_Then_Statements (Elsif_Part, Elsif_Stmts);
9054 Check_Stmts_For_Subp_Unnesting (Else_Stmts);
9055 Set_Else_Statements (If_Stmt, Else_Stmts);
9056 end Unnest_If_Statement;
9062 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
9064 procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id);
9065 -- This procedure fixes the scope for 2 identified cases of incorrect
9066 -- scope information.
9068 -- 1) The loops created by the compiler for array aggregates can have
9069 -- nested finalization procedure when the type of the array components
9070 -- needs finalization. It has the following form:
9072 -- for J4b in 10 .. 12 loop
9074 -- procedure __finalizer;
9076 -- procedure __finalizer is
9080 -- obj (J4b) := ...;
9082 -- When the compiler creates the N_Block_Statement, it sets its scope to
9083 -- the outer scope (the one containing the loop).
9085 -- The Unnest_Loop procedure moves the N_Loop_Statement inside a new
9086 -- procedure and correctly sets the scopes for both the new procedure
9087 -- and the loop entity. The inner block scope is not modified and this
9088 -- leaves the Tree in an incoherent state (i.e. the inner procedure must
9089 -- have its enclosing procedure in its scope ancestries).
9091 -- 2) The second case happens when an object declaration is created
9092 -- within a loop used to initialize the 'others' components of an
9093 -- aggregate that is nested within a transient scope. When the transient
9094 -- scope is removed, the object scope is set to the outer scope. For
9099 -- L98s : for J90s in 2 .. 19 loop
9101 -- R92s : aliased some_type;
9104 -- The loop L98s was initially wrapped in a transient scope B72s and
9105 -- R92s was nested within it. Then the transient scope is removed and
9106 -- the scope of R92s is set to 'pack'. And finally, when the unnester
9107 -- moves the loop body in a new procedure, R92s's scope is still left
9110 -- This procedure finds the two previous patterns and fixes the scope
9113 -- Another (better) fix would be to have the block scope set to be the
9114 -- loop entity earlier (when the block is created or when the loop gets
9115 -- an actual entity set). But unfortunately this proved harder to
9118 procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id) is
9120 Loop_Or_Block_Ent : Entity_Id;
9121 Ent_To_Fix : Entity_Id;
9122 Decl : Node_Id := Empty;
9124 pragma Assert (Nkind (Loop_Or_Block) in
9125 N_Loop_Statement | N_Block_Statement);
9127 Loop_Or_Block_Ent := Entity (Identifier (Loop_Or_Block));
9128 if Nkind (Loop_Or_Block) = N_Loop_Statement then
9129 Stmt := First (Statements (Loop_Or_Block));
9130 else -- N_Block_Statement
9132 (Statements (Handled_Statement_Sequence (Loop_Or_Block)));
9133 Decl := First (Declarations (Loop_Or_Block));
9136 -- Fix scopes for any object declaration found in the block
9137 while Present (Decl) loop
9138 if Nkind (Decl) = N_Object_Declaration then
9139 Ent_To_Fix := Defining_Identifier (Decl);
9140 Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent);
9145 while Present (Stmt) loop
9146 if Nkind (Stmt) = N_Block_Statement
9147 and then Is_Abort_Block (Stmt)
9149 Ent_To_Fix := Entity (Identifier (Stmt));
9150 Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent);
9151 elsif Nkind (Stmt) in N_Block_Statement | N_Loop_Statement
9153 Fixup_Inner_Scopes (Stmt);
9157 end Fixup_Inner_Scopes;
9159 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
9161 Local_Body : Node_Id;
9162 Local_Call : Node_Id;
9163 Loop_Ent : Entity_Id;
9164 Local_Proc : Entity_Id;
9165 Loop_Copy : constant Node_Id :=
9166 Relocate_Node (Loop_Stmt);
9168 Loop_Ent := Entity (Identifier (Loop_Stmt));
9169 Ent := First_Entity (Loop_Ent);
9171 Local_Proc := Make_Temporary (Loc, 'P');
9174 Make_Subprogram_Body (Loc,
9176 Make_Procedure_Specification (Loc,
9177 Defining_Unit_Name => Local_Proc),
9178 Declarations => Empty_List,
9179 Handled_Statement_Sequence =>
9180 Make_Handled_Sequence_Of_Statements (Loc,
9181 Statements => New_List (Loop_Copy)));
9183 Rewrite (Loop_Stmt, Local_Body);
9184 Analyze (Loop_Stmt);
9186 Set_Has_Nested_Subprogram (Local_Proc);
9189 Make_Procedure_Call_Statement (Loc,
9190 Name => New_Occurrence_Of (Local_Proc, Loc));
9192 Insert_After (Loop_Stmt, Local_Call);
9193 Analyze (Local_Call);
9195 -- New procedure has the same scope as the original loop, and the scope
9196 -- of the loop is the new procedure.
9198 Set_Scope (Local_Proc, Scope (Loop_Ent));
9199 Set_Scope (Loop_Ent, Local_Proc);
9201 Fixup_Inner_Scopes (Loop_Copy);
9203 -- The entity list of the new procedure is that of the loop
9205 Set_First_Entity (Local_Proc, Ent);
9207 -- Note that the entities associated with the loop don't need to have
9208 -- their Scope fields reset, since they're still associated with the
9209 -- same loop entity that now belongs to the copied loop statement.
9212 ---------------------------
9213 -- Unnest_Statement_List --
9214 ---------------------------
9216 procedure Unnest_Statement_List (Stmts : in out List_Id) is
9217 Loc : constant Source_Ptr := Sloc (First (Stmts));
9218 Local_Body : Node_Id;
9219 Local_Call : Node_Id;
9220 Local_Proc : Entity_Id;
9221 New_Stmts : constant List_Id := Empty_List;
9224 Local_Proc := Make_Temporary (Loc, 'P');
9227 Make_Subprogram_Body (Loc,
9229 Make_Procedure_Specification (Loc,
9230 Defining_Unit_Name => Local_Proc),
9231 Declarations => Empty_List,
9232 Handled_Statement_Sequence =>
9233 Make_Handled_Sequence_Of_Statements (Loc,
9234 Statements => Stmts));
9236 Append_To (New_Stmts, Local_Body);
9238 Analyze (Local_Body);
9240 Set_Has_Nested_Subprogram (Local_Proc);
9243 Make_Procedure_Call_Statement (Loc,
9244 Name => New_Occurrence_Of (Local_Proc, Loc));
9246 Append_To (New_Stmts, Local_Call);
9247 Analyze (Local_Call);
9249 -- Traverse the statements, and for any that are declarations or
9250 -- subprogram bodies that have entities, set the Scope of those
9251 -- entities to the new procedure's Entity_Id.
9254 Stmt : Node_Id := First (Stmts);
9257 while Present (Stmt) loop
9258 case Nkind (Stmt) is
9260 | N_Renaming_Declaration
9262 Set_Scope (Defining_Identifier (Stmt), Local_Proc);
9264 when N_Subprogram_Body =>
9266 (Defining_Unit_Name (Specification (Stmt)), Local_Proc);
9277 end Unnest_Statement_List;
9279 --------------------------------
9280 -- Wrap_Transient_Declaration --
9281 --------------------------------
9283 -- If a transient scope has been established during the processing of the
9284 -- Expression of an Object_Declaration, it is not possible to wrap the
9285 -- declaration into a transient block as usual case, otherwise the object
9286 -- would be itself declared in the wrong scope. Therefore, all entities (if
9287 -- any) defined in the transient block are moved to the proper enclosing
9288 -- scope. Furthermore, if they are controlled variables they are finalized
9289 -- right after the declaration. The finalization list of the transient
9290 -- scope is defined as a renaming of the enclosing one so during their
9291 -- initialization they will be attached to the proper finalization list.
9292 -- For instance, the following declaration :
9294 -- X : Typ := F (G (A), G (B));
9296 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9297 -- is expanded into :
9299 -- X : Typ := [ complex Expression-Action ];
9300 -- [Deep_]Finalize (_v1);
9301 -- [Deep_]Finalize (_v2);
9303 procedure Wrap_Transient_Declaration (N : Node_Id) is
9308 Curr_S := Current_Scope;
9309 Encl_S := Scope (Curr_S);
9311 -- Insert all actions including cleanup generated while analyzing or
9312 -- expanding the transient context back into the tree. Manage the
9313 -- secondary stack when the object declaration appears in a library
9314 -- level package [body].
9316 Insert_Actions_In_Scope_Around
9320 Uses_Sec_Stack (Curr_S)
9321 and then Nkind (N) = N_Object_Declaration
9322 and then Ekind (Encl_S) in E_Package | E_Package_Body
9323 and then Is_Library_Level_Entity (Encl_S));
9326 -- Relocate local entities declared within the transient scope to the
9327 -- enclosing scope. This action sets their Is_Public flag accordingly.
9329 Transfer_Entities (Curr_S, Encl_S);
9331 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9332 -- is properly released upon exiting the said scope.
9334 if Uses_Sec_Stack (Curr_S) then
9335 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9337 -- Do not mark a function that returns on the secondary stack as the
9338 -- reclamation is done by the caller.
9340 if Ekind (Curr_S) = E_Function
9341 and then Needs_Secondary_Stack (Etype (Curr_S))
9345 -- Otherwise mark the enclosing dynamic scope
9348 Set_Uses_Sec_Stack (Curr_S);
9349 Check_Restriction (No_Secondary_Stack, N);
9352 end Wrap_Transient_Declaration;
9354 -------------------------------
9355 -- Wrap_Transient_Expression --
9356 -------------------------------
9358 procedure Wrap_Transient_Expression (N : Node_Id) is
9359 Loc : constant Source_Ptr := Sloc (N);
9360 Expr : Node_Id := Relocate_Node (N);
9361 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
9362 Typ : constant Entity_Id := Etype (N);
9369 -- M : constant Mark_Id := SS_Mark;
9370 -- procedure Finalizer is ... (See Build_Finalizer)
9373 -- Temp := <Expr>; -- general case
9374 -- Temp := (if <Expr> then True else False); -- boolean case
9380 -- A special case is made for Boolean expressions so that the back end
9381 -- knows to generate a conditional branch instruction, if running with
9382 -- -fpreserve-control-flow. This ensures that a control-flow change
9383 -- signaling the decision outcome occurs before the cleanup actions.
9385 if Opt.Suppress_Control_Flow_Optimizations
9386 and then Is_Boolean_Type (Typ)
9389 Make_If_Expression (Loc,
9390 Expressions => New_List (
9392 New_Occurrence_Of (Standard_True, Loc),
9393 New_Occurrence_Of (Standard_False, Loc)));
9396 Insert_Actions (N, New_List (
9397 Make_Object_Declaration (Loc,
9398 Defining_Identifier => Temp,
9399 Object_Definition => New_Occurrence_Of (Typ, Loc)),
9401 Make_Transient_Block (Loc,
9403 Make_Assignment_Statement (Loc,
9404 Name => New_Occurrence_Of (Temp, Loc),
9405 Expression => Expr),
9406 Par => Parent (N))));
9408 if Debug_Generated_Code then
9409 Set_Debug_Info_Needed (Temp);
9412 Rewrite (N, New_Occurrence_Of (Temp, Loc));
9413 Analyze_And_Resolve (N, Typ);
9414 end Wrap_Transient_Expression;
9416 ------------------------------
9417 -- Wrap_Transient_Statement --
9418 ------------------------------
9420 procedure Wrap_Transient_Statement (N : Node_Id) is
9421 Loc : constant Source_Ptr := Sloc (N);
9422 New_Stmt : constant Node_Id := Relocate_Node (N);
9427 -- M : constant Mark_Id := SS_Mark;
9428 -- procedure Finalizer is ... (See Build_Finalizer)
9438 Make_Transient_Block (Loc,
9440 Par => Parent (N)));
9442 -- With the scope stack back to normal, we can call analyze on the
9443 -- resulting block. At this point, the transient scope is being
9444 -- treated like a perfectly normal scope, so there is nothing
9445 -- special about it.
9447 -- Note: Wrap_Transient_Statement is called with the node already
9448 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9449 -- otherwise we would get a recursive processing of the node when
9450 -- we do this Analyze call.
9453 end Wrap_Transient_Statement;