1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-2018, 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 Elists
; use Elists
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Output
; use Output
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Mech
; use Sem_Mech
;
41 with Sem_Res
; use Sem_Res
;
42 with Sem_Util
; use Sem_Util
;
43 with Sinfo
; use Sinfo
;
44 with Sinput
; use Sinput
;
45 with Snames
; use Snames
;
46 with Tbuild
; use Tbuild
;
47 with Uintp
; use Uintp
;
49 package body Exp_Unst
is
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
);
56 -- Subp is a library-level subprogram which has nested subprograms, and
57 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
58 -- declares the AREC types and objects, adds assignments to the AREC record
59 -- as required, defines the xxxPTR types for uplevel referenced objects,
60 -- adds the ARECP parameter to all nested subprograms which need it, and
61 -- modifies all uplevel references appropriately.
67 -- Table to record calls within the nest being analyzed. These are the
68 -- calls which may need to have an AREC actual added. This table is built
69 -- new for each subprogram nest and cleared at the end of processing each
72 type Call_Entry
is record
77 -- Entity of the subprogram containing the call (can be at any level)
80 -- Entity of the subprogram called (always at level 2 or higher). Note
81 -- that in accordance with the basic rules of nesting, the level of To
82 -- is either less than or equal to the level of From, or one greater.
85 package Calls
is new Table
.Table
(
86 Table_Component_Type
=> Call_Entry
,
87 Table_Index_Type
=> Nat
,
90 Table_Increment
=> 200,
91 Table_Name
=> "Unnest_Calls");
92 -- Records each call within the outer subprogram and all nested subprograms
93 -- that are to other subprograms nested within the outer subprogram. These
94 -- are the calls that may need an additional parameter.
96 procedure Append_Unique_Call
(Call
: Call_Entry
);
97 -- Append a call entry to the Calls table. A check is made to see if the
98 -- table already contains this entry and if so it has no effect.
104 -- Table to record explicit uplevel references to objects (variables,
105 -- constants, formal parameters). These are the references that will
106 -- need rewriting to use the activation table (AREC) pointers. Also
107 -- included are implicit and explicit uplevel references to types, but
108 -- these do not get rewritten by the front end. This table is built new
109 -- for each subprogram nest and cleared at the end of processing each
112 type Uref_Entry
is record
114 -- The reference itself. For objects this is always an entity reference
115 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
116 -- flag set and will appear in the Uplevel_Referenced_Entities list of
117 -- the subprogram declaring this entity.
120 -- The Entity_Id of the uplevel referenced object or type
123 -- The entity for the subprogram immediately containing this entity
126 -- The entity for the subprogram containing the referenced entity. Note
127 -- that the level of Callee must be less than the level of Caller, since
128 -- this is an uplevel reference.
131 package Urefs
is new Table
.Table
(
132 Table_Component_Type
=> Uref_Entry
,
133 Table_Index_Type
=> Nat
,
134 Table_Low_Bound
=> 1,
135 Table_Initial
=> 100,
136 Table_Increment
=> 200,
137 Table_Name
=> "Unnest_Urefs");
139 ------------------------
140 -- Append_Unique_Call --
141 ------------------------
143 procedure Append_Unique_Call
(Call
: Call_Entry
) is
145 for J
in Calls
.First
.. Calls
.Last
loop
146 if Calls
.Table
(J
) = Call
then
152 end Append_Unique_Call
;
158 function Get_Level
(Subp
: Entity_Id
; Sub
: Entity_Id
) return Nat
is
170 S
:= Enclosing_Subprogram
(S
);
179 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
180 E
: Entity_Id
:= Sub
;
183 pragma Assert
(Is_Subprogram
(E
));
185 if Subps_Index
(E
) = Uint_0
then
186 E
:= Ultimate_Alias
(E
);
188 if Ekind
(E
) = E_Function
189 and then Rewritten_For_C
(E
)
190 and then Present
(Corresponding_Procedure
(E
))
192 E
:= Corresponding_Procedure
(E
);
196 pragma Assert
(Subps_Index
(E
) /= Uint_0
);
197 return SI_Type
(UI_To_Int
(Subps_Index
(E
)));
200 -----------------------
201 -- Unnest_Subprogram --
202 -----------------------
204 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
) is
205 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
;
206 -- Returns name for string ARECjS, where j is the decimal value of j
208 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
209 -- Subp is the index of a subprogram which has a Lev greater than 1.
210 -- This function returns the index of the enclosing subprogram which
211 -- will have a Lev value one less than this.
213 function Img_Pos
(N
: Pos
) return String;
214 -- Return image of N without leading blank
219 Clist
: List_Id
) return Name_Id
;
220 -- This function returns the name to be used in the activation record to
221 -- reference the variable uplevel. Clist is the list of components that
222 -- have been created in the activation record so far. Normally the name
223 -- is just a copy of the Chars field of the entity. The exception is
224 -- when the name has already been used, in which case we suffix the name
225 -- with the index value Index to avoid duplication. This happens with
226 -- declare blocks and generic parameters at least.
232 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
is
234 return Name_Find
("AREC" & Img_Pos
(J
) & S
);
241 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
242 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
243 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
245 pragma Assert
(STJ
.Lev
> 1);
246 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
254 function Img_Pos
(N
: Pos
) return String is
255 Buf
: String (1 .. 20);
263 Buf
(Ptr
) := Character'Val (48 + NV
mod 10);
268 return Buf
(Ptr
+ 1 .. Buf
'Last);
278 Clist
: List_Id
) return Name_Id
287 elsif Chars
(Defining_Identifier
(C
)) = Chars
(Ent
) then
289 Name_Find
(Get_Name_String
(Chars
(Ent
)) & Img_Pos
(Index
));
296 -- Start of processing for Unnest_Subprogram
299 -- Nothing to do inside a generic (all processing is for instance)
301 if Inside_A_Generic
then
305 -- If the main unit is a package body then we need to examine the spec
306 -- to determine whether the main unit is generic (the scope stack is not
307 -- present when this is called on the main unit).
309 if Ekind
(Cunit_Entity
(Main_Unit
)) = E_Package_Body
310 and then Is_Generic_Unit
(Spec_Entity
(Cunit_Entity
(Main_Unit
)))
315 -- Only unnest when generating code for the main source unit
317 if not In_Extended_Main_Code_Unit
(Subp_Body
) then
321 -- This routine is called late, after the scope stack is gone. The
322 -- following creates a suitable dummy scope stack to be used for the
323 -- analyze/expand calls made from this routine.
327 -- First step, we must mark all nested subprograms that require a static
328 -- link (activation record) because either they contain explicit uplevel
329 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
330 -- this point), or they make calls to other subprograms in the same nest
331 -- that require a static link (in which case we set this flag).
333 -- This is a recursive definition, and to implement this, we have to
334 -- build a call graph for the set of nested subprograms, and then go
335 -- over this graph to implement recursively the invariant that if a
336 -- subprogram has a call to a subprogram requiring a static link, then
337 -- the calling subprogram requires a static link.
339 -- First populate the above tables
341 Subps_First
:= Subps
.Last
+ 1;
345 Build_Tables
: declare
346 Current_Subprogram
: Entity_Id
;
347 -- When we scan a subprogram body, we set Current_Subprogram to the
348 -- corresponding entity. This gets recursively saved and restored.
350 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
351 -- Visit a single node in Subp
357 procedure Visit
is new Traverse_Proc
(Visit_Node
);
358 -- Used to traverse the body of Subp, populating the tables
364 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
369 procedure Check_Static_Type
(T
: Entity_Id
; DT
: in out Boolean);
370 -- Given a type T, checks if it is a static type defined as a type
371 -- with no dynamic bounds in sight. If so, the only action is to
372 -- set Is_Static_Type True for T. If T is not a static type, then
373 -- all types with dynamic bounds associated with T are detected,
374 -- and their bounds are marked as uplevel referenced if not at the
375 -- library level, and DT is set True.
377 procedure Note_Uplevel_Ref
381 -- Called when we detect an explicit or implicit uplevel reference
382 -- from within Caller to entity E declared in Callee. E can be a
383 -- an object or a type.
385 -----------------------
386 -- Check_Static_Type --
387 -----------------------
389 procedure Check_Static_Type
(T
: Entity_Id
; DT
: in out Boolean) is
390 procedure Note_Uplevel_Bound
(N
: Node_Id
);
391 -- N is the bound of a dynamic type. This procedure notes that
392 -- this bound is uplevel referenced, it can handle references
393 -- to entities (typically _FIRST and _LAST entities), and also
394 -- attribute references of the form T'name (name is typically
395 -- FIRST or LAST) where T is the uplevel referenced bound.
397 ------------------------
398 -- Note_Uplevel_Bound --
399 ------------------------
401 procedure Note_Uplevel_Bound
(N
: Node_Id
) is
405 if Is_Entity_Name
(N
) then
406 if Present
(Entity
(N
)) then
409 Caller
=> Current_Subprogram
,
410 Callee
=> Enclosing_Subprogram
(Entity
(N
)));
415 elsif Nkind
(N
) = N_Attribute_Reference
then
416 Note_Uplevel_Bound
(Prefix
(N
));
418 end Note_Uplevel_Bound
;
420 -- Start of processing for Check_Static_Type
423 -- If already marked static, immediate return
425 if Is_Static_Type
(T
) then
429 -- If the type is at library level, always consider it static,
430 -- since such uplevel references are irrelevant.
432 if Is_Library_Level_Entity
(T
) then
433 Set_Is_Static_Type
(T
);
437 -- Otherwise figure out what the story is with this type
439 -- For a scalar type, check bounds
441 if Is_Scalar_Type
(T
) then
443 -- If both bounds static, then this is a static type
446 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
447 UB
: constant Node_Id
:= Type_High_Bound
(T
);
450 if not Is_Static_Expression
(LB
) then
451 Note_Uplevel_Bound
(LB
);
455 if not Is_Static_Expression
(UB
) then
456 Note_Uplevel_Bound
(UB
);
461 -- For record type, check all components
463 elsif Is_Record_Type
(T
) then
467 C
:= First_Component_Or_Discriminant
(T
);
468 while Present
(C
) loop
469 Check_Static_Type
(Etype
(C
), DT
);
470 Next_Component_Or_Discriminant
(C
);
474 -- For array type, check index types and component type
476 elsif Is_Array_Type
(T
) then
480 Check_Static_Type
(Component_Type
(T
), DT
);
482 IX
:= First_Index
(T
);
483 while Present
(IX
) loop
484 Check_Static_Type
(Etype
(IX
), DT
);
489 -- For private type, examine whether full view is static
491 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
492 Check_Static_Type
(Full_View
(T
), DT
);
494 if Is_Static_Type
(Full_View
(T
)) then
495 Set_Is_Static_Type
(T
);
498 -- For now, ignore other types
505 Set_Is_Static_Type
(T
);
507 end Check_Static_Type
;
509 ----------------------
510 -- Note_Uplevel_Ref --
511 ----------------------
513 procedure Note_Uplevel_Ref
519 -- Nothing to do for static type
521 if Is_Static_Type
(E
) then
525 -- Nothing to do if Caller and Callee are the same
527 if Caller
= Callee
then
530 -- Callee may be a function that returns an array, and that has
531 -- been rewritten as a procedure. If caller is that procedure,
532 -- nothing to do either.
534 elsif Ekind
(Callee
) = E_Function
535 and then Rewritten_For_C
(Callee
)
536 and then Corresponding_Procedure
(Callee
) = Caller
541 -- We have a new uplevel referenced entity
543 -- All we do at this stage is to add the uplevel reference to
544 -- the table. It's too early to do anything else, since this
545 -- uplevel reference may come from an unreachable subprogram
546 -- in which case the entry will be deleted.
548 Urefs
.Append
((N
, E
, Caller
, Callee
));
549 end Note_Uplevel_Ref
;
551 -- Start of processing for Visit_Node
556 if Nkind_In
(N
, N_Procedure_Call_Statement
, N_Function_Call
)
558 -- We are only interested in direct calls, not indirect calls
559 -- (where Name (N) is an explicit dereference) at least for now!
561 and then Nkind
(Name
(N
)) in N_Has_Entity
563 Ent
:= Entity
(Name
(N
));
565 -- We are only interested in calls to subprograms nested
566 -- within Subp. Calls to Subp itself or to subprograms
567 -- that are outside the nested structure do not affect us.
569 if Scope_Within
(Ent
, Subp
) then
571 -- Ignore calls to imported routines
573 if Is_Imported
(Ent
) then
576 -- Here we have a call to keep and analyze
579 -- Both caller and callee must be subprograms
581 if Is_Subprogram
(Ent
) then
582 Append_Unique_Call
((N
, Current_Subprogram
, Ent
));
587 -- Record a 'Access as a (potential) call
589 elsif Nkind
(N
) = N_Attribute_Reference
then
591 Attr
: constant Attribute_Id
:=
592 Get_Attribute_Id
(Attribute_Name
(N
));
595 when Attribute_Access
596 | Attribute_Unchecked_Access
597 | Attribute_Unrestricted_Access
599 if Nkind
(Prefix
(N
)) in N_Has_Entity
then
600 Ent
:= Entity
(Prefix
(N
));
602 -- We are only interested in calls to subprograms
603 -- nested within Subp.
605 if Scope_Within
(Ent
, Subp
) then
606 if Is_Imported
(Ent
) then
609 elsif Is_Subprogram
(Ent
) then
611 ((N
, Current_Subprogram
, Ent
));
620 DT
: Boolean := False;
622 Check_Static_Type
(Etype
(Prefix
(N
)), DT
);
630 -- Record a subprogram. We record a subprogram body that acts as
631 -- a spec. Otherwise we record a subprogram declaration, providing
632 -- that it has a corresponding body we can get hold of. The case
633 -- of no corresponding body being available is ignored for now.
635 elsif Nkind
(N
) = N_Subprogram_Body
then
636 Ent
:= Unique_Defining_Entity
(N
);
638 -- Ignore generic subprogram
640 if Is_Generic_Subprogram
(Ent
) then
644 -- Make new entry in subprogram table if not already made
647 L
: constant Nat
:= Get_Level
(Subp
, Ent
);
655 Declares_AREC
=> False,
664 Set_Subps_Index
(Ent
, UI_From_Int
(Subps
.Last
));
667 -- We make a recursive call to scan the subprogram body, so
668 -- that we can save and restore Current_Subprogram.
671 Save_CS
: constant Entity_Id
:= Current_Subprogram
;
675 Current_Subprogram
:= Ent
;
679 Decl
:= First
(Declarations
(N
));
680 while Present
(Decl
) loop
687 Visit
(Handled_Statement_Sequence
(N
));
689 -- Restore current subprogram setting
691 Current_Subprogram
:= Save_CS
;
694 -- Now at this level, return skipping the subprogram body
695 -- descendants, since we already took care of them!
699 -- Record an uplevel reference
701 elsif Nkind
(N
) in N_Has_Entity
and then Present
(Entity
(N
)) then
704 -- Only interested in entities declared within our nest
706 if not Is_Library_Level_Entity
(Ent
)
707 and then Scope_Within_Or_Same
(Scope
(Ent
), Subp
)
709 -- Skip entities defined in inlined subprograms
711 and then Chars
(Enclosing_Subprogram
(Ent
)) /= Name_uParent
714 -- Constants and variables are interesting
716 (Ekind_In
(Ent
, E_Constant
, E_Variable
)
718 -- Formals are interesting, but not if being used as mere
719 -- names of parameters for name notation calls.
724 (Nkind
(Parent
(N
)) = N_Parameter_Association
725 and then Selector_Name
(Parent
(N
)) = N
))
727 -- Types other than known Is_Static types are interesting
729 or else (Is_Type
(Ent
)
730 and then not Is_Static_Type
(Ent
)))
732 -- Here we have a possible interesting uplevel reference
734 if Is_Type
(Ent
) then
736 DT
: Boolean := False;
739 Check_Static_Type
(Ent
, DT
);
741 if Is_Static_Type
(Ent
) then
747 Caller
:= Current_Subprogram
;
748 Callee
:= Enclosing_Subprogram
(Ent
);
750 if Callee
/= Caller
and then not Is_Static_Type
(Ent
) then
751 Note_Uplevel_Ref
(Ent
, Caller
, Callee
);
755 -- If we have a body stub, visit the associated subunit
757 elsif Nkind
(N
) in N_Body_Stub
then
758 Visit
(Library_Unit
(N
));
760 -- Skip generic declarations
762 elsif Nkind
(N
) in N_Generic_Declaration
then
765 -- Skip generic package body
767 elsif Nkind
(N
) = N_Package_Body
768 and then Present
(Corresponding_Spec
(N
))
769 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
774 -- Fall through to continue scanning children of this node
779 -- Start of processing for Build_Tables
782 -- Traverse the body to get subprograms, calls and uplevel references
787 -- Now do the first transitive closure which determines which
788 -- subprograms in the nest are actually reachable.
790 Reachable_Closure
: declare
794 Subps
.Table
(Subps_First
).Reachable
:= True;
796 -- We use a simple minded algorithm as follows (obviously this can
797 -- be done more efficiently, using one of the standard algorithms
798 -- for efficient transitive closure computation, but this is simple
799 -- and most likely fast enough that its speed does not matter).
801 -- Repeatedly scan the list of calls. Any time we find a call from
802 -- A to B, where A is reachable, but B is not, then B is reachable,
803 -- and note that we have made a change by setting Modified True. We
804 -- repeat this until we make a pass with no modifications.
808 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
810 CTJ
: Call_Entry
renames Calls
.Table
(J
);
812 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
813 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
815 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
816 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
819 if SUBF
.Reachable
and then not SUBT
.Reachable
then
820 SUBT
.Reachable
:= True;
826 exit Outer
when not Modified
;
828 end Reachable_Closure
;
830 -- Remove calls from unreachable subprograms
837 for J
in Calls
.First
.. Calls
.Last
loop
839 CTJ
: Call_Entry
renames Calls
.Table
(J
);
841 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
842 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
844 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
845 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
848 if SUBF
.Reachable
then
849 pragma Assert
(SUBT
.Reachable
);
850 New_Index
:= New_Index
+ 1;
851 Calls
.Table
(New_Index
) := Calls
.Table
(J
);
856 Calls
.Set_Last
(New_Index
);
859 -- Remove uplevel references from unreachable subprograms
866 for J
in Urefs
.First
.. Urefs
.Last
loop
868 URJ
: Uref_Entry
renames Urefs
.Table
(J
);
870 SINF
: constant SI_Type
:= Subp_Index
(URJ
.Caller
);
871 SINT
: constant SI_Type
:= Subp_Index
(URJ
.Callee
);
873 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
874 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
879 -- Keep reachable reference
881 if SUBF
.Reachable
then
882 New_Index
:= New_Index
+ 1;
883 Urefs
.Table
(New_Index
) := Urefs
.Table
(J
);
885 -- And since we know we are keeping this one, this is a good
886 -- place to fill in information for a good reference.
888 -- Mark all enclosing subprograms need to declare AREC
892 S
:= Enclosing_Subprogram
(S
);
894 -- if we are at the top level, as can happen with
895 -- references to formals in aspects of nested subprogram
896 -- declarations, there are no further subprograms to
897 -- mark as requiring activation records.
900 Subps
.Table
(Subp_Index
(S
)).Declares_AREC
:= True;
901 exit when S
= URJ
.Callee
;
904 -- Add to list of uplevel referenced entities for Callee.
905 -- We do not add types to this list, only actual references
906 -- to objects that will be referenced uplevel, and we use
907 -- the flag Is_Uplevel_Referenced_Entity to avoid making
908 -- duplicate entries in the list.
910 if not Is_Uplevel_Referenced_Entity
(URJ
.Ent
) then
911 Set_Is_Uplevel_Referenced_Entity
(URJ
.Ent
);
913 if not Is_Type
(URJ
.Ent
) then
914 Append_New_Elmt
(URJ
.Ent
, SUBT
.Uents
);
918 -- And set uplevel indication for caller
920 if SUBT
.Lev
< SUBF
.Uplevel_Ref
then
921 SUBF
.Uplevel_Ref
:= SUBT
.Lev
;
927 Urefs
.Set_Last
(New_Index
);
930 -- Remove unreachable subprograms from Subps table. Note that we do
931 -- this after eliminating entries from the other two tables, since
932 -- those elimination steps depend on referencing the Subps table.
938 New_SI
:= Subps_First
- 1;
939 for J
in Subps_First
.. Subps
.Last
loop
941 STJ
: Subp_Entry
renames Subps
.Table
(J
);
946 -- Subprogram is reachable, copy and reset index
948 if STJ
.Reachable
then
949 New_SI
:= New_SI
+ 1;
950 Subps
.Table
(New_SI
) := STJ
;
951 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(New_SI
));
953 -- Subprogram is not reachable
956 -- Clear index, since no longer active
958 Set_Subps_Index
(Subps
.Table
(J
).Ent
, Uint_0
);
960 -- Output debug information if -gnatd.3 set
962 if Debug_Flag_Dot_3
then
963 Write_Str
("Eliminate ");
964 Write_Name
(Chars
(Subps
.Table
(J
).Ent
));
966 Write_Location
(Sloc
(Subps
.Table
(J
).Ent
));
967 Write_Str
(" (not referenced)");
971 -- Rewrite declaration and body to null statements
973 Spec
:= Corresponding_Spec
(STJ
.Bod
);
975 if Present
(Spec
) then
976 Decl
:= Parent
(Declaration_Node
(Spec
));
977 Rewrite
(Decl
, Make_Null_Statement
(Sloc
(Decl
)));
980 Rewrite
(STJ
.Bod
, Make_Null_Statement
(Sloc
(STJ
.Bod
)));
985 Subps
.Set_Last
(New_SI
);
988 -- Now it is time for the second transitive closure, which follows calls
989 -- and makes sure that A calls B, and B has uplevel references, then A
990 -- is also marked as having uplevel references.
992 Closure_Uplevel
: declare
996 -- We use a simple minded algorithm as follows (obviously this can
997 -- be done more efficiently, using one of the standard algorithms
998 -- for efficient transitive closure computation, but this is simple
999 -- and most likely fast enough that its speed does not matter).
1001 -- Repeatedly scan the list of calls. Any time we find a call from
1002 -- A to B, where B has uplevel references, make sure that A is marked
1003 -- as having at least the same level of uplevel referencing.
1007 Inner2
: for J
in Calls
.First
.. Calls
.Last
loop
1009 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1010 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1011 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1012 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1013 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1015 if SUBT
.Lev
> SUBT
.Uplevel_Ref
1016 and then SUBF
.Uplevel_Ref
> SUBT
.Uplevel_Ref
1018 SUBF
.Uplevel_Ref
:= SUBT
.Uplevel_Ref
;
1024 exit Outer2
when not Modified
;
1026 end Closure_Uplevel
;
1028 -- We have one more step before the tables are complete. An uplevel
1029 -- call from subprogram A to subprogram B where subprogram B has uplevel
1030 -- references is in effect an uplevel reference, and must arrange for
1031 -- the proper activation link to be passed.
1033 for J
in Calls
.First
.. Calls
.Last
loop
1035 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1037 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1038 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1040 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1041 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1046 -- If callee has uplevel references
1048 if SUBT
.Uplevel_Ref
< SUBT
.Lev
1050 -- And this is an uplevel call
1052 and then SUBT
.Lev
< SUBF
.Lev
1054 -- We need to arrange for finding the uplink
1058 A
:= Enclosing_Subprogram
(A
);
1059 Subps
.Table
(Subp_Index
(A
)).Declares_AREC
:= True;
1060 exit when A
= CTJ
.Callee
;
1062 -- In any case exit when we get to the outer level. This
1063 -- happens in some odd cases with generics (in particular
1064 -- sem_ch3.adb does not compile without this kludge ???).
1072 -- The tables are now complete, so we can record the last index in the
1073 -- Subps table for later reference in Cprint.
1075 Subps
.Table
(Subps_First
).Last
:= Subps
.Last
;
1077 -- Next step, create the entities for code we will insert. We do this
1078 -- at the start so that all the entities are defined, regardless of the
1079 -- order in which we do the code insertions.
1081 Create_Entities
: for J
in Subps_First
.. Subps
.Last
loop
1083 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1084 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1087 -- First we create the ARECnF entity for the additional formal for
1088 -- all subprograms which need an activation record passed.
1090 if STJ
.Uplevel_Ref
< STJ
.Lev
then
1092 Make_Defining_Identifier
(Loc
, Chars
=> AREC_Name
(J
, "F"));
1095 -- Define the AREC entities for the activation record if needed
1097 if STJ
.Declares_AREC
then
1099 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, ""));
1101 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "T"));
1103 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "PT"));
1105 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "P"));
1107 -- Define uplink component entity if inner nesting case
1109 if Present
(STJ
.ARECnF
) then
1111 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "U"));
1115 end loop Create_Entities
;
1117 -- Loop through subprograms
1120 Addr
: constant Entity_Id
:= RTE
(RE_Address
);
1123 for J
in Subps_First
.. Subps
.Last
loop
1125 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1128 -- First add the extra formal if needed. This applies to all
1129 -- nested subprograms that require an activation record to be
1130 -- passed, as indicated by ARECnF being defined.
1132 if Present
(STJ
.ARECnF
) then
1134 -- Here we need the extra formal. We do the expansion and
1135 -- analysis of this manually, since it is fairly simple,
1136 -- and it is not obvious how we can get what we want if we
1137 -- try to use the normal Analyze circuit.
1139 Add_Extra_Formal
: declare
1140 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
1141 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
1142 -- Index and Subp_Entry for enclosing routine
1144 Form
: constant Entity_Id
:= STJ
.ARECnF
;
1145 -- The formal to be added. Note that n here is one less
1146 -- than the level of the subprogram itself (STJ.Ent).
1148 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
1149 -- S is an N_Function/Procedure_Specification node, and F
1150 -- is the new entity to add to this subprogramn spec as
1151 -- the last Extra_Formal.
1153 ----------------------
1154 -- Add_Form_To_Spec --
1155 ----------------------
1157 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
1158 Sub
: constant Entity_Id
:= Defining_Entity
(S
);
1162 -- Case of at least one Extra_Formal is present, set
1163 -- ARECnF as the new last entry in the list.
1165 if Present
(Extra_Formals
(Sub
)) then
1166 Ent
:= Extra_Formals
(Sub
);
1167 while Present
(Extra_Formal
(Ent
)) loop
1168 Ent
:= Extra_Formal
(Ent
);
1171 Set_Extra_Formal
(Ent
, F
);
1173 -- No Extra formals present
1176 Set_Extra_Formals
(Sub
, F
);
1177 Ent
:= Last_Formal
(Sub
);
1179 if Present
(Ent
) then
1180 Set_Extra_Formal
(Ent
, F
);
1183 end Add_Form_To_Spec
;
1185 -- Start of processing for Add_Extra_Formal
1188 -- Decorate the new formal entity
1190 Set_Scope
(Form
, STJ
.Ent
);
1191 Set_Ekind
(Form
, E_In_Parameter
);
1192 Set_Etype
(Form
, STJE
.ARECnPT
);
1193 Set_Mechanism
(Form
, By_Copy
);
1194 Set_Never_Set_In_Source
(Form
, True);
1195 Set_Analyzed
(Form
, True);
1196 Set_Comes_From_Source
(Form
, False);
1197 Set_Is_Activation_Record
(Form
, True);
1199 -- Case of only body present
1201 if Acts_As_Spec
(STJ
.Bod
) then
1202 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
1204 -- Case of separate spec
1207 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
1209 end Add_Extra_Formal
;
1212 -- Processing for subprograms that declare an activation record
1214 if Present
(STJ
.ARECn
) then
1216 -- Local declarations for one such subprogram
1219 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1223 Decl_ARECnT
: Node_Id
;
1224 Decl_ARECnPT
: Node_Id
;
1225 Decl_ARECn
: Node_Id
;
1226 Decl_ARECnP
: Node_Id
;
1227 -- Declaration nodes for the AREC entities we build
1229 Decl_Assign
: Node_Id
;
1230 -- Assigment to set uplink, Empty if none
1233 -- List of new declarations we create
1236 -- Build list of component declarations for ARECnT
1238 Clist
:= Empty_List
;
1240 -- If we are in a subprogram that has a static link that
1241 -- is passed in (as indicated by ARECnF being defined),
1242 -- then include ARECnU : ARECmPT where ARECmPT comes from
1243 -- the level one higher than the current level, and the
1244 -- entity ARECnPT comes from the enclosing subprogram.
1246 if Present
(STJ
.ARECnF
) then
1249 renames Subps
.Table
(Enclosing_Subp
(J
));
1252 Make_Component_Declaration
(Loc
,
1253 Defining_Identifier
=> STJ
.ARECnU
,
1254 Component_Definition
=>
1255 Make_Component_Definition
(Loc
,
1256 Subtype_Indication
=>
1257 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
))));
1261 -- Add components for uplevel referenced entities
1263 if Present
(STJ
.Uents
) then
1269 -- 1's origin of index in list of elements. This is
1270 -- used to uniquify names if needed in Upref_Name.
1273 Elmt
:= First_Elmt
(STJ
.Uents
);
1275 while Present
(Elmt
) loop
1276 Uent
:= Node
(Elmt
);
1280 Make_Defining_Identifier
(Loc
,
1281 Chars
=> Upref_Name
(Uent
, Indx
, Clist
));
1283 Set_Activation_Record_Component
1287 Make_Component_Declaration
(Loc
,
1288 Defining_Identifier
=> Comp
,
1289 Component_Definition
=>
1290 Make_Component_Definition
(Loc
,
1291 Subtype_Indication
=>
1292 New_Occurrence_Of
(Addr
, Loc
))));
1299 -- Now we can insert the AREC declarations into the body
1301 -- type ARECnT is record .. end record;
1302 -- pragma Suppress_Initialization (ARECnT);
1304 -- Note that we need to set the Suppress_Initialization
1305 -- flag after Decl_ARECnT has been analyzed.
1308 Make_Full_Type_Declaration
(Loc
,
1309 Defining_Identifier
=> STJ
.ARECnT
,
1311 Make_Record_Definition
(Loc
,
1313 Make_Component_List
(Loc
,
1314 Component_Items
=> Clist
)));
1315 Decls
:= New_List
(Decl_ARECnT
);
1317 -- type ARECnPT is access all ARECnT;
1320 Make_Full_Type_Declaration
(Loc
,
1321 Defining_Identifier
=> STJ
.ARECnPT
,
1323 Make_Access_To_Object_Definition
(Loc
,
1324 All_Present
=> True,
1325 Subtype_Indication
=>
1326 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
1327 Append_To
(Decls
, Decl_ARECnPT
);
1329 -- ARECn : aliased ARECnT;
1332 Make_Object_Declaration
(Loc
,
1333 Defining_Identifier
=> STJ
.ARECn
,
1334 Aliased_Present
=> True,
1335 Object_Definition
=>
1336 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
1337 Append_To
(Decls
, Decl_ARECn
);
1339 -- ARECnP : constant ARECnPT := ARECn'Access;
1342 Make_Object_Declaration
(Loc
,
1343 Defining_Identifier
=> STJ
.ARECnP
,
1344 Constant_Present
=> True,
1345 Object_Definition
=>
1346 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
1348 Make_Attribute_Reference
(Loc
,
1350 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1351 Attribute_Name
=> Name_Access
));
1352 Append_To
(Decls
, Decl_ARECnP
);
1354 -- If we are in a subprogram that has a static link that
1355 -- is passed in (as indicated by ARECnF being defined),
1356 -- then generate ARECn.ARECmU := ARECmF where m is
1357 -- one less than the current level to set the uplink.
1359 if Present
(STJ
.ARECnF
) then
1361 Make_Assignment_Statement
(Loc
,
1363 Make_Selected_Component
(Loc
,
1365 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1367 New_Occurrence_Of
(STJ
.ARECnU
, Loc
)),
1369 New_Occurrence_Of
(STJ
.ARECnF
, Loc
));
1370 Append_To
(Decls
, Decl_Assign
);
1373 Decl_Assign
:= Empty
;
1376 Prepend_List_To
(Declarations
(STJ
.Bod
), Decls
);
1378 -- Analyze the newly inserted declarations. Note that we
1379 -- do not need to establish the whole scope stack, since
1380 -- we have already set all entity fields (so there will
1381 -- be no searching of upper scopes to resolve names). But
1382 -- we do set the scope of the current subprogram, so that
1383 -- newly created entities go in the right entity chain.
1385 -- We analyze with all checks suppressed (since we do
1386 -- not expect any exceptions).
1388 Push_Scope
(STJ
.Ent
);
1389 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
1391 -- Note that we need to call Set_Suppress_Initialization
1392 -- after Decl_ARECnT has been analyzed, but before
1393 -- analyzing Decl_ARECnP so that the flag is properly
1394 -- taking into account.
1396 Set_Suppress_Initialization
(STJ
.ARECnT
);
1398 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
1399 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
1400 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
1402 if Present
(Decl_Assign
) then
1403 Analyze
(Decl_Assign
, Suppress
=> All_Checks
);
1408 -- Next step, for each uplevel referenced entity, add
1409 -- assignment operations to set the component in the
1410 -- activation record.
1412 if Present
(STJ
.Uents
) then
1417 Elmt
:= First_Elmt
(STJ
.Uents
);
1418 while Present
(Elmt
) loop
1420 Ent
: constant Entity_Id
:= Node
(Elmt
);
1421 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
1422 Dec
: constant Node_Id
:=
1423 Declaration_Node
(Ent
);
1428 -- For parameters, we insert the assignment
1429 -- right after the declaration of ARECnP.
1430 -- For all other entities, we insert
1431 -- the assignment immediately after
1432 -- the declaration of the entity.
1434 -- Note: we don't need to mark the entity
1435 -- as being aliased, because the address
1436 -- attribute will mark it as Address_Taken,
1437 -- and that is good enough.
1439 if Is_Formal
(Ent
) then
1445 -- Build and insert the assignment:
1446 -- ARECn.nam := nam'Address
1449 Make_Assignment_Statement
(Loc
,
1451 Make_Selected_Component
(Loc
,
1453 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1456 (Activation_Record_Component
1461 Make_Attribute_Reference
(Loc
,
1463 New_Occurrence_Of
(Ent
, Loc
),
1464 Attribute_Name
=> Name_Address
));
1466 Insert_After
(Ins
, Asn
);
1468 -- Analyze the assignment statement. We do
1469 -- not need to establish the relevant scope
1470 -- stack entries here, because we have
1471 -- already set the correct entity references,
1472 -- so no name resolution is required, and no
1473 -- new entities are created, so we don't even
1474 -- need to set the current scope.
1476 -- We analyze with all checks suppressed
1477 -- (since we do not expect any exceptions).
1479 Analyze
(Asn
, Suppress
=> All_Checks
);
1492 -- Next step, process uplevel references. This has to be done in a
1493 -- separate pass, after completing the processing in Sub_Loop because we
1494 -- need all the AREC declarations generated, inserted, and analyzed so
1495 -- that the uplevel references can be successfully analyzed.
1497 Uplev_Refs
: for J
in Urefs
.First
.. Urefs
.Last
loop
1499 UPJ
: Uref_Entry
renames Urefs
.Table
(J
);
1502 -- Ignore type references, these are implicit references that do
1503 -- not need rewriting (e.g. the appearence in a conversion).
1505 if Is_Type
(UPJ
.Ent
) then
1509 -- Also ignore uplevel references to bounds of types that come
1510 -- from the original type reference.
1512 if Is_Entity_Name
(UPJ
.Ref
)
1513 and then Present
(Entity
(UPJ
.Ref
))
1514 and then Is_Type
(Entity
(UPJ
.Ref
))
1519 -- Rewrite one reference
1521 Rewrite_One_Ref
: declare
1522 Loc
: constant Source_Ptr
:= Sloc
(UPJ
.Ref
);
1523 -- Source location for the reference
1525 Typ
: constant Entity_Id
:= Etype
(UPJ
.Ent
);
1526 -- The type of the referenced entity
1528 Atyp
: constant Entity_Id
:= Get_Actual_Subtype
(UPJ
.Ref
);
1529 -- The actual subtype of the reference
1531 RS_Caller
: constant SI_Type
:= Subp_Index
(UPJ
.Caller
);
1532 -- Subp_Index for caller containing reference
1534 STJR
: Subp_Entry
renames Subps
.Table
(RS_Caller
);
1535 -- Subp_Entry for subprogram containing reference
1537 RS_Callee
: constant SI_Type
:= Subp_Index
(UPJ
.Callee
);
1538 -- Subp_Index for subprogram containing referenced entity
1540 STJE
: Subp_Entry
renames Subps
.Table
(RS_Callee
);
1541 -- Subp_Entry for subprogram containing referenced entity
1548 -- Ignore if no ARECnF entity for enclosing subprogram which
1549 -- probably happens as a result of not properly treating
1550 -- instance bodies. To be examined ???
1552 -- If this test is omitted, then the compilation of freeze.adb
1553 -- and inline.adb fail in unnesting mode.
1555 if No
(STJR
.ARECnF
) then
1559 -- Push the current scope, so that the pointer type Tnn, and
1560 -- any subsidiary entities resulting from the analysis of the
1561 -- rewritten reference, go in the right entity chain.
1563 Push_Scope
(STJR
.Ent
);
1565 -- Now we need to rewrite the reference. We have a reference
1566 -- from level STJR.Lev to level STJE.Lev. The general form of
1567 -- the rewritten reference for entity X is:
1569 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
1571 -- where a,b,c,d .. m =
1572 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
1574 pragma Assert
(STJR
.Lev
> STJE
.Lev
);
1576 -- Compute the prefix of X. Here are examples to make things
1577 -- clear (with parens to show groupings, the prefix is
1578 -- everything except the .X at the end).
1580 -- level 2 to level 1
1584 -- level 3 to level 1
1586 -- (AREC2F.AREC1U).X
1588 -- level 4 to level 1
1590 -- ((AREC3F.AREC2U).AREC1U).X
1592 -- level 6 to level 2
1594 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1596 -- In the above, ARECnF and ARECnU are pointers, so there are
1597 -- explicit dereferences required for these occurrences.
1600 Make_Explicit_Dereference
(Loc
,
1601 Prefix
=> New_Occurrence_Of
(STJR
.ARECnF
, Loc
));
1603 for L
in STJE
.Lev
.. STJR
.Lev
- 2 loop
1604 SI
:= Enclosing_Subp
(SI
);
1606 Make_Explicit_Dereference
(Loc
,
1608 Make_Selected_Component
(Loc
,
1611 New_Occurrence_Of
(Subps
.Table
(SI
).ARECnU
, Loc
)));
1614 -- Get activation record component (must exist)
1616 Comp
:= Activation_Record_Component
(UPJ
.Ent
);
1617 pragma Assert
(Present
(Comp
));
1619 -- Do the replacement
1622 Make_Attribute_Reference
(Loc
,
1623 Prefix
=> New_Occurrence_Of
(Atyp
, Loc
),
1624 Attribute_Name
=> Name_Deref
,
1625 Expressions
=> New_List
(
1626 Make_Selected_Component
(Loc
,
1629 New_Occurrence_Of
(Comp
, Loc
)))));
1631 -- Analyze and resolve the new expression. We do not need to
1632 -- establish the relevant scope stack entries here, because we
1633 -- have already set all the correct entity references, so no
1634 -- name resolution is needed. We have already set the current
1635 -- scope, so that any new entities created will be in the right
1638 -- We analyze with all checks suppressed (since we do not
1639 -- expect any exceptions)
1641 Analyze_And_Resolve
(UPJ
.Ref
, Typ
, Suppress
=> All_Checks
);
1643 end Rewrite_One_Ref
;
1648 end loop Uplev_Refs
;
1650 -- Finally, loop through all calls adding extra actual for the
1651 -- activation record where it is required.
1653 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
1655 -- Process a single call, we are only interested in a call to a
1656 -- subprogram that actually needs a pointer to an activation record,
1657 -- as indicated by the ARECnF entity being set. This excludes the
1658 -- top level subprogram, and any subprogram not having uplevel refs.
1660 Adjust_One_Call
: declare
1661 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1662 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Caller
));
1663 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Callee
));
1665 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
1673 if Present
(STT
.ARECnF
)
1674 and then Nkind
(CTJ
.N
) /= N_Attribute_Reference
1676 -- CTJ.N is a call to a subprogram which may require a pointer
1677 -- to an activation record. The subprogram containing the call
1678 -- is CTJ.From and the subprogram being called is CTJ.To, so we
1679 -- have a call from level STF.Lev to level STT.Lev.
1681 -- There are three possibilities:
1683 -- For a call to the same level, we just pass the activation
1684 -- record passed to the calling subprogram.
1686 if STF
.Lev
= STT
.Lev
then
1687 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1689 -- For a call that goes down a level, we pass a pointer to the
1690 -- activation record constructed within the caller (which may
1691 -- be the outer-level subprogram, but also may be a more deeply
1694 elsif STT
.Lev
= STF
.Lev
+ 1 then
1695 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
1697 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1698 -- since it is not possible to do a downcall of more than
1701 -- For a call from level STF.Lev to level STT.Lev, we
1702 -- have to find the activation record needed by the
1703 -- callee. This is as follows:
1705 -- ARECaF.ARECbU.ARECcU....ARECm
1707 -- where a,b,c .. m =
1708 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1711 pragma Assert
(STT
.Lev
< STF
.Lev
);
1713 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1714 SubX
:= Subp_Index
(CTJ
.Caller
);
1715 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
1716 SubX
:= Enclosing_Subp
(SubX
);
1718 Make_Selected_Component
(Loc
,
1722 (Subps
.Table
(SubX
).ARECnU
, Loc
));
1726 -- Extra is the additional parameter to be added. Build a
1727 -- parameter association that we can append to the actuals.
1730 Make_Parameter_Association
(Loc
,
1732 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
1733 Explicit_Actual_Parameter
=> Extra
);
1735 if No
(Parameter_Associations
(CTJ
.N
)) then
1736 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
1739 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
1741 -- We need to deal with the actual parameter chain as well. The
1742 -- newly added parameter is always the last actual.
1744 Act
:= First_Named_Actual
(CTJ
.N
);
1747 Set_First_Named_Actual
(CTJ
.N
, Extra
);
1749 -- Here we must follow the chain and append the new entry
1758 PAN
:= Parent
(Act
);
1759 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
1760 NNA
:= Next_Named_Actual
(PAN
);
1763 Set_Next_Named_Actual
(PAN
, Extra
);
1772 -- Analyze and resolve the new actual. We do not need to
1773 -- establish the relevant scope stack entries here, because
1774 -- we have already set all the correct entity references, so
1775 -- no name resolution is needed.
1777 -- We analyze with all checks suppressed (since we do not
1778 -- expect any exceptions, and also we temporarily turn off
1779 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1780 -- references (not needed at this stage, and in fact causes
1781 -- a bit of recursive chaos).
1783 Opt
.Unnest_Subprogram_Mode
:= False;
1785 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
1786 Opt
.Unnest_Subprogram_Mode
:= True;
1788 end Adjust_One_Call
;
1789 end loop Adjust_Calls
;
1792 end Unnest_Subprogram
;
1794 ------------------------
1795 -- Unnest_Subprograms --
1796 ------------------------
1798 procedure Unnest_Subprograms
(N
: Node_Id
) is
1799 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
;
1800 -- Tree visitor that search for outer level procedures with nested
1801 -- subprograms and invokes Unnest_Subprogram()
1803 ------------------------
1804 -- Search_Subprograms --
1805 ------------------------
1807 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
is
1809 if Nkind_In
(N
, N_Subprogram_Body
, N_Subprogram_Body_Stub
) then
1811 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
1814 -- We are only interested in subprograms (not generic
1815 -- subprograms), that have nested subprograms.
1817 if Is_Subprogram
(Spec_Id
)
1818 and then Has_Nested_Subprogram
(Spec_Id
)
1819 and then Is_Library_Level_Entity
(Spec_Id
)
1821 Unnest_Subprogram
(Spec_Id
, N
);
1827 end Search_Subprograms
;
1833 procedure Do_Search
is new Traverse_Proc
(Search_Subprograms
);
1834 -- Subtree visitor instantiation
1836 -- Start of processing for Unnest_Subprograms
1839 if not Opt
.Unnest_Subprogram_Mode
then
1844 end Unnest_Subprograms
;