1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-2015, 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 Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Exp_Util
; use Exp_Util
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Rtsfind
; use Rtsfind
;
36 with Sinput
; use Sinput
;
38 with Sem_Ch8
; use Sem_Ch8
;
39 with Sem_Mech
; use Sem_Mech
;
40 with Sem_Res
; use Sem_Res
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
45 with Tbuild
; use Tbuild
;
46 with Uintp
; use Uintp
;
48 package body Exp_Unst
is
50 -- Tables used by Unnest_Subprogram
52 type Subp_Entry
is record
54 -- Entity of the subprogram
57 -- Subprogram_Body node for this subprogram
60 -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested
61 -- immediately within this outer subprogram etc.)
64 -- This is a copy of the Uplevel_References field from the entity for
65 -- the subprogram. Copy this to reuse the field for Subps_Index.
68 -- This entity is defined for all subprograms with uplevel references
69 -- except for the top-level subprogram (Subp itself). It is the entity
70 -- for the formal which is added to the parameter list to pass the
71 -- pointer to the activation record. Note that for this entity, n is
72 -- one less than the current level.
78 -- These AREC entities are defined only for subprograms for which we
79 -- generate an activation record declaration, i.e. for subprograms
80 -- with at least one nested subprogram that have uplevel referennces.
81 -- They are set to Empty for all other cases.
84 -- This AREC entity is the uplink component. It is other than Empty only
85 -- for nested subprograms that themselves have nested subprograms and
86 -- have uplevel references. Note that the n here is one less than the
87 -- level of the subprogram defining the activation record.
91 subtype SI_Type
is Nat
;
93 package Subps
is new Table
.Table
(
94 Table_Component_Type
=> Subp_Entry
,
95 Table_Index_Type
=> SI_Type
,
98 Table_Increment
=> 200,
99 Table_Name
=> "Unnest_Subps");
100 -- Records the subprograms in the nest whose outer subprogram is Subp
102 type Call_Entry
is record
107 -- Entity of the subprogram containing the call
110 -- Entity of the subprogram called
113 package Calls
is new Table
.Table
(
114 Table_Component_Type
=> Call_Entry
,
115 Table_Index_Type
=> Nat
,
116 Table_Low_Bound
=> 1,
117 Table_Initial
=> 100,
118 Table_Increment
=> 200,
119 Table_Name
=> "Unnest_Calls");
120 -- Records each call within the outer subprogram and all nested subprograms
121 -- that are to other subprograms nested within the outer subprogram. These
122 -- are the calls that may need an additional parameter.
124 -------------------------------------
125 -- Check_Uplevel_Reference_To_Type --
126 -------------------------------------
128 procedure Check_Uplevel_Reference_To_Type
(Typ
: Entity_Id
) is
129 function Check_Dynamic_Type
(T
: Entity_Id
) return Boolean;
130 -- This is an internal recursive routine that checks if T or any of
131 -- its subsdidiary types are dynamic. If so, then the original Typ is
132 -- marked as having an uplevel reference, as is the subsidiary type in
133 -- question, and any referenced dynamic bounds are also marked as having
134 -- an uplevel reference, and True is returned. If the type is a static
135 -- type, then False is returned;
137 ------------------------
138 -- Check_Dynamic_Type --
139 ------------------------
141 function Check_Dynamic_Type
(T
: Entity_Id
) return Boolean is
142 DT
: Boolean := False;
145 -- If it's a static type, nothing to do
147 if Is_Static_Type
(T
) then
150 -- If the type is uplevel referenced, then it must be dynamic
152 elsif Has_Uplevel_Reference
(T
) then
153 Set_Has_Uplevel_Reference
(Typ
);
156 -- If the type is at library level, always consider it static, since
157 -- uplevel references do not matter in this case.
159 elsif Is_Library_Level_Entity
(T
) then
160 Set_Is_Static_Type
(T
);
163 -- Otherwise we need to figure out what the story is with this type
168 -- For a scalar type, check bounds
170 if Is_Scalar_Type
(T
) then
172 -- If both bounds static, then this is a static type
175 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
176 UB
: constant Node_Id
:= Type_High_Bound
(T
);
179 if not Is_Static_Expression
(LB
) then
180 Set_Has_Uplevel_Reference
(Entity
(LB
));
184 if not Is_Static_Expression
(UB
) then
185 Set_Has_Uplevel_Reference
(Entity
(UB
));
190 -- For record type, check all components
192 elsif Is_Record_Type
(T
) then
197 C
:= First_Component_Or_Discriminant
(T
);
198 while Present
(C
) loop
199 if Check_Dynamic_Type
(Etype
(C
)) then
203 Next_Component_Or_Discriminant
(C
);
207 -- For array type, check index types and component type
209 elsif Is_Array_Type
(T
) then
214 if Check_Dynamic_Type
(Component_Type
(T
)) then
218 IX
:= First_Index
(T
);
219 while Present
(IX
) loop
220 if Check_Dynamic_Type
(Etype
(IX
)) then
228 -- For now, ignore other types
234 -- See if we marked that type as dynamic
237 Set_Has_Uplevel_Reference
(T
);
238 Set_Has_Uplevel_Reference
(Typ
);
241 -- If not mark it as static
244 Set_Is_Static_Type
(T
);
248 end Check_Dynamic_Type
;
250 -- Start of processing for Check_Uplevel_Reference_To_Type
253 -- Nothing to do inside a generic (all processing is for instance)
255 if Inside_A_Generic
then
258 -- Nothing to do if we know this is a static type
260 elsif Is_Static_Type
(Typ
) then
263 -- Nothing to do if already marked as uplevel referenced
265 elsif Has_Uplevel_Reference
(Typ
) then
268 -- Otherwise check if we have a dynamic type
271 if Check_Dynamic_Type
(Typ
) then
272 Set_Has_Uplevel_Reference
(Typ
);
277 end Check_Uplevel_Reference_To_Type
;
279 ----------------------------
280 -- Note_Uplevel_Reference --
281 ----------------------------
283 procedure Note_Uplevel_Reference
(N
: Node_Id
; Subp
: Entity_Id
) is
287 -- Nothing to do inside a generic (all processing is for instance)
289 if Inside_A_Generic
then
293 -- Nothing to do if reference has no entity field
295 if Nkind
(N
) not in N_Has_Entity
then
299 -- Establish list if first call for Uplevel_References
301 if No
(Uplevel_References
(Subp
)) then
302 Set_Uplevel_References
(Subp
, New_Elmt_List
);
305 -- Ignore if node is already in the list. This is a bit inefficient,
306 -- but we can definitely get duplicates that cause trouble!
308 Elmt
:= First_Elmt
(Uplevel_References
(Subp
));
309 while Present
(Elmt
) loop
310 if N
= Node
(Elmt
) then
317 -- Add new entry to Uplevel_References. Each entry is two elements of
318 -- the list. The first is the actual reference, the second is the
319 -- enclosing subprogram at the point of reference
321 Append_Elmt
(N
, Uplevel_References
(Subp
));
323 if Is_Subprogram
(Current_Scope
) then
324 Append_Elmt
(Current_Scope
, Uplevel_References
(Subp
));
327 (Enclosing_Subprogram
(Current_Scope
), Uplevel_References
(Subp
));
330 Set_Has_Uplevel_Reference
(Entity
(N
));
331 Set_Has_Uplevel_Reference
(Subp
);
332 end Note_Uplevel_Reference
;
334 -----------------------
335 -- Unnest_Subprogram --
336 -----------------------
338 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
) is
339 function Actual_Ref
(N
: Node_Id
) return Node_Id
;
340 -- This function is applied to an element in the Uplevel_References
341 -- list, and it finds the actual reference. Often this is just N itself,
342 -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and
343 -- this function digs out the actual reference
345 function AREC_String
(Lev
: Pos
) return String;
346 -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
348 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
349 -- Subp is the index of a subprogram which has a Lev greater than 1.
350 -- This function returns the index of the enclosing subprogram which
351 -- will have a Lev value one less than this.
353 function Get_Level
(Sub
: Entity_Id
) return Nat
;
354 -- Sub is either Subp itself, or a subprogram nested within Subp. This
355 -- function returns the level of nesting (Subp = 1, subprograms that
356 -- are immediately nested within Subp = 2, etc).
358 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
;
359 -- Given the entity for a subprogram, return corresponding Subps index
365 function Actual_Ref
(N
: Node_Id
) return Node_Id
is
369 -- If we have an entity reference, then this is the actual ref
374 -- For a type conversion, go get the expression
376 when N_Type_Conversion
=>
377 return Expression
(N
);
379 -- For an explicit dereference, get the prefix
381 when N_Explicit_Dereference
=>
384 -- No other possibilities should exist
395 function AREC_String
(Lev
: Pos
) return String is
398 return AREC_String
(Lev
/ 10) & Character'Val (Lev
mod 10 + 48);
400 return "AREC" & Character'Val (Lev
+ 48);
408 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
409 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
410 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
412 pragma Assert
(STJ
.Lev
> 1);
413 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
421 function Get_Level
(Sub
: Entity_Id
) return Nat
is
432 S
:= Enclosing_Subprogram
(S
);
442 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
444 pragma Assert
(Is_Subprogram
(Sub
));
445 return SI_Type
(UI_To_Int
(Subps_Index
(Sub
)));
448 -- Start of processing for Unnest_Subprogram
451 -- Nothing to do inside a generic (all processing is for instance)
453 if Inside_A_Generic
then
456 -- At least for now, do not unnest anything but main source unit
458 if not In_Extended_Main_Source_Unit
(Subp_Body
) then
462 -- First step, we must mark all nested subprograms that require a static
463 -- link (activation record) because either they contain explicit uplevel
464 -- references (as indicated by Has_Uplevel_Reference being set at this
465 -- point), or they make calls to other subprograms in the same nest that
466 -- require a static link (in which case we set this flag).
468 -- This is a recursive definition, and to implement this, we have to
469 -- build a call graph for the set of nested subprograms, and then go
470 -- over this graph to implement recursively the invariant that if a
471 -- subprogram has a call to a subprogram requiring a static link, then
472 -- the calling subprogram requires a static link.
474 -- First populate the above tables
479 Build_Tables
: declare
480 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
481 -- Visit a single node in Subp
487 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
491 function Find_Current_Subprogram
return Entity_Id
;
492 -- Finds the current subprogram containing the call N
494 -----------------------------
495 -- Find_Current_Subprogram --
496 -----------------------------
498 function Find_Current_Subprogram
return Entity_Id
is
506 if Nkind
(Nod
) = N_Subprogram_Body
then
507 if Acts_As_Spec
(Nod
) then
508 return Defining_Entity
(Specification
(Nod
));
510 return Corresponding_Spec
(Nod
);
514 end Find_Current_Subprogram
;
516 -- Start of processing for Visit_Node
521 if Nkind_In
(N
, N_Procedure_Call_Statement
, N_Function_Call
)
523 -- We are only interested in direct calls, not indirect calls
524 -- (where Name (N) is an explicit dereference) at least for now!
526 and then Nkind
(Name
(N
)) in N_Has_Entity
528 Ent
:= Entity
(Name
(N
));
530 -- We are only interested in calls to subprograms nested
531 -- within Subp. Calls to Subp itself or to subprograms that
532 -- are outside the nested structure do not affect us.
534 if Scope_Within
(Ent
, Subp
) then
536 -- For now, ignore calls to generic instances. Seems to be
537 -- some problem there which we will investigate later ???
539 if Original_Location
(Sloc
(Ent
)) /= Sloc
(Ent
)
540 or else Is_Generic_Instance
(Ent
)
544 -- Ignore calls to imported routines
546 elsif Is_Imported
(Ent
) then
549 -- Here we have a call to keep and analyze
552 Csub
:= Find_Current_Subprogram
;
554 -- Both caller and callee must be subprograms (we ignore
555 -- generic subprograms).
557 if Is_Subprogram
(Csub
) and then Is_Subprogram
(Ent
) then
558 Calls
.Append
((N
, Find_Current_Subprogram
, Ent
));
563 -- Record a subprogram. We record a subprogram body that acts as
564 -- a spec. Otherwise we record a subprogram declaration, providing
565 -- that it has a corresponding body we can get hold of. The case
566 -- of no corresponding body being available is ignored for now.
568 elsif (Nkind
(N
) = N_Subprogram_Body
and then Acts_As_Spec
(N
))
569 or else (Nkind
(N
) = N_Subprogram_Declaration
570 and then Present
(Corresponding_Body
(N
)))
572 Subps
.Increment_Last
;
575 STJ
: Subp_Entry
renames Subps
.Table
(Subps
.Last
);
578 -- Set fields of Subp_Entry for new subprogram
580 STJ
.Ent
:= Defining_Entity
(Specification
(N
));
581 STJ
.Lev
:= Get_Level
(STJ
.Ent
);
583 if Nkind
(N
) = N_Subprogram_Body
then
587 Parent
(Declaration_Node
(Corresponding_Body
(N
)));
588 pragma Assert
(Nkind
(STJ
.Bod
) = N_Subprogram_Body
);
591 -- Capture Uplevel_References, and then set (uses the same
592 -- field), the Subps_Index value for this subprogram.
594 STJ
.Urefs
:= Uplevel_References
(STJ
.Ent
);
595 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(Int
(Subps
.Last
)));
606 procedure Visit
is new Traverse_Proc
(Visit_Node
);
607 -- Used to traverse the body of Subp, populating the tables
609 -- Start of processing for Build_Tables
612 -- A special case, if the outer level subprogram has a separate spec
613 -- then we won't catch it in the traversal of the body. But we do
614 -- want to visit the declaration in this case!
616 if not Acts_As_Spec
(Subp_Body
) then
618 Dummy
: Traverse_Result
;
619 Decl
: constant Node_Id
:=
620 Parent
(Declaration_Node
(Corresponding_Spec
(Subp_Body
)));
621 pragma Assert
(Nkind
(Decl
) = N_Subprogram_Declaration
);
623 Dummy
:= Visit_Node
(Decl
);
627 -- Traverse the body to get the rest of the subprograms and calls
632 -- Second step is to do the transitive closure, if any subprogram has
633 -- a call to a subprogram for which Has_Uplevel_Reference is set, then
634 -- we set Has_Uplevel_Reference for the calling routine.
640 -- We use a simple minded algorithm as follows (obviously this can
641 -- be done more efficiently, using one of the standard algorithms
642 -- for efficient transitive closure computation, but this is simple
643 -- and most likely fast enough that its speed does not matter).
645 -- Repeatedly scan the list of calls. Any time we find a call from
646 -- A to B, where A does not have Has_Uplevel_Reference, and B does
647 -- have this flag set, then set the flag for A, and note that we
648 -- have made a change by setting Modified True. We repeat this until
649 -- we make a pass with no modifications.
653 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
654 if not Has_Uplevel_Reference
(Calls
.Table
(J
).From
)
655 and then Has_Uplevel_Reference
(Calls
.Table
(J
).To
)
657 Set_Has_Uplevel_Reference
(Calls
.Table
(J
).From
);
662 exit Outer
when not Modified
;
666 -- Next step, create the entities for code we will insert. We do this
667 -- at the start so that all the entities are defined, regardless of the
668 -- order in which we do the code insertions.
670 Create_Entities
: for J
in Subps
.First
.. Subps
.Last
loop
672 STJ
: Subp_Entry
renames Subps
.Table
(J
);
673 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
674 ARS
: constant String := AREC_String
(STJ
.Lev
);
677 -- First we create the ARECnF entity for the additional formal
678 -- for all subprograms requiring that an activation record pointer
679 -- be passed. This is true of all subprograms that have uplevel
680 -- references, and whose enclosing subprogram also has uplevel
683 if Has_Uplevel_Reference
(STJ
.Ent
)
684 and then STJ
.Ent
/= Subp
685 and then Has_Uplevel_Reference
(Enclosing_Subprogram
(STJ
.Ent
))
688 Make_Defining_Identifier
(Loc
,
689 Chars
=> Name_Find_Str
(AREC_String
(STJ
.Lev
- 1) & "F"));
694 -- Now define the AREC entities for the activation record. This
695 -- is needed for any subprogram that has nested subprograms and
696 -- has uplevel references.
698 if Has_Nested_Subprogram
(STJ
.Ent
)
699 and then Has_Uplevel_Reference
(STJ
.Ent
)
702 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
));
704 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "T"));
706 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "PT"));
708 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "P"));
713 STJ
.ARECnPT
:= Empty
;
718 -- Define uplink component entity if inner nesting case
720 if Has_Uplevel_Reference
(STJ
.Ent
) and then STJ
.Lev
> 1 then
722 ARS1
: constant String := AREC_String
(STJ
.Lev
- 1);
725 Make_Defining_Identifier
(Loc
,
726 Chars
=> Name_Find_Str
(ARS1
& "U"));
733 end loop Create_Entities
;
735 -- Loop through subprograms
738 Addr
: constant Entity_Id
:= RTE
(RE_Address
);
741 for J
in Subps
.First
.. Subps
.Last
loop
743 STJ
: Subp_Entry
renames Subps
.Table
(J
);
746 -- First add the extra formal if needed. This applies to all
747 -- nested subprograms that require an activation record to be
748 -- passed, as indicated by ARECnF being defined.
750 if Present
(STJ
.ARECnF
) then
752 -- Here we need the extra formal. We do the expansion and
753 -- analysis of this manually, since it is fairly simple,
754 -- and it is not obvious how we can get what we want if we
755 -- try to use the normal Analyze circuit.
757 Add_Extra_Formal
: declare
758 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
759 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
760 -- Index and Subp_Entry for enclosing routine
762 Form
: constant Entity_Id
:= STJ
.ARECnF
;
763 -- The formal to be added. Note that n here is one less
764 -- than the level of the subprogram itself (STJ.Ent).
766 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
767 -- S is an N_Function/Procedure_Specification node, and F
768 -- is the new entity to add to this subprogramn spec as
769 -- the last Extra_Formal.
771 ----------------------
772 -- Add_Form_To_Spec --
773 ----------------------
775 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
776 Sub
: constant Entity_Id
:= Defining_Entity
(S
);
780 -- Case of at least one Extra_Formal is present, set
781 -- ARECnF as the new last entry in the list.
783 if Present
(Extra_Formals
(Sub
)) then
784 Ent
:= Extra_Formals
(Sub
);
785 while Present
(Extra_Formal
(Ent
)) loop
786 Ent
:= Extra_Formal
(Ent
);
789 Set_Extra_Formal
(Ent
, F
);
791 -- No Extra formals present
794 Set_Extra_Formals
(Sub
, F
);
795 Ent
:= Last_Formal
(Sub
);
797 if Present
(Ent
) then
798 Set_Extra_Formal
(Ent
, F
);
801 end Add_Form_To_Spec
;
803 -- Start of processing for Add_Extra_Formal
806 -- Decorate the new formal entity
808 Set_Scope
(Form
, STJ
.Ent
);
809 Set_Ekind
(Form
, E_In_Parameter
);
810 Set_Etype
(Form
, STJE
.ARECnPT
);
811 Set_Mechanism
(Form
, By_Copy
);
812 Set_Never_Set_In_Source
(Form
, True);
813 Set_Analyzed
(Form
, True);
814 Set_Comes_From_Source
(Form
, False);
816 -- Case of only body present
818 if Acts_As_Spec
(STJ
.Bod
) then
819 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
821 -- Case of separate spec
824 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
826 end Add_Extra_Formal
;
829 -- Processing for subprograms that have at least one nested
830 -- subprogram, and have uplevel references.
832 if Has_Nested_Subprogram
(STJ
.Ent
)
833 and then Has_Uplevel_Reference
(STJ
.Ent
)
835 -- Local declarations for one such subprogram
838 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
845 Decl_ARECnT
: Node_Id
;
846 Decl_ARECn
: Node_Id
;
847 Decl_ARECnPT
: Node_Id
;
848 Decl_ARECnP
: Node_Id
;
849 -- Declaration nodes for the AREC entities we build
852 array (1 .. List_Length
(STJ
.Urefs
)) of Entity_Id
;
853 Num_Uplevel_Entities
: Nat
;
854 -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains
855 -- a list (with no duplicates) of the entities for this
856 -- subprogram that are referenced uplevel. The maximum
857 -- number of entries cannot exceed the total number of
858 -- uplevel references.
861 -- Populate the Uplevel_Entities array, using the flag
862 -- Uplevel_Reference_Noted to avoid duplicates.
864 Num_Uplevel_Entities
:= 0;
866 if Present
(STJ
.Urefs
) then
867 Elmt
:= First_Elmt
(STJ
.Urefs
);
868 while Present
(Elmt
) loop
869 Nod
:= Actual_Ref
(Node
(Elmt
));
872 if not Uplevel_Reference_Noted
(Ent
) then
873 Set_Uplevel_Reference_Noted
(Ent
, True);
874 Num_Uplevel_Entities
:= Num_Uplevel_Entities
+ 1;
875 Uplevel_Entities
(Num_Uplevel_Entities
) := Ent
;
883 -- Build list of component declarations for ARECnT
887 -- If we are in a subprogram that has a static link that
888 -- ias passed in (as indicated by ARECnF being deinfed),
889 -- then include ARECnU : ARECnPT := ARECnF where n is
890 -- one less than the current level and the entity ARECnPT
891 -- comes from the enclosing subprogram.
893 if Present
(STJ
.ARECnF
) then
896 renames Subps
.Table
(Enclosing_Subp
(J
));
900 Make_Component_Declaration
(Loc
,
901 Defining_Identifier
=> STJ
.ARECnU
,
902 Component_Definition
=>
903 Make_Component_Definition
(Loc
,
904 Subtype_Indication
=>
905 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
)),
907 New_Occurrence_Of
(STJ
.ARECnF
, Loc
)));
911 -- Add components for uplevel referenced entities
913 for J
in 1 .. Num_Uplevel_Entities
loop
915 Make_Defining_Identifier
(Loc
,
916 Chars
=> Chars
(Uplevel_Entities
(J
)));
918 Set_Activation_Record_Component
919 (Uplevel_Entities
(J
), Comp
);
922 Make_Component_Declaration
(Loc
,
923 Defining_Identifier
=> Comp
,
924 Component_Definition
=>
925 Make_Component_Definition
(Loc
,
926 Subtype_Indication
=>
927 New_Occurrence_Of
(Addr
, Loc
))));
930 -- Now we can insert the AREC declarations into the body
932 -- type ARECnT is record .. end record;
935 Make_Full_Type_Declaration
(Loc
,
936 Defining_Identifier
=> STJ
.ARECnT
,
938 Make_Record_Definition
(Loc
,
940 Make_Component_List
(Loc
,
941 Component_Items
=> Clist
)));
943 -- ARECn : aliased ARECnT;
946 Make_Object_Declaration
(Loc
,
947 Defining_Identifier
=> STJ
.ARECn
,
948 Aliased_Present
=> True,
950 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
952 -- type ARECnPT is access all ARECnT;
955 Make_Full_Type_Declaration
(Loc
,
956 Defining_Identifier
=> STJ
.ARECnPT
,
958 Make_Access_To_Object_Definition
(Loc
,
960 Subtype_Indication
=>
961 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
963 -- ARECnP : constant ARECnPT := ARECn'Access;
966 Make_Object_Declaration
(Loc
,
967 Defining_Identifier
=> STJ
.ARECnP
,
968 Constant_Present
=> True,
970 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
972 Make_Attribute_Reference
(Loc
,
974 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
975 Attribute_Name
=> Name_Access
));
977 Prepend_List_To
(Declarations
(STJ
.Bod
),
979 (Decl_ARECnT
, Decl_ARECn
, Decl_ARECnPT
, Decl_ARECnP
));
981 -- Analyze the newly inserted declarations. Note that we
982 -- do not need to establish the whole scope stack, since
983 -- we have already set all entity fields (so there will
984 -- be no searching of upper scopes to resolve names). But
985 -- we do set the scope of the current subprogram, so that
986 -- newly created entities go in the right entity chain.
988 -- We analyze with all checks suppressed (since we do
989 -- not expect any exceptions, and also we temporarily
990 -- turn off Unested_Subprogram_Mode to avoid trying to
991 -- mark uplevel references (not needed at this stage,
992 -- and in fact causes a bit of recursive chaos).
994 Push_Scope
(STJ
.Ent
);
995 Opt
.Unnest_Subprogram_Mode
:= False;
996 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
997 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
998 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
999 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
1000 Opt
.Unnest_Subprogram_Mode
:= True;
1003 -- Next step, for each uplevel referenced entity, add
1004 -- assignment operations to set the comoponent in the
1005 -- activation record.
1007 for J
in 1 .. Num_Uplevel_Entities
loop
1009 Ent
: constant Entity_Id
:= Uplevel_Entities
(J
);
1010 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
1011 Dec
: constant Node_Id
:= Declaration_Node
(Ent
);
1016 -- For parameters, we insert the assignment right
1017 -- after the declaration of ARECnP. For all other
1018 -- entities, we insert the assignment immediately
1019 -- after the declaration of the entity.
1021 -- Note: we don't need to mark the entity as being
1022 -- aliased, because the address attribute will mark
1023 -- it as Address_Taken, and that is good enough.
1025 if Is_Formal
(Ent
) then
1031 -- Build and insert the assignment:
1035 Make_Assignment_Statement
(Loc
,
1037 Make_Selected_Component
(Loc
,
1039 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1041 Make_Identifier
(Loc
, Chars
(Ent
))),
1044 Make_Attribute_Reference
(Loc
,
1046 New_Occurrence_Of
(Ent
, Loc
),
1047 Attribute_Name
=> Name_Address
));
1049 Insert_After
(Ins
, Asn
);
1051 -- Analyze the assignment statement. We do not need
1052 -- to establish the relevant scope stack entries
1053 -- here, because we have already set the correct
1054 -- entity references, so no name resolution is
1055 -- required, and no new entities are created, so
1056 -- we don't even need to set the current scope.
1058 -- We analyze with all checks suppressed (since
1059 -- we do not expect any exceptions, and also we
1060 -- temporarily turn off Unested_Subprogram_Mode
1061 -- to avoid trying to mark uplevel references (not
1062 -- needed at this stage, and in fact causes a bit
1063 -- of recursive chaos).
1065 Opt
.Unnest_Subprogram_Mode
:= False;
1066 Analyze
(Asn
, Suppress
=> All_Checks
);
1067 Opt
.Unnest_Subprogram_Mode
:= True;
1076 -- Next step, process uplevel references. This has to be done in a
1077 -- separate pass, after completing the processing in Sub_Loop because we
1078 -- need all the AREC declarations generated, inserted, and analyzed so
1079 -- that the uplevel references can be successfully analyzed.
1081 Uplev_Refs
: for J
in Subps
.First
.. Subps
.Last
loop
1083 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1086 -- We are only interested in entries which have uplevel references
1087 -- to deal with, as indicated by the Urefs list being present
1089 if Present
(STJ
.Urefs
) then
1091 -- Process uplevel references for one subprogram
1097 -- Loop through uplevel references
1099 Elmt
:= First_Elmt
(STJ
.Urefs
);
1100 while Present
(Elmt
) loop
1102 -- Rewrite one reference
1105 Ref
: constant Node_Id
:= Actual_Ref
(Node
(Elmt
));
1106 -- The reference to be rewritten
1108 Loc
: constant Source_Ptr
:= Sloc
(Ref
);
1109 -- Source location for the reference
1111 Ent
: constant Entity_Id
:= Entity
(Ref
);
1112 -- The referenced entity
1114 Typ
: constant Entity_Id
:= Etype
(Ent
);
1115 -- The type of the referenced entity
1117 Rsub
: constant Entity_Id
:=
1118 Node
(Next_Elmt
(Elmt
));
1119 -- The enclosing subprogram for the reference
1121 RSX
: constant SI_Type
:= Subp_Index
(Rsub
);
1122 -- Subp_Index for enclosing subprogram for ref
1124 STJR
: Subp_Entry
renames Subps
.Table
(RSX
);
1125 -- Subp_Entry for enclosing subprogram for ref
1127 Tnn
: constant Entity_Id
:=
1129 (Loc
, 'T', Related_Node
=> Ref
);
1130 -- Local pointer type for reference
1137 -- Push the current scope, so that the pointer type
1138 -- Tnn, and any subsidiary entities resulting from
1139 -- the analysis of the rewritten reference, go in the
1140 -- right entity chain.
1142 Push_Scope
(STJR
.Ent
);
1144 -- First insert declaration for pointer type
1146 -- type Tnn is access all typ;
1148 Insert_Action
(Node
(Elmt
),
1149 Make_Full_Type_Declaration
(Loc
,
1150 Defining_Identifier
=> Tnn
,
1152 Make_Access_To_Object_Definition
(Loc
,
1153 All_Present
=> True,
1154 Subtype_Indication
=>
1155 New_Occurrence_Of
(Typ
, Loc
))));
1157 -- Now we need to rewrite the reference. We have a
1158 -- reference is from level STJE.Lev to level STJ.Lev.
1159 -- The general form of the rewritten reference for
1162 -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X).all
1164 -- where a,b,c,d .. m =
1165 -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev
1167 pragma Assert
(STJR
.Lev
> STJ
.Lev
);
1169 -- Compute the prefix of X. Here are examples to make
1170 -- things clear (with parens to show groupings, the
1171 -- prefix is everything except the .X at the end).
1173 -- level 2 to level 1
1177 -- level 3 to level 1
1179 -- (AREC2F.AREC1U).X
1181 -- level 4 to level 1
1183 -- ((AREC3F.AREC2U).AREC1U).X
1185 -- level 6 to level 2
1187 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1189 Pfx
:= New_Occurrence_Of
(STJR
.ARECnF
, Loc
);
1191 for L
in STJ
.Lev
.. STJR
.Lev
- 2 loop
1192 SI
:= Enclosing_Subp
(SI
);
1194 Make_Selected_Component
(Loc
,
1198 (Subps
.Table
(SI
).ARECnU
, Loc
));
1201 -- Get activation record component (must exist)
1203 Comp
:= Activation_Record_Component
(Ent
);
1204 pragma Assert
(Present
(Comp
));
1206 -- Do the replacement
1209 Make_Explicit_Dereference
(Loc
,
1211 Unchecked_Convert_To
(Tnn
,
1212 Make_Selected_Component
(Loc
,
1215 New_Occurrence_Of
(Comp
, Loc
)))));
1217 -- Analyze and resolve the new expression. We do not
1218 -- need to establish the relevant scope stack entries
1219 -- here, because we have already set all the correct
1220 -- entity references, so no name resolution is needed.
1221 -- We have already set the current scope, so that any
1222 -- new entities created will be in the right scope.
1224 -- We analyze with all checks suppressed (since we do
1225 -- not expect any exceptions, and also we temporarily
1226 -- turn off Unested_Subprogram_Mode to avoid trying to
1227 -- mark uplevel references (not needed at this stage,
1228 -- and in fact causes a bit of recursive chaos).
1230 Opt
.Unnest_Subprogram_Mode
:= False;
1231 Analyze_And_Resolve
(Ref
, Typ
, Suppress
=> All_Checks
);
1232 Opt
.Unnest_Subprogram_Mode
:= True;
1242 end loop Uplev_Refs
;
1244 -- Finally, loop through all calls adding extra actual for the
1245 -- activation record where it is required.
1247 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
1249 -- Process a single call, we are only interested in a call to a
1250 -- subprogram that actually needs a pointer to an activation record,
1251 -- as indicated by the ARECnF entity being set. This excludes the
1252 -- top level subprogram, and any subprogram not having uplevel refs.
1254 Adjust_One_Call
: declare
1255 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1256 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.From
));
1257 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.To
));
1259 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
1267 if Present
(STT
.ARECnF
) then
1269 -- CTJ.N is a call to a subprogram which may require
1270 -- a pointer to an activation record. The subprogram
1271 -- containing the call is CTJ.From and the subprogram being
1272 -- called is CTJ.To, so we have a call from level STF.Lev to
1275 -- There are three possibilities:
1277 -- For a call to the same level, we just pass the activation
1278 -- record passed to the calling subprogram.
1280 if STF
.Lev
= STT
.Lev
then
1281 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1283 -- For a call that goes down a level, we pass a pointer
1284 -- to the activation record constructed wtihin the caller
1285 -- (which may be the outer level subprogram, but also may
1286 -- be a more deeply nested caller).
1288 elsif STT
.Lev
= STF
.Lev
+ 1 then
1289 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
1291 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1292 -- since it is not possible to do a downcall of more than
1295 -- For a call from level STF.Lev to level STT.Lev, we
1296 -- have to find the activation record needed by the
1297 -- callee. This is as follows:
1299 -- ARECaF.ARECbU.ARECcU....ARECm
1301 -- where a,b,c .. m =
1302 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1305 pragma Assert
(STT
.Lev
< STF
.Lev
);
1307 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1308 SubX
:= Subp_Index
(CTJ
.From
);
1309 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
1310 SubX
:= Enclosing_Subp
(SubX
);
1312 Make_Selected_Component
(Loc
,
1316 (Subps
.Table
(SubX
).ARECnU
, Loc
));
1320 -- Extra is the additional parameter to be added. Build a
1321 -- parameter association that we can append to the actuals.
1324 Make_Parameter_Association
(Loc
,
1326 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
1327 Explicit_Actual_Parameter
=> Extra
);
1329 if No
(Parameter_Associations
(CTJ
.N
)) then
1330 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
1333 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
1335 -- We need to deal with the actual parameter chain as well.
1336 -- The newly added parameter is always the last actual.
1338 Act
:= First_Named_Actual
(CTJ
.N
);
1341 Set_First_Named_Actual
(CTJ
.N
, Extra
);
1343 -- Here we must follow the chain and append the new entry
1352 PAN
:= Parent
(Act
);
1353 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
1354 NNA
:= Next_Named_Actual
(PAN
);
1357 Set_Next_Named_Actual
(PAN
, Extra
);
1366 -- Analyze and resolve the new actual. We do not need to
1367 -- establish the relevant scope stack entries here, because
1368 -- we have already set all the correct entity references, so
1369 -- no name resolution is needed.
1371 -- We analyze with all checks suppressed (since we do not
1372 -- expect any exceptions, and also we temporarily turn off
1373 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1374 -- references (not needed at this stage, and in fact causes
1375 -- a bit of recursive chaos).
1377 Opt
.Unnest_Subprogram_Mode
:= False;
1379 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
1380 Opt
.Unnest_Subprogram_Mode
:= True;
1382 end Adjust_One_Call
;
1383 end loop Adjust_Calls
;
1386 end Unnest_Subprogram
;