1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-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 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Exp_Util
; use Exp_Util
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Output
; use Output
;
39 with Rtsfind
; use Rtsfind
;
41 with Sem_Aux
; use Sem_Aux
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Mech
; use Sem_Mech
;
44 with Sem_Res
; use Sem_Res
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
48 with Sinfo
.Utils
; use Sinfo
.Utils
;
49 with Sinput
; use Sinput
;
50 with Snames
; use Snames
;
51 with Stand
; use Stand
;
52 with Tbuild
; use Tbuild
;
53 with Uintp
; use Uintp
;
55 package body Exp_Unst
is
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 procedure Unnest_Subprogram
62 (Subp
: Entity_Id
; Subp_Body
: Node_Id
; For_Inline
: Boolean := False);
63 -- Subp is a library-level subprogram which has nested subprograms, and
64 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
65 -- declares the AREC types and objects, adds assignments to the AREC record
66 -- as required, defines the xxxPTR types for uplevel referenced objects,
67 -- adds the ARECP parameter to all nested subprograms which need it, and
68 -- modifies all uplevel references appropriately. If For_Inline is True,
69 -- we're unnesting this subprogram because it's on the list of inlined
70 -- subprograms and should unnest it despite it not being part of the main
77 -- Table to record calls within the nest being analyzed. These are the
78 -- calls which may need to have an AREC actual added. This table is built
79 -- new for each subprogram nest and cleared at the end of processing each
82 type Call_Entry
is record
87 -- Entity of the subprogram containing the call (can be at any level)
90 -- Entity of the subprogram called (always at level 2 or higher). Note
91 -- that in accordance with the basic rules of nesting, the level of To
92 -- is either less than or equal to the level of From, or one greater.
95 package Calls
is new Table
.Table
(
96 Table_Component_Type
=> Call_Entry
,
97 Table_Index_Type
=> Nat
,
100 Table_Increment
=> 200,
101 Table_Name
=> "Unnest_Calls");
102 -- Records each call within the outer subprogram and all nested subprograms
103 -- that are to other subprograms nested within the outer subprogram. These
104 -- are the calls that may need an additional parameter.
106 procedure Append_Unique_Call
(Call
: Call_Entry
);
107 -- Append a call entry to the Calls table. A check is made to see if the
108 -- table already contains this entry and if so it has no effect.
110 ----------------------------------
111 -- Subprograms For Fat Pointers --
112 ----------------------------------
114 function Build_Access_Type_Decl
116 Scop
: Entity_Id
) return Node_Id
;
117 -- For an uplevel reference that involves an unconstrained array type,
118 -- build an access type declaration for the corresponding activation
119 -- record component. The relevant attributes of the access type are
120 -- set here to avoid a full analysis that would require a scope stack.
122 function Needs_Fat_Pointer
(E
: Entity_Id
) return Boolean;
123 -- A formal parameter of an unconstrained array type that appears in an
124 -- uplevel reference requires the construction of an access type, to be
125 -- used in the corresponding component declaration.
131 -- Table to record explicit uplevel references to objects (variables,
132 -- constants, formal parameters). These are the references that will
133 -- need rewriting to use the activation table (AREC) pointers. Also
134 -- included are implicit and explicit uplevel references to types, but
135 -- these do not get rewritten by the front end. This table is built new
136 -- for each subprogram nest and cleared at the end of processing each
139 type Uref_Entry
is record
141 -- The reference itself. For objects this is always an entity reference
142 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
143 -- flag set and will appear in the Uplevel_Referenced_Entities list of
144 -- the subprogram declaring this entity.
147 -- The Entity_Id of the uplevel referenced object or type
150 -- The entity for the subprogram immediately containing this entity
153 -- The entity for the subprogram containing the referenced entity. Note
154 -- that the level of Callee must be less than the level of Caller, since
155 -- this is an uplevel reference.
158 package Urefs
is new Table
.Table
(
159 Table_Component_Type
=> Uref_Entry
,
160 Table_Index_Type
=> Nat
,
161 Table_Low_Bound
=> 1,
162 Table_Initial
=> 100,
163 Table_Increment
=> 200,
164 Table_Name
=> "Unnest_Urefs");
166 ------------------------
167 -- Append_Unique_Call --
168 ------------------------
170 procedure Append_Unique_Call
(Call
: Call_Entry
) is
172 for J
in Calls
.First
.. Calls
.Last
loop
173 if Calls
.Table
(J
) = Call
then
179 end Append_Unique_Call
;
181 -----------------------------
182 -- Build_Access_Type_Decl --
183 -----------------------------
185 function Build_Access_Type_Decl
187 Scop
: Entity_Id
) return Node_Id
189 Loc
: constant Source_Ptr
:= Sloc
(E
);
193 Typ
:= Make_Temporary
(Loc
, 'S');
194 Mutate_Ekind
(Typ
, E_General_Access_Type
);
195 Set_Etype
(Typ
, Typ
);
196 Set_Scope
(Typ
, Scop
);
197 Set_Directly_Designated_Type
(Typ
, Etype
(E
));
200 Make_Full_Type_Declaration
(Loc
,
201 Defining_Identifier
=> Typ
,
203 Make_Access_To_Object_Definition
(Loc
,
204 Subtype_Indication
=> New_Occurrence_Of
(Etype
(E
), Loc
)));
205 end Build_Access_Type_Decl
;
211 function Get_Level
(Subp
: Entity_Id
; Sub
: Entity_Id
) return Nat
is
223 S
:= Enclosing_Subprogram
(S
);
228 --------------------------
229 -- In_Synchronized_Unit --
230 --------------------------
232 function In_Synchronized_Unit
(Subp
: Entity_Id
) return Boolean is
233 S
: Entity_Id
:= Scope
(Subp
);
236 while Present
(S
) and then S
/= Standard_Standard
loop
237 if Is_Concurrent_Type
(S
) then
240 elsif Is_Private_Type
(S
)
241 and then Present
(Full_View
(S
))
242 and then Is_Concurrent_Type
(Full_View
(S
))
251 end In_Synchronized_Unit
;
253 -----------------------
254 -- Needs_Fat_Pointer --
255 -----------------------
257 function Needs_Fat_Pointer
(E
: Entity_Id
) return Boolean is
258 Typ
: constant Entity_Id
:= Get_Fullest_View
(Etype
(E
));
260 return Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
);
261 end Needs_Fat_Pointer
;
267 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
268 E
: Entity_Id
:= Sub
;
271 pragma Assert
(Is_Subprogram
(E
));
273 if Field_Is_Initial_Zero
(E
, F_Subps_Index
)
274 or else Subps_Index
(E
) = Uint_0
276 E
:= Ultimate_Alias
(E
);
278 -- The body of a protected operation has a different name and
279 -- has been scanned at this point, and thus has an entry in the
282 if E
= Sub
and then Present
(Protected_Body_Subprogram
(E
)) then
283 E
:= Protected_Body_Subprogram
(E
);
286 if Ekind
(E
) = E_Function
287 and then Rewritten_For_C
(E
)
288 and then Present
(Corresponding_Procedure
(E
))
290 E
:= Corresponding_Procedure
(E
);
294 pragma Assert
(Subps_Index
(E
) /= Uint_0
);
295 return SI_Type
(UI_To_Int
(Subps_Index
(E
)));
298 -----------------------
299 -- Unnest_Subprogram --
300 -----------------------
302 procedure Unnest_Subprogram
303 (Subp
: Entity_Id
; Subp_Body
: Node_Id
; For_Inline
: Boolean := False) is
304 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
;
305 -- Returns name for string ARECjS, where j is the decimal value of j
307 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
308 -- Subp is the index of a subprogram which has a Lev greater than 1.
309 -- This function returns the index of the enclosing subprogram which
310 -- will have a Lev value one less than this.
312 function Img_Pos
(N
: Pos
) return String;
313 -- Return image of N without leading blank
318 Clist
: List_Id
) return Name_Id
;
319 -- This function returns the name to be used in the activation record to
320 -- reference the variable uplevel. Clist is the list of components that
321 -- have been created in the activation record so far. Normally the name
322 -- is just a copy of the Chars field of the entity. The exception is
323 -- when the name has already been used, in which case we suffix the name
324 -- with the index value Index to avoid duplication. This happens with
325 -- declare blocks and generic parameters at least.
331 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
is
333 return Name_Find
("AREC" & Img_Pos
(J
) & S
);
340 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
341 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
342 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
344 pragma Assert
(STJ
.Lev
> 1);
345 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
353 function Img_Pos
(N
: Pos
) return String is
354 Buf
: String (1 .. 20);
362 Buf
(Ptr
) := Character'Val (48 + NV
mod 10);
367 return Buf
(Ptr
+ 1 .. Buf
'Last);
377 Clist
: List_Id
) return Name_Id
386 elsif Chars
(Defining_Identifier
(C
)) = Chars
(Ent
) then
388 Name_Find
(Get_Name_String
(Chars
(Ent
)) & Img_Pos
(Index
));
395 -- Start of processing for Unnest_Subprogram
398 -- Nothing to do inside a generic (all processing is for instance)
400 if Inside_A_Generic
then
404 -- If the main unit is a package body then we need to examine the spec
405 -- to determine whether the main unit is generic (the scope stack is not
406 -- present when this is called on the main unit).
409 and then Ekind
(Cunit_Entity
(Main_Unit
)) = E_Package_Body
410 and then Is_Generic_Unit
(Spec_Entity
(Cunit_Entity
(Main_Unit
)))
414 -- Only unnest when generating code for the main source unit or if
415 -- we're unnesting for inline. But in some Annex E cases the Sloc
416 -- points to a different unit, so also make sure that the Parent
417 -- isn't in something that we know we're generating code for.
420 and then not In_Extended_Main_Code_Unit
(Subp_Body
)
421 and then not In_Extended_Main_Code_Unit
(Parent
(Subp_Body
))
426 -- This routine is called late, after the scope stack is gone. The
427 -- following creates a suitable dummy scope stack to be used for the
428 -- analyze/expand calls made from this routine.
432 -- First step, we must mark all nested subprograms that require a static
433 -- link (activation record) because either they contain explicit uplevel
434 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
435 -- this point), or they make calls to other subprograms in the same nest
436 -- that require a static link (in which case we set this flag).
438 -- This is a recursive definition, and to implement this, we have to
439 -- build a call graph for the set of nested subprograms, and then go
440 -- over this graph to implement recursively the invariant that if a
441 -- subprogram has a call to a subprogram requiring a static link, then
442 -- the calling subprogram requires a static link.
444 -- First populate the above tables
446 Subps_First
:= Subps
.Last
+ 1;
450 Build_Tables
: declare
451 Current_Subprogram
: Entity_Id
:= Empty
;
452 -- When we scan a subprogram body, we set Current_Subprogram to the
453 -- corresponding entity. This gets recursively saved and restored.
455 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
456 -- Visit a single node in Subp
462 procedure Visit
is new Traverse_Proc
(Visit_Node
);
463 -- Used to traverse the body of Subp, populating the tables
469 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
474 procedure Check_Static_Type
478 Check_Designated
: Boolean := False);
479 -- Given a type In_T, checks if it is a static type defined as
480 -- a type with no dynamic bounds in sight. If so, the only
481 -- action is to set Is_Static_Type True for In_T. If In_T is
482 -- not a static type, then all types with dynamic bounds
483 -- associated with In_T are detected, and their bounds are
484 -- marked as uplevel referenced if not at the library level,
485 -- and DT is set True. If N is specified, it's the node that
486 -- will need to be replaced. If not specified, it means we
487 -- can't do a replacement because the bound is implicit.
489 -- If Check_Designated is True and In_T or its full view
490 -- is an access type, check whether the designated type
491 -- has dynamic bounds.
493 procedure Note_Uplevel_Ref
498 -- Called when we detect an explicit or implicit uplevel reference
499 -- from within Caller to entity E declared in Callee. E can be a
500 -- an object or a type.
502 procedure Register_Subprogram
(E
: Entity_Id
; Bod
: Node_Id
);
503 -- Enter a subprogram whose body is visible or which is a
504 -- subprogram instance into the subprogram table.
506 -----------------------
507 -- Check_Static_Type --
508 -----------------------
510 procedure Check_Static_Type
514 Check_Designated
: Boolean := False)
516 T
: constant Entity_Id
:= Get_Fullest_View
(In_T
);
518 procedure Note_Uplevel_Bound
(N
: Node_Id
; Ref
: Node_Id
);
519 -- N is the bound of a dynamic type. This procedure notes that
520 -- this bound is uplevel referenced, it can handle references
521 -- to entities (typically _FIRST and _LAST entities), and also
522 -- attribute references of the form T'name (name is typically
523 -- FIRST or LAST) where T is the uplevel referenced bound.
524 -- Ref, if Present, is the location of the reference to
527 ------------------------
528 -- Note_Uplevel_Bound --
529 ------------------------
531 procedure Note_Uplevel_Bound
(N
: Node_Id
; Ref
: Node_Id
) is
533 -- Entity name case. Make sure that the entity is declared
534 -- in a subprogram. This may not be the case for a type in a
535 -- loop appearing in a precondition.
536 -- Exclude explicitly discriminants (that can appear
537 -- in bounds of discriminated components) and enumeration
540 if Is_Entity_Name
(N
) then
541 if Present
(Entity
(N
))
542 and then not Is_Type
(Entity
(N
))
543 and then Present
(Enclosing_Subprogram
(Entity
(N
)))
546 not in E_Discriminant | E_Enumeration_Literal
551 Caller
=> Current_Subprogram
,
552 Callee
=> Enclosing_Subprogram
(Entity
(N
)));
555 -- Attribute or indexed component case
558 N_Attribute_Reference | N_Indexed_Component
560 Note_Uplevel_Bound
(Prefix
(N
), Ref
);
562 -- The indices of the indexed components, or the
563 -- associated expressions of an attribute reference,
564 -- may also involve uplevel references.
570 Expr
:= First
(Expressions
(N
));
571 while Present
(Expr
) loop
572 Note_Uplevel_Bound
(Expr
, Ref
);
577 -- The type of the prefix may be have an uplevel
578 -- reference if this needs bounds.
580 if Nkind
(N
) = N_Attribute_Reference
then
582 Attr
: constant Attribute_Id
:=
583 Get_Attribute_Id
(Attribute_Name
(N
));
584 DT
: Boolean := False;
587 if (Attr
= Attribute_First
588 or else Attr
= Attribute_Last
589 or else Attr
= Attribute_Length
)
590 and then Is_Constrained
(Etype
(Prefix
(N
)))
593 (Etype
(Prefix
(N
)), Empty
, DT
);
598 -- Binary operator cases. These can apply to arrays for
599 -- which we may need bounds.
601 elsif Nkind
(N
) in N_Binary_Op
then
602 Note_Uplevel_Bound
(Left_Opnd
(N
), Ref
);
603 Note_Uplevel_Bound
(Right_Opnd
(N
), Ref
);
605 -- Unary operator case
607 elsif Nkind
(N
) in N_Unary_Op
then
608 Note_Uplevel_Bound
(Right_Opnd
(N
), Ref
);
610 -- Explicit dereference and selected component case
613 N_Explicit_Dereference | N_Selected_Component
615 Note_Uplevel_Bound
(Prefix
(N
), Ref
);
617 -- Conditional expressions
619 elsif Nkind
(N
) = N_If_Expression
then
624 Expr
:= First
(Expressions
(N
));
625 while Present
(Expr
) loop
626 Note_Uplevel_Bound
(Expr
, Ref
);
631 elsif Nkind
(N
) = N_Case_Expression
then
633 Alternative
: Node_Id
;
636 Note_Uplevel_Bound
(Expression
(N
), Ref
);
638 Alternative
:= First
(Alternatives
(N
));
639 while Present
(Alternative
) loop
640 Note_Uplevel_Bound
(Expression
(Alternative
), Ref
);
647 N_Type_Conversion | N_Unchecked_Type_Conversion
649 Note_Uplevel_Bound
(Expression
(N
), Ref
);
651 end Note_Uplevel_Bound
;
653 -- Start of processing for Check_Static_Type
656 -- If already marked static, immediate return
658 if Is_Static_Type
(T
) and then not Check_Designated
then
662 -- If the type is at library level, always consider it static,
663 -- since such uplevel references are irrelevant.
665 if Is_Library_Level_Entity
(T
) then
666 Set_Is_Static_Type
(T
);
670 -- Otherwise figure out what the story is with this type
672 -- For a scalar type, check bounds
674 if Is_Scalar_Type
(T
) then
676 -- If both bounds static, then this is a static type
679 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
680 UB
: constant Node_Id
:= Type_High_Bound
(T
);
683 if not Is_Static_Expression
(LB
) then
684 Note_Uplevel_Bound
(LB
, N
);
688 if not Is_Static_Expression
(UB
) then
689 Note_Uplevel_Bound
(UB
, N
);
694 -- For record type, check all components and discriminant
695 -- constraints if present.
697 elsif Is_Record_Type
(T
) then
703 C
:= First_Component_Or_Discriminant
(T
);
704 while Present
(C
) loop
705 Check_Static_Type
(Etype
(C
), N
, DT
);
706 Next_Component_Or_Discriminant
(C
);
709 if Has_Discriminants
(T
)
710 and then Present
(Discriminant_Constraint
(T
))
712 D
:= First_Elmt
(Discriminant_Constraint
(T
));
713 while Present
(D
) loop
714 if not Is_Static_Expression
(Node
(D
)) then
715 Note_Uplevel_Bound
(Node
(D
), N
);
724 -- For array type, check index types and component type
726 elsif Is_Array_Type
(T
) then
730 Check_Static_Type
(Component_Type
(T
), N
, DT
);
732 IX
:= First_Index
(T
);
733 while Present
(IX
) loop
734 Check_Static_Type
(Etype
(IX
), N
, DT
);
739 -- For private type, examine whether full view is static
741 elsif Is_Incomplete_Or_Private_Type
(T
)
742 and then Present
(Full_View
(T
))
744 Check_Static_Type
(Full_View
(T
), N
, DT
, Check_Designated
);
746 if Is_Static_Type
(Full_View
(T
)) then
747 Set_Is_Static_Type
(T
);
750 -- For access types, check designated type when required
752 elsif Is_Access_Type
(T
) and then Check_Designated
then
753 Check_Static_Type
(Directly_Designated_Type
(T
), N
, DT
);
755 -- For now, ignore other types
762 Set_Is_Static_Type
(T
);
764 end Check_Static_Type
;
766 ----------------------
767 -- Note_Uplevel_Ref --
768 ----------------------
770 procedure Note_Uplevel_Ref
776 Full_E
: Entity_Id
:= E
;
778 -- Nothing to do for static type
780 if Is_Static_Type
(E
) then
784 -- Nothing to do if Caller and Callee are the same
786 if Caller
= Callee
then
789 -- Callee may be a function that returns an array, and that has
790 -- been rewritten as a procedure. If caller is that procedure,
791 -- nothing to do either.
793 elsif Ekind
(Callee
) = E_Function
794 and then Rewritten_For_C
(Callee
)
795 and then Corresponding_Procedure
(Callee
) = Caller
799 elsif Ekind
(Callee
) in E_Entry | E_Entry_Family
then
803 -- We have a new uplevel referenced entity
805 if Ekind
(E
) = E_Constant
and then Present
(Full_View
(E
)) then
806 Full_E
:= Full_View
(E
);
809 -- All we do at this stage is to add the uplevel reference to
810 -- the table. It's too early to do anything else, since this
811 -- uplevel reference may come from an unreachable subprogram
812 -- in which case the entry will be deleted.
814 Urefs
.Append
((N
, Full_E
, Caller
, Callee
));
815 end Note_Uplevel_Ref
;
817 -------------------------
818 -- Register_Subprogram --
819 -------------------------
821 procedure Register_Subprogram
(E
: Entity_Id
; Bod
: Node_Id
) is
822 L
: constant Nat
:= Get_Level
(Subp
, E
);
825 -- Subprograms declared in tasks and protected types cannot be
826 -- eliminated because calls to them may be in other units, so
827 -- they must be treated as reachable.
833 Reachable
=> In_Synchronized_Unit
(E
)
834 or else Address_Taken
(E
),
836 Declares_AREC
=> False,
846 Set_Subps_Index
(E
, UI_From_Int
(Subps
.Last
));
848 -- If we marked this reachable because it's in a synchronized
849 -- unit, we have to mark all enclosing subprograms as reachable
850 -- as well. We do the same for subprograms with Address_Taken,
851 -- because otherwise we can run into problems with looking at
852 -- enclosing subprograms in Subps.Table due to their being
853 -- unreachable (the Subp_Index of unreachable subps is later
854 -- set to zero and their entry in Subps.Table is removed).
856 if In_Synchronized_Unit
(E
) or else Address_Taken
(E
) then
861 for J
in reverse 1 .. L
- 1 loop
862 S
:= Enclosing_Subprogram
(S
);
863 Subps
.Table
(Subp_Index
(S
)).Reachable
:= True;
867 end Register_Subprogram
;
869 -- Start of processing for Visit_Node
874 -- Record a subprogram call
877 | N_Procedure_Call_Statement
879 -- We are only interested in direct calls, not indirect
880 -- calls (where Name (N) is an explicit dereference) at
883 if Nkind
(Name
(N
)) in N_Has_Entity
then
884 Ent
:= Entity
(Name
(N
));
886 -- We are only interested in calls to subprograms nested
887 -- within Subp. Calls to Subp itself or to subprograms
888 -- outside the nested structure do not affect us.
890 if Is_Subprogram
(Ent
)
891 and then not Is_Generic_Subprogram
(Ent
)
892 and then not Is_Imported
(Ent
)
893 and then not Is_Intrinsic_Subprogram
(Ent
)
894 and then Scope_Within
(Ultimate_Alias
(Ent
), Subp
)
896 Append_Unique_Call
((N
, Current_Subprogram
, Ent
));
900 -- For all calls where the formal is an unconstrained array
901 -- and the actual is constrained we need to check the bounds
902 -- for uplevel references.
906 DT
: Boolean := False;
913 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
914 Subp
:= Etype
(Name
(N
));
916 Subp
:= Entity
(Name
(N
));
919 Actual
:= First_Actual
(N
);
920 Formal
:= First_Formal_With_Extras
(Subp
);
922 while Present
(Actual
) loop
923 F_Type
:= Get_Fullest_View
(Etype
(Formal
));
924 A_Type
:= Get_Fullest_View
(Etype
(Actual
));
926 if Is_Array_Type
(F_Type
)
927 and then not Is_Constrained
(F_Type
)
928 and then Is_Constrained
(A_Type
)
930 Check_Static_Type
(A_Type
, Empty
, DT
);
933 Next_Actual
(Actual
);
934 Next_Formal_With_Extras
(Formal
);
938 -- An At_End_Proc in a statement sequence indicates that there
939 -- is a call from the enclosing construct or block to that
940 -- subprogram. As above, the called entity must be local and
943 when N_Handled_Sequence_Of_Statements | N_Block_Statement
=>
944 if Present
(At_End_Proc
(N
))
945 and then Scope_Within
(Entity
(At_End_Proc
(N
)), Subp
)
946 and then not Is_Imported
(Entity
(At_End_Proc
(N
)))
949 ((N
, Current_Subprogram
, Entity
(At_End_Proc
(N
))));
952 -- Similarly, the following constructs include a semantic
953 -- attribute Procedure_To_Call that must be handled like
954 -- other calls. Likewise for attribute Storage_Pool.
957 | N_Extended_Return_Statement
959 | N_Simple_Return_Statement
962 Pool
: constant Entity_Id
:= Storage_Pool
(N
);
963 Proc
: constant Entity_Id
:= Procedure_To_Call
(N
);
967 and then Scope_Within
(Proc
, Subp
)
968 and then not Is_Imported
(Proc
)
970 Append_Unique_Call
((N
, Current_Subprogram
, Proc
));
974 and then not Is_Library_Level_Entity
(Pool
)
975 and then Scope_Within_Or_Same
(Scope
(Pool
), Subp
)
977 Caller
:= Current_Subprogram
;
978 Callee
:= Enclosing_Subprogram
(Pool
);
980 if Callee
/= Caller
then
981 Note_Uplevel_Ref
(Pool
, Empty
, Caller
, Callee
);
986 -- For an allocator with a qualified expression, check type
987 -- of expression being qualified. The explicit type name is
988 -- handled as an entity reference.
990 if Nkind
(N
) = N_Allocator
991 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
994 DT
: Boolean := False;
997 (Etype
(Expression
(Expression
(N
))), Empty
, DT
);
1000 -- For a Return or Free (all other nodes we handle here),
1001 -- we usually need the size of the object, so we need to be
1002 -- sure that any nonstatic bounds of the expression's type
1003 -- that are uplevel are handled.
1005 elsif Nkind
(N
) /= N_Allocator
1006 and then Present
(Expression
(N
))
1009 DT
: Boolean := False;
1012 (Etype
(Expression
(N
)),
1015 Check_Designated
=> Nkind
(N
) = N_Free_Statement
);
1019 -- A 'Access reference is a (potential) call. So is 'Address,
1020 -- in particular on imported subprograms. Other attributes
1021 -- require special handling.
1023 when N_Attribute_Reference
=>
1025 Attr
: constant Attribute_Id
:=
1026 Get_Attribute_Id
(Attribute_Name
(N
));
1029 when Attribute_Access
1030 | Attribute_Unchecked_Access
1031 | Attribute_Unrestricted_Access
1034 if Nkind
(Prefix
(N
)) in N_Has_Entity
then
1035 Ent
:= Entity
(Prefix
(N
));
1037 -- We only need to examine calls to subprograms
1038 -- nested within current Subp.
1040 if Scope_Within
(Ent
, Subp
) then
1041 if Is_Imported
(Ent
) then
1044 elsif Is_Subprogram
(Ent
) then
1046 ((N
, Current_Subprogram
, Ent
));
1051 -- References to bounds can be uplevel references if
1052 -- the type isn't static.
1054 when Attribute_First
1058 -- Special-case attributes of objects whose bounds
1059 -- may be uplevel references. More complex prefixes
1060 -- handled during full traversal. Note that if the
1061 -- nominal subtype of the prefix is unconstrained,
1062 -- the bound must be obtained from the object, not
1063 -- from the (possibly) uplevel reference. We call
1064 -- Get_Referenced_Object to deal with prefixes that
1065 -- are object renamings (prefixes that are types
1066 -- can be passed and will simply be returned). But
1067 -- it's also legal to get the bounds from the type
1068 -- of the prefix, so we have to handle both cases.
1071 DT
: Boolean := False;
1075 (Etype
(Get_Referenced_Object
(Prefix
(N
))))
1078 (Etype
(Get_Referenced_Object
(Prefix
(N
))),
1082 if Is_Constrained
(Etype
(Prefix
(N
))) then
1084 (Etype
(Prefix
(N
)), Empty
, DT
);
1093 -- Component associations in aggregates are either static or
1094 -- else the aggregate will be expanded into assignments, in
1095 -- which case the expression is analyzed later and provides
1096 -- no relevant code generation.
1098 when N_Component_Association
=>
1099 if No
(Expression
(N
))
1100 or else No
(Etype
(Expression
(N
)))
1105 -- Generic associations are not analyzed: the actuals are
1106 -- transferred to renaming and subtype declarations that
1107 -- are the ones that must be examined.
1109 when N_Generic_Association
=>
1112 -- Indexed references can be uplevel if the type isn't static
1113 -- and if the lower bound (or an inner bound for a multi-
1114 -- dimensional array) is uplevel.
1116 when N_Indexed_Component
1119 if Is_Constrained
(Etype
(Prefix
(N
))) then
1121 DT
: Boolean := False;
1123 Check_Static_Type
(Etype
(Prefix
(N
)), Empty
, DT
);
1127 -- A selected component can have an implicit up-level
1128 -- reference due to the bounds of previous fields in the
1129 -- record. We simplify the processing here by examining
1130 -- all components of the record.
1132 -- Selected components appear as unit names and end labels
1133 -- for child units. Prefixes of these nodes denote parent
1134 -- units and carry no type information so they are skipped.
1136 when N_Selected_Component
=>
1137 if Present
(Etype
(Prefix
(N
))) then
1139 DT
: Boolean := False;
1141 Check_Static_Type
(Etype
(Prefix
(N
)), Empty
, DT
);
1145 -- For EQ/NE comparisons, we need the type of the operands
1146 -- in order to do the comparison, which means we need the
1153 DT
: Boolean := False;
1155 Check_Static_Type
(Etype
(Left_Opnd
(N
)), Empty
, DT
);
1156 Check_Static_Type
(Etype
(Right_Opnd
(N
)), Empty
, DT
);
1159 -- Likewise we need the sizes to compute how much to move in
1162 when N_Assignment_Statement
=>
1164 DT
: Boolean := False;
1166 Check_Static_Type
(Etype
(Name
(N
)), Empty
, DT
);
1167 Check_Static_Type
(Etype
(Expression
(N
)), Empty
, DT
);
1170 -- Record a subprogram. We record a subprogram body that acts
1171 -- as a spec. Otherwise we record a subprogram declaration,
1172 -- providing that it has a corresponding body we can get hold
1173 -- of. The case of no corresponding body being available is
1176 when N_Subprogram_Body
=>
1177 Ent
:= Unique_Defining_Entity
(N
);
1179 -- Ignore generic subprogram
1181 if Is_Generic_Subprogram
(Ent
) then
1185 -- Make new entry in subprogram table if not already made
1187 Register_Subprogram
(Ent
, N
);
1189 -- Record a call from an At_End_Proc
1191 if Present
(At_End_Proc
(N
))
1192 and then Scope_Within
(Entity
(At_End_Proc
(N
)), Subp
)
1193 and then not Is_Imported
(Entity
(At_End_Proc
(N
)))
1195 Append_Unique_Call
((N
, Ent
, Entity
(At_End_Proc
(N
))));
1198 -- We make a recursive call to scan the subprogram body, so
1199 -- that we can save and restore Current_Subprogram.
1202 Save_CS
: constant Entity_Id
:= Current_Subprogram
;
1206 Current_Subprogram
:= Ent
;
1208 -- Scan declarations
1210 Decl
:= First
(Declarations
(N
));
1211 while Present
(Decl
) loop
1218 Visit
(Handled_Statement_Sequence
(N
));
1220 -- Restore current subprogram setting
1222 Current_Subprogram
:= Save_CS
;
1225 -- Now at this level, return skipping the subprogram body
1226 -- descendants, since we already took care of them!
1230 -- If we have a body stub, visit the associated subunit, which
1231 -- is a semantic descendant of the stub.
1234 Visit
(Library_Unit
(N
));
1236 -- A declaration of a wrapper package indicates a subprogram
1237 -- instance for which there is no explicit body. Enter the
1238 -- subprogram instance in the table.
1240 when N_Package_Declaration
=>
1241 if Is_Wrapper_Package
(Defining_Entity
(N
)) then
1243 (Related_Instance
(Defining_Entity
(N
)), Empty
);
1246 -- Skip generic declarations
1248 when N_Generic_Declaration
=>
1251 -- Skip generic package body
1253 when N_Package_Body
=>
1254 if Present
(Corresponding_Spec
(N
))
1255 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
1260 -- Aspects, pragmas and component declarations are ignored.
1261 -- Quantified expressions are expanded into explicit loops
1262 -- and the original epression must be ignored.
1264 when N_Aspect_Specification
1265 | N_Component_Declaration
1267 | N_Quantified_Expression
1271 -- We want to skip the function spec for a generic function
1272 -- to avoid looking at any generic types that might be in
1275 when N_Function_Specification
=>
1276 if Is_Generic_Subprogram
(Unique_Defining_Entity
(N
)) then
1280 -- Otherwise record an uplevel reference in a local identifier
1283 if Nkind
(N
) in N_Has_Entity
1284 and then Present
(Entity
(N
))
1288 -- Only interested in entities declared within our nest
1290 if not Is_Library_Level_Entity
(Ent
)
1291 and then Scope_Within_Or_Same
(Scope
(Ent
), Subp
)
1293 -- Skip entities defined in inlined subprograms
1296 Chars
(Enclosing_Subprogram
(Ent
)) /= Name_uParent
1298 -- Constants and variables are potentially uplevel
1299 -- references to global declarations.
1302 (Ekind
(Ent
) in E_Constant
1306 -- Formals are interesting, but not if being used
1307 -- as mere names of parameters for name notation
1313 (Nkind
(Parent
(N
)) = N_Parameter_Association
1314 and then Selector_Name
(Parent
(N
)) = N
))
1316 -- Types other than known Is_Static types are
1317 -- potentially interesting.
1320 (Is_Type
(Ent
) and then not Is_Static_Type
(Ent
)))
1322 -- Here we have a potentially interesting uplevel
1323 -- reference to examine.
1325 if Is_Type
(Ent
) then
1327 DT
: Boolean := False;
1330 Check_Static_Type
(Ent
, N
, DT
);
1335 Caller
:= Current_Subprogram
;
1336 Callee
:= Enclosing_Subprogram
(Ent
);
1339 and then (not Is_Static_Type
(Ent
)
1340 or else Needs_Fat_Pointer
(Ent
))
1342 Note_Uplevel_Ref
(Ent
, N
, Caller
, Callee
);
1344 -- Check the type of a formal parameter of the current
1345 -- subprogram, whose formal type may be an uplevel
1348 elsif Is_Formal
(Ent
)
1349 and then Scope
(Ent
) = Current_Subprogram
1352 DT
: Boolean := False;
1355 Check_Static_Type
(Etype
(Ent
), Empty
, DT
);
1362 -- Fall through to continue scanning children of this node
1367 -- Start of processing for Build_Tables
1370 -- Traverse the body to get subprograms, calls and uplevel references
1375 -- Now do the first transitive closure which determines which
1376 -- subprograms in the nest are actually reachable.
1378 Reachable_Closure
: declare
1382 Subps
.Table
(Subps_First
).Reachable
:= True;
1384 -- We use a simple minded algorithm as follows (obviously this can
1385 -- be done more efficiently, using one of the standard algorithms
1386 -- for efficient transitive closure computation, but this is simple
1387 -- and most likely fast enough that its speed does not matter).
1389 -- Repeatedly scan the list of calls. Any time we find a call from
1390 -- A to B, where A is reachable, but B is not, then B is reachable,
1391 -- and note that we have made a change by setting Modified True. We
1392 -- repeat this until we make a pass with no modifications.
1396 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
1398 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1400 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1401 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1403 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1404 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1407 if SUBF
.Reachable
and then not SUBT
.Reachable
then
1408 SUBT
.Reachable
:= True;
1414 exit Outer
when not Modified
;
1416 end Reachable_Closure
;
1418 -- Remove calls from unreachable subprograms
1425 for J
in Calls
.First
.. Calls
.Last
loop
1427 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1429 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1430 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1432 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1433 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1436 if SUBF
.Reachable
then
1437 pragma Assert
(SUBT
.Reachable
);
1438 New_Index
:= New_Index
+ 1;
1439 Calls
.Table
(New_Index
) := Calls
.Table
(J
);
1444 Calls
.Set_Last
(New_Index
);
1447 -- Remove uplevel references from unreachable subprograms
1454 for J
in Urefs
.First
.. Urefs
.Last
loop
1456 URJ
: Uref_Entry
renames Urefs
.Table
(J
);
1458 SINF
: constant SI_Type
:= Subp_Index
(URJ
.Caller
);
1459 SINT
: constant SI_Type
:= Subp_Index
(URJ
.Callee
);
1461 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1462 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1467 -- Keep reachable reference
1469 if SUBF
.Reachable
then
1470 New_Index
:= New_Index
+ 1;
1471 Urefs
.Table
(New_Index
) := Urefs
.Table
(J
);
1473 -- And since we know we are keeping this one, this is a good
1474 -- place to fill in information for a good reference.
1476 -- Mark all enclosing subprograms need to declare AREC
1480 S
:= Enclosing_Subprogram
(S
);
1482 -- If we are at the top level, as can happen with
1483 -- references to formals in aspects of nested subprogram
1484 -- declarations, there are no further subprograms to mark
1485 -- as requiring activation records.
1490 SUBI
: Subp_Entry
renames Subps
.Table
(Subp_Index
(S
));
1492 SUBI
.Declares_AREC
:= True;
1494 -- If this entity was marked reachable because it is
1495 -- in a task or protected type, there may not appear
1496 -- to be any calls to it, which would normally adjust
1497 -- the levels of the parent subprograms. So we need to
1498 -- be sure that the uplevel reference of that entity
1499 -- takes into account possible calls.
1501 if In_Synchronized_Unit
(SUBF
.Ent
)
1502 and then SUBT
.Lev
< SUBI
.Uplevel_Ref
1504 SUBI
.Uplevel_Ref
:= SUBT
.Lev
;
1508 exit when S
= URJ
.Callee
;
1511 -- Add to list of uplevel referenced entities for Callee.
1512 -- We do not add types to this list, only actual references
1513 -- to objects that will be referenced uplevel, and we use
1514 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1515 -- duplicate entries in the list. Discriminants are also
1516 -- excluded, only the enclosing object can appear in the
1519 if not Is_Uplevel_Referenced_Entity
(URJ
.Ent
)
1520 and then Ekind
(URJ
.Ent
) /= E_Discriminant
1522 Set_Is_Uplevel_Referenced_Entity
(URJ
.Ent
);
1523 Append_New_Elmt
(URJ
.Ent
, SUBT
.Uents
);
1526 -- And set uplevel indication for caller
1528 if SUBT
.Lev
< SUBF
.Uplevel_Ref
then
1529 SUBF
.Uplevel_Ref
:= SUBT
.Lev
;
1535 Urefs
.Set_Last
(New_Index
);
1538 -- Remove unreachable subprograms from Subps table. Note that we do
1539 -- this after eliminating entries from the other two tables, since
1540 -- those elimination steps depend on referencing the Subps table.
1546 New_SI
:= Subps_First
- 1;
1547 for J
in Subps_First
.. Subps
.Last
loop
1549 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1554 -- Subprogram is reachable, copy and reset index
1556 if STJ
.Reachable
then
1557 New_SI
:= New_SI
+ 1;
1558 Subps
.Table
(New_SI
) := STJ
;
1559 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(New_SI
));
1561 -- Subprogram is not reachable
1564 -- Clear index, since no longer active
1566 Set_Subps_Index
(Subps
.Table
(J
).Ent
, Uint_0
);
1568 -- Output debug information if -gnatd.3 set
1570 if Debug_Flag_Dot_3
then
1571 Write_Str
("Eliminate ");
1572 Write_Name
(Chars
(Subps
.Table
(J
).Ent
));
1574 Write_Location
(Sloc
(Subps
.Table
(J
).Ent
));
1575 Write_Str
(" (not referenced)");
1579 -- Rewrite declaration, body, and corresponding freeze node
1580 -- to null statements.
1582 -- A subprogram instantiation does not have an explicit
1583 -- body. If unused, we could remove the corresponding
1584 -- wrapper package and its body.
1586 if Present
(STJ
.Bod
) then
1587 Spec
:= Corresponding_Spec
(STJ
.Bod
);
1589 if Present
(Spec
) then
1590 Decl
:= Parent
(Declaration_Node
(Spec
));
1591 Rewrite
(Decl
, Make_Null_Statement
(Sloc
(Decl
)));
1593 if Present
(Freeze_Node
(Spec
)) then
1594 Rewrite
(Freeze_Node
(Spec
),
1595 Make_Null_Statement
(Sloc
(Decl
)));
1599 Rewrite
(STJ
.Bod
, Make_Null_Statement
(Sloc
(STJ
.Bod
)));
1605 Subps
.Set_Last
(New_SI
);
1608 -- Now it is time for the second transitive closure, which follows calls
1609 -- and makes sure that A calls B, and B has uplevel references, then A
1610 -- is also marked as having uplevel references.
1612 Closure_Uplevel
: declare
1616 -- We use a simple minded algorithm as follows (obviously this can
1617 -- be done more efficiently, using one of the standard algorithms
1618 -- for efficient transitive closure computation, but this is simple
1619 -- and most likely fast enough that its speed does not matter).
1621 -- Repeatedly scan the list of calls. Any time we find a call from
1622 -- A to B, where B has uplevel references, make sure that A is marked
1623 -- as having at least the same level of uplevel referencing.
1627 Inner2
: for J
in Calls
.First
.. Calls
.Last
loop
1629 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1630 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1631 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1632 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1633 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1635 if SUBT
.Lev
> SUBT
.Uplevel_Ref
1636 and then SUBF
.Uplevel_Ref
> SUBT
.Uplevel_Ref
1638 SUBF
.Uplevel_Ref
:= SUBT
.Uplevel_Ref
;
1644 exit Outer2
when not Modified
;
1646 end Closure_Uplevel
;
1648 -- We have one more step before the tables are complete. An uplevel
1649 -- call from subprogram A to subprogram B where subprogram B has uplevel
1650 -- references is in effect an uplevel reference, and must arrange for
1651 -- the proper activation link to be passed.
1653 for J
in Calls
.First
.. Calls
.Last
loop
1655 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1657 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1658 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1660 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1661 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1666 -- If callee has uplevel references
1668 if SUBT
.Uplevel_Ref
< SUBT
.Lev
1670 -- And this is an uplevel call
1672 and then SUBT
.Lev
< SUBF
.Lev
1674 -- We need to arrange for finding the uplink
1678 A
:= Enclosing_Subprogram
(A
);
1679 Subps
.Table
(Subp_Index
(A
)).Declares_AREC
:= True;
1680 exit when A
= CTJ
.Callee
;
1682 -- In any case exit when we get to the outer level. This
1683 -- happens in some odd cases with generics (in particular
1684 -- sem_ch3.adb does not compile without this kludge ???).
1692 -- The tables are now complete, so we can record the last index in the
1693 -- Subps table for later reference in Cprint.
1695 Subps
.Table
(Subps_First
).Last
:= Subps
.Last
;
1697 -- Next step, create the entities for code we will insert. We do this
1698 -- at the start so that all the entities are defined, regardless of the
1699 -- order in which we do the code insertions.
1701 Create_Entities
: for J
in Subps_First
.. Subps
.Last
loop
1703 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1704 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1707 -- First we create the ARECnF entity for the additional formal for
1708 -- all subprograms which need an activation record passed.
1710 if STJ
.Uplevel_Ref
< STJ
.Lev
then
1712 Make_Defining_Identifier
(Loc
, Chars
=> AREC_Name
(J
, "F"));
1715 -- Define the AREC entities for the activation record if needed
1717 if STJ
.Declares_AREC
then
1719 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, ""));
1721 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "T"));
1723 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "PT"));
1725 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "P"));
1727 -- Define uplink component entity if inner nesting case
1729 if Present
(STJ
.ARECnF
) then
1731 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "U"));
1735 end loop Create_Entities
;
1737 -- Loop through subprograms
1740 Addr
: Entity_Id
:= Empty
;
1743 for J
in Subps_First
.. Subps
.Last
loop
1745 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1748 -- First add the extra formal if needed. This applies to all
1749 -- nested subprograms that require an activation record to be
1750 -- passed, as indicated by ARECnF being defined.
1752 if Present
(STJ
.ARECnF
) then
1754 -- Here we need the extra formal. We do the expansion and
1755 -- analysis of this manually, since it is fairly simple,
1756 -- and it is not obvious how we can get what we want if we
1757 -- try to use the normal Analyze circuit.
1759 Add_Extra_Formal
: declare
1760 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
1761 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
1762 -- Index and Subp_Entry for enclosing routine
1764 Form
: constant Entity_Id
:= STJ
.ARECnF
;
1765 -- The formal to be added. Note that n here is one less
1766 -- than the level of the subprogram itself (STJ.Ent).
1768 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
1769 -- S is an N_Function/Procedure_Specification node, and F
1770 -- is the new entity to add to this subprogram spec as
1771 -- the last Extra_Formal.
1773 ----------------------
1774 -- Add_Form_To_Spec --
1775 ----------------------
1777 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
1778 Sub
: constant Entity_Id
:= Defining_Entity
(S
);
1782 -- Case of at least one Extra_Formal is present, set
1783 -- ARECnF as the new last entry in the list.
1785 if Present
(Extra_Formals
(Sub
)) then
1786 Ent
:= Extra_Formals
(Sub
);
1787 while Present
(Extra_Formal
(Ent
)) loop
1788 Ent
:= Extra_Formal
(Ent
);
1791 Set_Extra_Formal
(Ent
, F
);
1793 -- No Extra formals present
1796 Set_Extra_Formals
(Sub
, F
);
1797 Ent
:= Last_Formal
(Sub
);
1799 if Present
(Ent
) then
1800 Set_Extra_Formal
(Ent
, F
);
1803 end Add_Form_To_Spec
;
1805 -- Start of processing for Add_Extra_Formal
1808 -- Decorate the new formal entity
1810 Set_Scope
(Form
, STJ
.Ent
);
1811 Mutate_Ekind
(Form
, E_In_Parameter
);
1812 Set_Etype
(Form
, STJE
.ARECnPT
);
1813 Set_Mechanism
(Form
, By_Copy
);
1814 Set_Never_Set_In_Source
(Form
, True);
1815 Set_Analyzed
(Form
, True);
1816 Set_Comes_From_Source
(Form
, False);
1817 Set_Is_Activation_Record
(Form
, True);
1819 -- Case of only body present
1821 if Acts_As_Spec
(STJ
.Bod
) then
1822 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
1824 -- Case of separate spec
1827 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
1829 end Add_Extra_Formal
;
1832 -- Processing for subprograms that declare an activation record
1834 if Present
(STJ
.ARECn
) then
1836 -- Local declarations for one such subprogram
1839 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1841 Decls
: constant List_Id
:= New_List
;
1842 -- List of new declarations we create
1847 Decl_Assign
: Node_Id
;
1848 -- Assignment to set uplink, Empty if none
1850 Decl_ARECnT
: Node_Id
;
1851 Decl_ARECnPT
: Node_Id
;
1852 Decl_ARECn
: Node_Id
;
1853 Decl_ARECnP
: Node_Id
;
1854 -- Declaration nodes for the AREC entities we build
1857 -- Build list of component declarations for ARECnT and
1858 -- load System.Address.
1860 Clist
:= Empty_List
;
1863 Addr
:= RTE
(RE_Address
);
1866 -- If we are in a subprogram that has a static link that
1867 -- is passed in (as indicated by ARECnF being defined),
1868 -- then include ARECnU : ARECmPT where ARECmPT comes from
1869 -- the level one higher than the current level, and the
1870 -- entity ARECnPT comes from the enclosing subprogram.
1872 if Present
(STJ
.ARECnF
) then
1875 renames Subps
.Table
(Enclosing_Subp
(J
));
1878 Make_Component_Declaration
(Loc
,
1879 Defining_Identifier
=> STJ
.ARECnU
,
1880 Component_Definition
=>
1881 Make_Component_Definition
(Loc
,
1882 Subtype_Indication
=>
1883 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
))));
1887 -- Add components for uplevel referenced entities
1889 if Present
(STJ
.Uents
) then
1896 -- 1's origin of index in list of elements. This is
1897 -- used to uniquify names if needed in Upref_Name.
1900 Elmt
:= First_Elmt
(STJ
.Uents
);
1902 while Present
(Elmt
) loop
1903 Uent
:= Node
(Elmt
);
1907 Make_Defining_Identifier
(Loc
,
1908 Chars
=> Upref_Name
(Uent
, Indx
, Clist
));
1910 Set_Activation_Record_Component
1913 if Needs_Fat_Pointer
(Uent
) then
1915 -- Build corresponding access type
1918 Build_Access_Type_Decl
1919 (Etype
(Uent
), STJ
.Ent
);
1920 Append_To
(Decls
, Ptr_Decl
);
1922 -- And use its type in the corresponding
1926 Make_Component_Declaration
(Loc
,
1927 Defining_Identifier
=> Comp
,
1928 Component_Definition
=>
1929 Make_Component_Definition
(Loc
,
1930 Subtype_Indication
=>
1932 (Defining_Identifier
(Ptr_Decl
),
1936 Make_Component_Declaration
(Loc
,
1937 Defining_Identifier
=> Comp
,
1938 Component_Definition
=>
1939 Make_Component_Definition
(Loc
,
1940 Subtype_Indication
=>
1941 New_Occurrence_Of
(Addr
, Loc
))));
1948 -- Now we can insert the AREC declarations into the body
1949 -- type ARECnT is record .. end record;
1950 -- pragma Suppress_Initialization (ARECnT);
1952 -- Note that we need to set the Suppress_Initialization
1953 -- flag after Decl_ARECnT has been analyzed.
1956 Make_Full_Type_Declaration
(Loc
,
1957 Defining_Identifier
=> STJ
.ARECnT
,
1959 Make_Record_Definition
(Loc
,
1961 Make_Component_List
(Loc
,
1962 Component_Items
=> Clist
)));
1963 Append_To
(Decls
, Decl_ARECnT
);
1965 -- type ARECnPT is access all ARECnT;
1968 Make_Full_Type_Declaration
(Loc
,
1969 Defining_Identifier
=> STJ
.ARECnPT
,
1971 Make_Access_To_Object_Definition
(Loc
,
1972 All_Present
=> True,
1973 Subtype_Indication
=>
1974 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
1975 Append_To
(Decls
, Decl_ARECnPT
);
1977 -- ARECn : aliased ARECnT;
1980 Make_Object_Declaration
(Loc
,
1981 Defining_Identifier
=> STJ
.ARECn
,
1982 Aliased_Present
=> True,
1983 Object_Definition
=>
1984 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
1985 Append_To
(Decls
, Decl_ARECn
);
1987 -- ARECnP : constant ARECnPT := ARECn'Access;
1990 Make_Object_Declaration
(Loc
,
1991 Defining_Identifier
=> STJ
.ARECnP
,
1992 Constant_Present
=> True,
1993 Object_Definition
=>
1994 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
1996 Make_Attribute_Reference
(Loc
,
1998 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1999 Attribute_Name
=> Name_Access
));
2000 Append_To
(Decls
, Decl_ARECnP
);
2002 -- If we are in a subprogram that has a static link that
2003 -- is passed in (as indicated by ARECnF being defined),
2004 -- then generate ARECn.ARECmU := ARECmF where m is
2005 -- one less than the current level to set the uplink.
2007 if Present
(STJ
.ARECnF
) then
2009 Make_Assignment_Statement
(Loc
,
2011 Make_Selected_Component
(Loc
,
2013 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
2015 New_Occurrence_Of
(STJ
.ARECnU
, Loc
)),
2017 New_Occurrence_Of
(STJ
.ARECnF
, Loc
));
2018 Append_To
(Decls
, Decl_Assign
);
2021 Decl_Assign
:= Empty
;
2024 if No
(Declarations
(STJ
.Bod
)) then
2025 Set_Declarations
(STJ
.Bod
, Decls
);
2027 Prepend_List_To
(Declarations
(STJ
.Bod
), Decls
);
2030 -- Analyze the newly inserted declarations. Note that we
2031 -- do not need to establish the whole scope stack, since
2032 -- we have already set all entity fields (so there will
2033 -- be no searching of upper scopes to resolve names). But
2034 -- we do set the scope of the current subprogram, so that
2035 -- newly created entities go in the right entity chain.
2037 -- We analyze with all checks suppressed (since we do
2038 -- not expect any exceptions).
2040 Push_Scope
(STJ
.Ent
);
2041 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
2043 -- Note that we need to call Set_Suppress_Initialization
2044 -- after Decl_ARECnT has been analyzed, but before
2045 -- analyzing Decl_ARECnP so that the flag is properly
2046 -- taking into account.
2048 Set_Suppress_Initialization
(STJ
.ARECnT
);
2050 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
2051 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
2052 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
2054 if Present
(Decl_Assign
) then
2055 Analyze
(Decl_Assign
, Suppress
=> All_Checks
);
2060 -- Next step, for each uplevel referenced entity, add
2061 -- assignment operations to set the component in the
2062 -- activation record.
2064 if Present
(STJ
.Uents
) then
2069 Elmt
:= First_Elmt
(STJ
.Uents
);
2070 while Present
(Elmt
) loop
2072 Ent
: constant Entity_Id
:= Node
(Elmt
);
2073 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
2074 Dec
: constant Node_Id
:=
2075 Declaration_Node
(Ent
);
2084 -- For parameters, we insert the assignment
2085 -- right after the declaration of ARECnP.
2086 -- For all other entities, we insert the
2087 -- assignment immediately after the
2088 -- declaration of the entity or after the
2089 -- freeze node if present.
2091 -- Note: we don't need to mark the entity
2092 -- as being aliased, because the address
2093 -- attribute will mark it as Address_Taken,
2094 -- and that is good enough.
2096 if Is_Formal
(Ent
) then
2099 elsif Has_Delayed_Freeze
(Ent
) then
2100 Ins
:= Freeze_Node
(Ent
);
2106 -- Build and insert the assignment:
2107 -- ARECn.nam := nam'Address
2108 -- or else 'Unchecked_Access for
2109 -- unconstrained array.
2111 if Needs_Fat_Pointer
(Ent
) then
2112 Attr
:= Name_Unchecked_Access
;
2114 Attr
:= Name_Address
;
2118 Make_Attribute_Reference
(Loc
,
2120 New_Occurrence_Of
(Ent
, Loc
),
2121 Attribute_Name
=> Attr
);
2123 -- If the entity is an unconstrained formal
2124 -- we wrap the attribute reference in an
2125 -- unchecked conversion to the type of the
2126 -- activation record component, to prevent
2127 -- spurious subtype conformance errors within
2131 and then not Is_Constrained
(Etype
(Ent
))
2133 -- Find target component and its type
2135 Comp
:= First_Component
(STJ
.ARECnT
);
2136 while Chars
(Comp
) /= Chars
(Ent
) loop
2137 Next_Component
(Comp
);
2141 Unchecked_Convert_To
(Etype
(Comp
), Rhs
);
2145 Make_Assignment_Statement
(Loc
,
2147 Make_Selected_Component
(Loc
,
2149 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
2152 (Activation_Record_Component
2157 -- If we have a loop parameter, we have
2158 -- to insert before the first statement
2159 -- of the loop. Ins points to the
2160 -- N_Loop_Parameter_Specification or to
2161 -- an N_Iterator_Specification.
2164 N_Iterator_Specification |
2165 N_Loop_Parameter_Specification
2167 -- Quantified expression are rewritten as
2168 -- loops during expansion.
2170 if Nkind
(Parent
(Ins
)) =
2171 N_Quantified_Expression
2179 (Parent
(Parent
(Ins
))));
2180 Insert_Before
(Ins
, Asn
);
2184 Insert_After
(Ins
, Asn
);
2187 -- Analyze the assignment statement. We do
2188 -- not need to establish the relevant scope
2189 -- stack entries here, because we have
2190 -- already set the correct entity references,
2191 -- so no name resolution is required, and no
2192 -- new entities are created, so we don't even
2193 -- need to set the current scope.
2195 -- We analyze with all checks suppressed
2196 -- (since we do not expect any exceptions).
2198 Analyze
(Asn
, Suppress
=> All_Checks
);
2211 -- Next step, process uplevel references. This has to be done in a
2212 -- separate pass, after completing the processing in Sub_Loop because we
2213 -- need all the AREC declarations generated, inserted, and analyzed so
2214 -- that the uplevel references can be successfully analyzed.
2216 Uplev_Refs
: for J
in Urefs
.First
.. Urefs
.Last
loop
2218 UPJ
: Uref_Entry
renames Urefs
.Table
(J
);
2221 -- Ignore type references, these are implicit references that do
2222 -- not need rewriting (e.g. the appearance in a conversion).
2223 -- Also ignore if no reference was specified or if the rewriting
2224 -- has already been done (this can happen if the N_Identifier
2225 -- occurs more than one time in the tree). Also ignore references
2226 -- when not generating C code (in particular for the case of LLVM,
2227 -- since GNAT-LLVM will handle the processing for up-level refs).
2230 or else not Is_Entity_Name
(UPJ
.Ref
)
2231 or else No
(Entity
(UPJ
.Ref
))
2232 or else not Opt
.Generate_C_Code
2237 -- Rewrite one reference
2239 Rewrite_One_Ref
: declare
2240 Loc
: constant Source_Ptr
:= Sloc
(UPJ
.Ref
);
2241 -- Source location for the reference
2243 Typ
: constant Entity_Id
:= Etype
(UPJ
.Ent
);
2244 -- The type of the referenced entity
2247 -- The actual subtype of the reference
2249 RS_Caller
: constant SI_Type
:= Subp_Index
(UPJ
.Caller
);
2250 -- Subp_Index for caller containing reference
2252 STJR
: Subp_Entry
renames Subps
.Table
(RS_Caller
);
2253 -- Subp_Entry for subprogram containing reference
2255 RS_Callee
: constant SI_Type
:= Subp_Index
(UPJ
.Callee
);
2256 -- Subp_Index for subprogram containing referenced entity
2258 STJE
: Subp_Entry
renames Subps
.Table
(RS_Callee
);
2259 -- Subp_Entry for subprogram containing referenced entity
2266 Atyp
:= Etype
(UPJ
.Ref
);
2268 if Ekind
(Atyp
) /= E_Record_Subtype
then
2269 Atyp
:= Get_Actual_Subtype
(UPJ
.Ref
);
2272 -- Ignore if no ARECnF entity for enclosing subprogram which
2273 -- probably happens as a result of not properly treating
2274 -- instance bodies. To be examined ???
2276 -- If this test is omitted, then the compilation of freeze.adb
2277 -- and inline.adb fail in unnesting mode.
2279 if No
(STJR
.ARECnF
) then
2283 -- If this is a reference to a global constant, use its value
2284 -- rather than create a reference. It is more efficient and
2285 -- furthermore indispensable if the context requires a
2286 -- constant, such as a branch of a case statement.
2288 if Ekind
(UPJ
.Ent
) = E_Constant
2289 and then Is_True_Constant
(UPJ
.Ent
)
2290 and then Present
(Constant_Value
(UPJ
.Ent
))
2291 and then Is_Static_Expression
(Constant_Value
(UPJ
.Ent
))
2293 Rewrite
(UPJ
.Ref
, New_Copy_Tree
(Constant_Value
(UPJ
.Ent
)));
2297 -- Push the current scope, so that the pointer type Tnn, and
2298 -- any subsidiary entities resulting from the analysis of the
2299 -- rewritten reference, go in the right entity chain.
2301 Push_Scope
(STJR
.Ent
);
2303 -- Now we need to rewrite the reference. We have a reference
2304 -- from level STJR.Lev to level STJE.Lev. The general form of
2305 -- the rewritten reference for entity X is:
2307 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
2309 -- where a,b,c,d .. m =
2310 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
2312 pragma Assert
(STJR
.Lev
> STJE
.Lev
);
2314 -- Compute the prefix of X. Here are examples to make things
2315 -- clear (with parens to show groupings, the prefix is
2316 -- everything except the .X at the end).
2318 -- level 2 to level 1
2322 -- level 3 to level 1
2324 -- (AREC2F.AREC1U).X
2326 -- level 4 to level 1
2328 -- ((AREC3F.AREC2U).AREC1U).X
2330 -- level 6 to level 2
2332 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
2334 -- In the above, ARECnF and ARECnU are pointers, so there are
2335 -- explicit dereferences required for these occurrences.
2338 Make_Explicit_Dereference
(Loc
,
2339 Prefix
=> New_Occurrence_Of
(STJR
.ARECnF
, Loc
));
2341 for L
in STJE
.Lev
.. STJR
.Lev
- 2 loop
2342 SI
:= Enclosing_Subp
(SI
);
2344 Make_Explicit_Dereference
(Loc
,
2346 Make_Selected_Component
(Loc
,
2349 New_Occurrence_Of
(Subps
.Table
(SI
).ARECnU
, Loc
)));
2352 -- Get activation record component (must exist)
2354 Comp
:= Activation_Record_Component
(UPJ
.Ent
);
2355 pragma Assert
(Present
(Comp
));
2357 -- Do the replacement. If the component type is an access type,
2358 -- this is an uplevel reference for an entity that requires a
2359 -- fat pointer, so dereference the component.
2361 if Is_Access_Type
(Etype
(Comp
)) then
2363 Make_Explicit_Dereference
(Loc
,
2365 Make_Selected_Component
(Loc
,
2368 New_Occurrence_Of
(Comp
, Loc
))));
2372 Make_Attribute_Reference
(Loc
,
2373 Prefix
=> New_Occurrence_Of
(Atyp
, Loc
),
2374 Attribute_Name
=> Name_Deref
,
2375 Expressions
=> New_List
(
2376 Make_Selected_Component
(Loc
,
2379 New_Occurrence_Of
(Comp
, Loc
)))));
2382 -- Analyze and resolve the new expression. We do not need to
2383 -- establish the relevant scope stack entries here, because we
2384 -- have already set all the correct entity references, so no
2385 -- name resolution is needed. We have already set the current
2386 -- scope, so that any new entities created will be in the right
2389 -- We analyze with all checks suppressed (since we do not
2390 -- expect any exceptions)
2392 Analyze_And_Resolve
(UPJ
.Ref
, Typ
, Suppress
=> All_Checks
);
2394 -- Generate an extra temporary to facilitate the C backend
2395 -- processing this dereference
2397 if Opt
.Modify_Tree_For_C
2398 and then Nkind
(Parent
(UPJ
.Ref
)) in
2399 N_Type_Conversion | N_Unchecked_Type_Conversion
2401 Force_Evaluation
(UPJ
.Ref
, Mode
=> Strict
);
2405 end Rewrite_One_Ref
;
2410 end loop Uplev_Refs
;
2412 -- Finally, loop through all calls adding extra actual for the
2413 -- activation record where it is required.
2415 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
2417 -- Process a single call, we are only interested in a call to a
2418 -- subprogram that actually needs a pointer to an activation record,
2419 -- as indicated by the ARECnF entity being set. This excludes the
2420 -- top level subprogram, and any subprogram not having uplevel refs.
2422 Adjust_One_Call
: declare
2423 CTJ
: Call_Entry
renames Calls
.Table
(J
);
2424 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Caller
));
2425 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Callee
));
2427 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
2435 if Present
(STT
.ARECnF
)
2436 and then Nkind
(CTJ
.N
) in N_Subprogram_Call
2438 -- CTJ.N is a call to a subprogram which may require a pointer
2439 -- to an activation record. The subprogram containing the call
2440 -- is CTJ.From and the subprogram being called is CTJ.To, so we
2441 -- have a call from level STF.Lev to level STT.Lev.
2443 -- There are three possibilities:
2445 -- For a call to the same level, we just pass the activation
2446 -- record passed to the calling subprogram.
2448 if STF
.Lev
= STT
.Lev
then
2449 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
2451 -- For a call that goes down a level, we pass a pointer to the
2452 -- activation record constructed within the caller (which may
2453 -- be the outer-level subprogram, but also may be a more deeply
2456 elsif STT
.Lev
= STF
.Lev
+ 1 then
2457 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
2459 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
2460 -- since it is not possible to do a downcall of more than
2463 -- For a call from level STF.Lev to level STT.Lev, we
2464 -- have to find the activation record needed by the
2465 -- callee. This is as follows:
2467 -- ARECaF.ARECbU.ARECcU....ARECmU
2469 -- where a,b,c .. m =
2470 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
2473 pragma Assert
(STT
.Lev
< STF
.Lev
);
2475 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
2476 SubX
:= Subp_Index
(CTJ
.Caller
);
2477 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
2478 SubX
:= Enclosing_Subp
(SubX
);
2480 Make_Selected_Component
(Loc
,
2484 (Subps
.Table
(SubX
).ARECnU
, Loc
));
2488 -- Extra is the additional parameter to be added. Build a
2489 -- parameter association that we can append to the actuals.
2492 Make_Parameter_Association
(Loc
,
2494 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
2495 Explicit_Actual_Parameter
=> Extra
);
2497 if No
(Parameter_Associations
(CTJ
.N
)) then
2498 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
2501 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
2503 -- We need to deal with the actual parameter chain as well. The
2504 -- newly added parameter is always the last actual.
2506 Act
:= First_Named_Actual
(CTJ
.N
);
2509 Set_First_Named_Actual
(CTJ
.N
, Extra
);
2511 -- If call has been relocated (as with an expression in
2512 -- an aggregate), set First_Named pointer in original node
2513 -- as well, because that's the parent of the parameter list.
2515 Set_First_Named_Actual
2516 (Parent
(List_Containing
(ExtraP
)), Extra
);
2518 -- Here we must follow the chain and append the new entry
2527 PAN
:= Parent
(Act
);
2528 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
2529 NNA
:= Next_Named_Actual
(PAN
);
2532 Set_Next_Named_Actual
(PAN
, Extra
);
2541 -- Analyze and resolve the new actual. We do not need to
2542 -- establish the relevant scope stack entries here, because
2543 -- we have already set all the correct entity references, so
2544 -- no name resolution is needed.
2546 -- We analyze with all checks suppressed (since we do not
2547 -- expect any exceptions, and also we temporarily turn off
2548 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2549 -- references (not needed at this stage, and in fact causes
2550 -- a bit of recursive chaos).
2552 Opt
.Unnest_Subprogram_Mode
:= False;
2554 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
2555 Opt
.Unnest_Subprogram_Mode
:= True;
2557 end Adjust_One_Call
;
2558 end loop Adjust_Calls
;
2561 end Unnest_Subprogram
;
2563 ------------------------
2564 -- Unnest_Subprograms --
2565 ------------------------
2567 procedure Unnest_Subprograms
(N
: Node_Id
) is
2568 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
;
2569 -- Tree visitor that search for outer level procedures with nested
2570 -- subprograms and invokes Unnest_Subprogram()
2576 procedure Do_Search
is new Traverse_Proc
(Search_Subprograms
);
2577 -- Subtree visitor instantiation
2579 ------------------------
2580 -- Search_Subprograms --
2581 ------------------------
2583 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
is
2585 if Nkind
(N
) in N_Subprogram_Body | N_Subprogram_Body_Stub
then
2587 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
2590 -- We are only interested in subprograms (not generic
2591 -- subprograms), that have nested subprograms.
2593 if Is_Subprogram
(Spec_Id
)
2594 and then Has_Nested_Subprogram
(Spec_Id
)
2595 and then Is_Library_Level_Entity
(Spec_Id
)
2597 Unnest_Subprogram
(Spec_Id
, N
);
2603 -- The proper body of a stub may contain nested subprograms, and
2604 -- therefore must be visited explicitly. Nested stubs are examined
2605 -- recursively in Visit_Node.
2607 elsif Nkind
(N
) in N_Body_Stub
then
2608 Do_Search
(Library_Unit
(N
));
2610 -- Skip generic packages
2612 elsif Nkind
(N
) = N_Package_Body
2613 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
2619 end Search_Subprograms
;
2622 Subp_Body
: Node_Id
;
2624 -- Start of processing for Unnest_Subprograms
2627 if not Opt
.Unnest_Subprogram_Mode
or not Opt
.Expander_Active
then
2631 -- A specification will contain bodies if it contains instantiations so
2632 -- examine package or subprogram declaration of the main unit, when it
2635 if Nkind
(Unit
(N
)) = N_Package_Body
2636 or else (Nkind
(Unit
(N
)) = N_Subprogram_Body
2637 and then not Acts_As_Spec
(N
))
2639 Do_Search
(Library_Unit
(N
));
2644 -- Unnest any subprograms passed on the list of inlined subprograms
2646 Subp
:= First_Inlined_Subprogram
(N
);
2648 while Present
(Subp
) loop
2649 Subp_Body
:= Parent
(Declaration_Node
(Subp
));
2651 if Nkind
(Subp_Body
) = N_Subprogram_Declaration
2652 and then Present
(Corresponding_Body
(Subp_Body
))
2654 Subp_Body
:= Parent
(Declaration_Node
2655 (Corresponding_Body
(Subp_Body
)));
2658 Unnest_Subprogram
(Subp
, Subp_Body
, For_Inline
=> True);
2659 Next_Inlined_Subprogram
(Subp
);
2661 end Unnest_Subprograms
;