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 -- Otherwise we need to figure out what the story is with this type
161 -- For a scalar type, check bounds
163 if Is_Scalar_Type
(T
) then
165 -- If both bounds static, then this is a static type
168 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
169 UB
: constant Node_Id
:= Type_High_Bound
(T
);
172 if not Is_Static_Expression
(LB
) then
173 Set_Has_Uplevel_Reference
(Entity
(LB
));
177 if not Is_Static_Expression
(UB
) then
178 Set_Has_Uplevel_Reference
(Entity
(UB
));
183 -- For record type, check all components
185 elsif Is_Record_Type
(T
) then
190 C
:= First_Component_Or_Discriminant
(T
);
191 while Present
(C
) loop
192 if Check_Dynamic_Type
(Etype
(C
)) then
196 Next_Component_Or_Discriminant
(C
);
200 -- For array type, check index types and component type
202 elsif Is_Array_Type
(T
) then
207 if Check_Dynamic_Type
(Component_Type
(T
)) then
211 IX
:= First_Index
(T
);
212 while Present
(IX
) loop
213 if Check_Dynamic_Type
(Etype
(IX
)) then
221 -- For now, ignore other types
227 -- See if we marked that type as dynamic
230 Set_Has_Uplevel_Reference
(T
);
231 Set_Has_Uplevel_Reference
(Typ
);
234 -- If not mark it as static
237 Set_Is_Static_Type
(T
);
241 end Check_Dynamic_Type
;
243 -- Start of processing for Check_Uplevel_Reference_To_Type
246 -- Nothing to do if we know this is a static type
248 if Is_Static_Type
(Typ
) then
251 -- Nothing to do if already marked as uplevel referenced
253 elsif Has_Uplevel_Reference
(Typ
) then
256 -- Otherwise check if we have a dynamic type
259 if Check_Dynamic_Type
(Typ
) then
260 Set_Has_Uplevel_Reference
(Typ
);
265 end Check_Uplevel_Reference_To_Type
;
267 ----------------------------
268 -- Note_Uplevel_Reference --
269 ----------------------------
271 procedure Note_Uplevel_Reference
(N
: Node_Id
; Subp
: Entity_Id
) is
273 -- Nothing to do if reference has no entity field
275 if Nkind
(N
) not in N_Entity
then
279 -- Establish list if first call for Uplevel_References
281 if No
(Uplevel_References
(Subp
)) then
282 Set_Uplevel_References
(Subp
, New_Elmt_List
);
285 -- Add new entry to Uplevel_References. Each entry is two elements of
286 -- the list. The first is the actual reference, the second is the
287 -- enclosing subprogram at the point of reference
289 Append_Elmt
(N
, Uplevel_References
(Subp
));
291 if Is_Subprogram
(Current_Scope
) then
292 Append_Elmt
(Current_Scope
, Uplevel_References
(Subp
));
295 (Enclosing_Subprogram
(Current_Scope
), Uplevel_References
(Subp
));
298 Set_Has_Uplevel_Reference
(Entity
(N
));
299 Set_Has_Uplevel_Reference
(Subp
);
300 end Note_Uplevel_Reference
;
302 -----------------------
303 -- Unnest_Subprogram --
304 -----------------------
306 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
) is
307 function AREC_String
(Lev
: Pos
) return String;
308 -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
310 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
311 -- Subp is the index of a subprogram which has a Lev greater than 1.
312 -- This function returns the index of the enclosing subprogram which
313 -- will have a Lev value one less than this.
315 function Get_Level
(Sub
: Entity_Id
) return Nat
;
316 -- Sub is either Subp itself, or a subprogram nested within Subp. This
317 -- function returns the level of nesting (Subp = 1, subprograms that
318 -- are immediately nested within Subp = 2, etc).
320 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
;
321 -- Given the entity for a subprogram, return corresponding Subps index
327 function AREC_String
(Lev
: Pos
) return String is
331 AREC_String
(Lev
/ 10) & Character'Val (Lev
mod 10 + 48);
334 "AREC" & Character'Val (Lev
+ 48);
342 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
343 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
344 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
346 pragma Assert
(STJ
.Lev
> 1);
347 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
355 function Get_Level
(Sub
: Entity_Id
) return Nat
is
366 S
:= Enclosing_Subprogram
(S
);
376 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
378 pragma Assert
(Is_Subprogram
(Sub
));
379 return SI_Type
(UI_To_Int
(Subps_Index
(Sub
)));
382 -- Start of processing for Unnest_Subprogram
385 -- At least for now, do not unnest anything but main source unit
387 if not In_Extended_Main_Source_Unit
(Subp_Body
) then
391 -- First step, we must mark all nested subprograms that require a static
392 -- link (activation record) because either they contain explicit uplevel
393 -- references (as indicated by Has_Uplevel_Reference being set at this
394 -- point), or they make calls to other subprograms in the same nest that
395 -- require a static link (in which case we set this flag).
397 -- This is a recursive definition, and to implement this, we have to
398 -- build a call graph for the set of nested subprograms, and then go
399 -- over this graph to implement recursively the invariant that if a
400 -- subprogram has a call to a subprogram requiring a static link, then
401 -- the calling subprogram requires a static link.
403 -- First populate the above tables
408 Build_Tables
: declare
409 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
410 -- Visit a single node in Subp
416 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
420 function Find_Current_Subprogram
return Entity_Id
;
421 -- Finds the current subprogram containing the call N
423 -----------------------------
424 -- Find_Current_Subprogram --
425 -----------------------------
427 function Find_Current_Subprogram
return Entity_Id
is
435 if Nkind
(Nod
) = N_Subprogram_Body
then
436 if Acts_As_Spec
(Nod
) then
437 return Defining_Unit_Name
(Specification
(Nod
));
439 return Corresponding_Spec
(Nod
);
443 end Find_Current_Subprogram
;
445 -- Start of processing for Visit_Node
450 if Nkind_In
(N
, N_Procedure_Call_Statement
, N_Function_Call
)
452 -- We are only interested in direct calls, not indirect calls
453 -- (where Name (N) is an explicit dereference) at least for now!
455 and then Nkind
(Name
(N
)) in N_Has_Entity
457 Ent
:= Entity
(Name
(N
));
459 -- We are only interested in calls to subprograms nested
460 -- within Subp. Calls to Subp itself or to subprograms that
461 -- are outside the nested structure do not affect us.
463 if Scope_Within
(Ent
, Subp
) then
465 -- For now, ignore calls to generic instances. Seems to be
466 -- some problem there which we will investigate later ???
468 if Original_Location
(Sloc
(Ent
)) /= Sloc
(Ent
)
469 or else Is_Generic_Instance
(Ent
)
473 -- Here we have a call to keep and analyze
476 Csub
:= Find_Current_Subprogram
;
478 -- Both caller and callee must be subprograms (we ignore
479 -- generic subprograms).
481 if Is_Subprogram
(Csub
) and then Is_Subprogram
(Ent
) then
482 Calls
.Append
((N
, Find_Current_Subprogram
, Ent
));
487 -- Record a subprogram. We record a subprogram body that acts as
488 -- a spec. Otherwise we record a subprogram declaration, providing
489 -- that it has a corresponding body we can get hold of. The case
490 -- of no corresponding body being available is ignored for now.
492 elsif (Nkind
(N
) = N_Subprogram_Body
and then Acts_As_Spec
(N
))
493 or else (Nkind
(N
) = N_Subprogram_Declaration
494 and then Present
(Corresponding_Body
(N
)))
496 Subps
.Increment_Last
;
499 STJ
: Subp_Entry
renames Subps
.Table
(Subps
.Last
);
502 -- Set fields of Subp_Entry for new subprogram
504 STJ
.Ent
:= Defining_Unit_Name
(Specification
(N
));
505 STJ
.Lev
:= Get_Level
(STJ
.Ent
);
507 if Nkind
(N
) = N_Subprogram_Body
then
510 STJ
.Bod
:= Parent
(Parent
(Corresponding_Body
(N
)));
512 pragma Assert
(Nkind
(STJ
.Bod
) = N_Subprogram_Body
);
515 -- Capture Uplevel_References, and then set (uses the same
516 -- field), the Subps_Index value for this subprogram.
518 STJ
.Urefs
:= Uplevel_References
(STJ
.Ent
);
519 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(Int
(Subps
.Last
)));
530 procedure Visit
is new Traverse_Proc
(Visit_Node
);
531 -- Used to traverse the body of Subp, populating the tables
533 -- Start of processing for Build_Tables
536 -- A special case, if the outer level subprogram has a separate spec
537 -- then we won't catch it in the traversal of the body. But we do
538 -- want to visit the declaration in this case!
540 if not Acts_As_Spec
(Subp_Body
) then
542 Dummy
: Traverse_Result
;
543 Decl
: constant Node_Id
:=
544 Parent
(Declaration_Node
(Corresponding_Spec
(Subp_Body
)));
545 pragma Assert
(Nkind
(Decl
) = N_Subprogram_Declaration
);
547 Dummy
:= Visit_Node
(Decl
);
551 -- Traverse the body to get the rest of the subprograms and calls
556 -- Second step is to do the transitive closure, if any subprogram has
557 -- a call to a subprogram for which Has_Uplevel_Reference is set, then
558 -- we set Has_Uplevel_Reference for the calling routine.
564 -- We use a simple minded algorithm as follows (obviously this can
565 -- be done more efficiently, using one of the standard algorithms
566 -- for efficient transitive closure computation, but this is simple
567 -- and most likely fast enough that its speed does not matter).
569 -- Repeatedly scan the list of calls. Any time we find a call from
570 -- A to B, where A does not have Has_Uplevel_Reference, and B does
571 -- have this flag set, then set the flag for A, and note that we
572 -- have made a change by setting Modified True. We repeat this until
573 -- we make a pass with no modifications.
577 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
578 if not Has_Uplevel_Reference
(Calls
.Table
(J
).From
)
579 and then Has_Uplevel_Reference
(Calls
.Table
(J
).To
)
581 Set_Has_Uplevel_Reference
(Calls
.Table
(J
).From
);
586 exit Outer
when not Modified
;
590 -- Next step, create the entities for code we will insert. We do this
591 -- at the start so that all the entities are defined, regardless of the
592 -- order in which we do the code insertions.
594 for J
in Subps
.First
.. Subps
.Last
loop
596 STJ
: Subp_Entry
renames Subps
.Table
(J
);
597 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
598 ARS
: constant String := AREC_String
(STJ
.Lev
);
601 -- First we create the ARECnF entity for the additional formal
602 -- for all subprograms requiring that an activation record pointer
603 -- be passed. This is true of all subprograms that have uplevel
604 -- references, and whose enclosing subprogram also has uplevel
607 if Has_Uplevel_Reference
(STJ
.Ent
)
608 and then STJ
.Ent
/= Subp
609 and then Has_Uplevel_Reference
(Enclosing_Subprogram
(STJ
.Ent
))
612 Make_Defining_Identifier
(Loc
,
613 Chars
=> Name_Find_Str
(AREC_String
(STJ
.Lev
- 1) & "F"));
618 -- Now define the AREC entities for the activation record. This
619 -- is needed for any subprogram that has nested subprograms and
620 -- has uplevel references.
622 if Has_Nested_Subprogram
(STJ
.Ent
)
623 and then Has_Uplevel_Reference
(STJ
.Ent
)
626 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
));
628 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "T"));
630 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "PT"));
632 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "P"));
637 STJ
.ARECnPT
:= Empty
;
642 -- Define uplink component entity if inner nesting case
644 if Has_Uplevel_Reference
(STJ
.Ent
) and then STJ
.Lev
> 1 then
646 ARS1
: constant String := AREC_String
(STJ
.Lev
- 1);
649 Make_Defining_Identifier
(Loc
,
650 Chars
=> Name_Find_Str
(ARS1
& "U"));
659 -- Loop through subprograms
662 Addr
: constant Entity_Id
:= RTE
(RE_Address
);
665 for J
in Subps
.First
.. Subps
.Last
loop
667 STJ
: Subp_Entry
renames Subps
.Table
(J
);
670 -- First add the extra formal if needed. This applies to all
671 -- nested subprograms that require an activation record to be
672 -- passed, as indicated by ARECnF being defined.
674 if Present
(STJ
.ARECnF
) then
676 -- Here we need the extra formal. We do the expansion and
677 -- analysis of this manually, since it is fairly simple,
678 -- and it is not obvious how we can get what we want if we
679 -- try to use the normal Analyze circuit.
681 Extra_Formal
: declare
682 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
683 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
684 -- Index and Subp_Entry for enclosing routine
686 Form
: constant Entity_Id
:= STJ
.ARECnF
;
687 -- The formal to be added. Note that n here is one less
688 -- than the level of the subprogram itself (STJ.Ent).
691 -- If needed, this is the formal added to the body
693 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
694 -- S is an N_Function/Procedure_Specification node, and F
695 -- is the new entity to add to this subprogramn spec.
697 ----------------------
698 -- Add_Form_To_Spec --
699 ----------------------
701 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
702 Sub
: constant Entity_Id
:= Defining_Unit_Name
(S
);
705 if No
(First_Entity
(Sub
)) then
706 Set_First_Entity
(Sub
, F
);
707 Set_Last_Entity
(Sub
, F
);
711 LastF
: constant Entity_Id
:= Last_Formal
(Sub
);
714 Set_Next_Entity
(F
, First_Entity
(Sub
));
715 Set_First_Entity
(Sub
, F
);
718 Set_Next_Entity
(F
, Next_Entity
(LastF
));
719 Set_Next_Entity
(LastF
, F
);
721 if Last_Entity
(Sub
) = LastF
then
722 Set_Last_Entity
(Sub
, F
);
728 if No
(Parameter_Specifications
(S
)) then
729 Set_Parameter_Specifications
(S
, Empty_List
);
732 Append_To
(Parameter_Specifications
(S
),
733 Make_Parameter_Specification
(Sloc
(F
),
734 Defining_Identifier
=> F
,
736 New_Occurrence_Of
(STJE
.ARECnPT
, Sloc
(F
))));
737 end Add_Form_To_Spec
;
739 -- Start of processing for Extra_Formal
742 -- Decorate the new formal entity
744 Set_Scope
(Form
, STJ
.Ent
);
745 Set_Ekind
(Form
, E_In_Parameter
);
746 Set_Etype
(Form
, STJE
.ARECnPT
);
747 Set_Mechanism
(Form
, By_Copy
);
748 Set_Never_Set_In_Source
(Form
, True);
749 Set_Analyzed
(Form
, True);
750 Set_Comes_From_Source
(Form
, False);
752 -- Case of only body present
754 if Acts_As_Spec
(STJ
.Bod
) then
755 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
757 -- Case of separate spec
760 Formb
:= New_Entity
(Nkind
(Form
), Sloc
(Form
));
761 Copy_Node
(Form
, Formb
);
762 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
763 Add_Form_To_Spec
(Formb
, Specification
(STJ
.Bod
));
768 -- Processing for subprograms that have at least one nested
769 -- subprogram, and have uplevel references.
771 if Has_Nested_Subprogram
(STJ
.Ent
)
772 and then Has_Uplevel_Reference
(STJ
.Ent
)
774 -- Local declarations for one such subprogram
777 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
783 Decl_ARECnT
: Node_Id
;
784 Decl_ARECn
: Node_Id
;
785 Decl_ARECnPT
: Node_Id
;
786 Decl_ARECnP
: Node_Id
;
787 -- Declaration nodes for the AREC entities we build
790 array (1 .. List_Length
(STJ
.Urefs
)) of Entity_Id
;
791 Num_Uplevel_Entities
: Nat
;
792 -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains
793 -- a list (with no duplicates) of the entities for this
794 -- subprogram that are referenced uplevel. The maximum
795 -- number of entries cannot exceed the total number of
796 -- uplevel references.
799 -- Populate the Uplevel_Entities array, using the flag
800 -- Uplevel_Reference_Noted to avoid duplicates.
802 Num_Uplevel_Entities
:= 0;
804 if Present
(STJ
.Urefs
) then
805 Elmt
:= First_Elmt
(STJ
.Urefs
);
806 while Present
(Elmt
) loop
807 Ent
:= Entity
(Node
(Elmt
));
809 if not Uplevel_Reference_Noted
(Ent
) then
810 Set_Uplevel_Reference_Noted
(Ent
, True);
811 Num_Uplevel_Entities
:= Num_Uplevel_Entities
+ 1;
812 Uplevel_Entities
(Num_Uplevel_Entities
) := Ent
;
820 -- Build list of component declarations for ARECnT
824 -- If we are in a subprogram that has a static link that
825 -- ias passed in (as indicated by ARECnF being deinfed),
826 -- then include ARECnU : ARECnPT := ARECnF where n is
827 -- one less than the current level and the entity ARECnPT
828 -- comes from the enclosing subprogram.
830 if Present
(STJ
.ARECnF
) then
833 renames Subps
.Table
(Enclosing_Subp
(J
));
837 Make_Component_Declaration
(Loc
,
838 Defining_Identifier
=> STJ
.ARECnU
,
839 Component_Definition
=>
840 Make_Component_Definition
(Loc
,
841 Subtype_Indication
=>
842 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
)),
844 New_Occurrence_Of
(STJ
.ARECnF
, Loc
)));
848 -- Add components for uplevel referenced entities
850 for J
in 1 .. Num_Uplevel_Entities
loop
852 Make_Defining_Identifier
(Loc
,
853 Chars
=> Chars
(Uplevel_Entities
(J
)));
855 Set_Activation_Record_Component
856 (Uplevel_Entities
(J
), Comp
);
859 Make_Component_Declaration
(Loc
,
860 Defining_Identifier
=> Comp
,
861 Component_Definition
=>
862 Make_Component_Definition
(Loc
,
863 Subtype_Indication
=>
864 New_Occurrence_Of
(Addr
, Loc
))));
867 -- Now we can insert the AREC declarations into the body
869 -- type ARECnT is record .. end record;
872 Make_Full_Type_Declaration
(Loc
,
873 Defining_Identifier
=> STJ
.ARECnT
,
875 Make_Record_Definition
(Loc
,
877 Make_Component_List
(Loc
,
878 Component_Items
=> Clist
)));
880 -- ARECn : aliased ARECnT;
883 Make_Object_Declaration
(Loc
,
884 Defining_Identifier
=> STJ
.ARECn
,
885 Aliased_Present
=> True,
887 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
889 -- type ARECnPT is access all ARECnT;
892 Make_Full_Type_Declaration
(Loc
,
893 Defining_Identifier
=> STJ
.ARECnPT
,
895 Make_Access_To_Object_Definition
(Loc
,
897 Subtype_Indication
=>
898 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
900 -- ARECnP : constant ARECnPT := ARECn'Access;
903 Make_Object_Declaration
(Loc
,
904 Defining_Identifier
=> STJ
.ARECnP
,
905 Constant_Present
=> True,
907 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
909 Make_Attribute_Reference
(Loc
,
911 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
912 Attribute_Name
=> Name_Access
));
914 Prepend_List_To
(Declarations
(STJ
.Bod
),
916 (Decl_ARECnT
, Decl_ARECn
, Decl_ARECnPT
, Decl_ARECnP
));
918 -- Analyze the newly inserted declarations. Note that we
919 -- do not need to establish the whole scope stack, since
920 -- we have already set all entity fields (so there will
921 -- be no searching of upper scopes to resolve names). But
922 -- we do set the scope of the current subprogram, so that
923 -- newly created entities go in the right entity chain.
925 -- We analyze with all checks suppressed (since we do
926 -- not expect any exceptions, and also we temporarily
927 -- turn off Unested_Subprogram_Mode to avoid trying to
928 -- mark uplevel references (not needed at this stage,
929 -- and in fact causes a bit of recursive chaos).
931 Push_Scope
(STJ
.Ent
);
932 Opt
.Unnest_Subprogram_Mode
:= False;
933 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
934 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
935 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
936 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
937 Opt
.Unnest_Subprogram_Mode
:= True;
940 -- Next step, for each uplevel referenced entity, add
941 -- assignment operations to set the comoponent in the
942 -- activation record.
944 for J
in 1 .. Num_Uplevel_Entities
loop
946 Ent
: constant Entity_Id
:= Uplevel_Entities
(J
);
947 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
948 Dec
: constant Node_Id
:= Declaration_Node
(Ent
);
953 -- For parameters, we insert the assignment right
954 -- after the declaration of ARECnP. For all other
955 -- entities, we insert the assignment immediately
956 -- after the declaration of the entity.
958 -- Note: we don't need to mark the entity as being
959 -- aliased, because the address attribute will mark
960 -- it as Address_Taken, and that is good enough.
962 if Is_Formal
(Ent
) then
968 -- Build and insert the assignment:
972 Make_Assignment_Statement
(Loc
,
974 Make_Selected_Component
(Loc
,
976 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
978 Make_Identifier
(Loc
, Chars
(Ent
))),
981 Make_Attribute_Reference
(Loc
,
983 New_Occurrence_Of
(Ent
, Loc
),
984 Attribute_Name
=> Name_Address
));
986 Insert_After
(Ins
, Asn
);
988 -- Analyze the assignment statement. We do not need
989 -- to establish the relevant scope stack entries
990 -- here, because we have already set the correct
991 -- entity references, so no name resolution is
992 -- required, and no new entities are created, so
993 -- we don't even need to set the current scope.
995 -- We analyze with all checks suppressed (since
996 -- we do not expect any exceptions, and also we
997 -- temporarily turn off Unested_Subprogram_Mode
998 -- to avoid trying to mark uplevel references (not
999 -- needed at this stage, and in fact causes a bit
1000 -- of recursive chaos).
1002 Opt
.Unnest_Subprogram_Mode
:= False;
1003 Analyze
(Asn
, Suppress
=> All_Checks
);
1004 Opt
.Unnest_Subprogram_Mode
:= True;
1013 -- Next step, process uplevel references. This has to be done in a
1014 -- separate pass, after completing the processing in Sub_Loop because we
1015 -- need all the AREC declarations generated, inserted, and analyzed so
1016 -- that the uplevel references can be successfully analyzed.
1018 Uplev_Refs
: for J
in Subps
.First
.. Subps
.Last
loop
1020 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1023 -- We are only interested in entries which have uplevel references
1024 -- to deal with, as indicated by the Urefs list being present
1026 if Present
(STJ
.Urefs
) then
1028 -- Process uplevel references for one subprogram
1034 -- Loop through uplevel references
1036 Elmt
:= First_Elmt
(STJ
.Urefs
);
1037 while Present
(Elmt
) loop
1039 -- Skip if we have an explicit dereference. This means
1040 -- that we already did the expansion. There can be
1041 -- duplicates in ths STJ.Urefs list.
1043 if Nkind
(Node
(Elmt
)) = N_Explicit_Dereference
then
1047 -- Otherwise, rewrite this reference
1050 Ref
: constant Node_Id
:= Node
(Elmt
);
1051 -- The uplevel reference itself
1053 Loc
: constant Source_Ptr
:= Sloc
(Ref
);
1054 -- Source location for the reference
1056 Ent
: constant Entity_Id
:= Entity
(Ref
);
1057 -- The referenced entity
1059 Typ
: constant Entity_Id
:= Etype
(Ent
);
1060 -- The type of the referenced entity
1062 Rsub
: constant Entity_Id
:=
1063 Node
(Next_Elmt
(Elmt
));
1064 -- The enclosing subprogram for the reference
1066 RSX
: constant SI_Type
:= Subp_Index
(Rsub
);
1067 -- Subp_Index for enclosing subprogram for ref
1069 STJR
: Subp_Entry
renames Subps
.Table
(RSX
);
1070 -- Subp_Entry for enclosing subprogram for ref
1072 Tnn
: constant Entity_Id
:=
1074 (Loc
, 'T', Related_Node
=> Ref
);
1075 -- Local pointer type for reference
1082 -- Push the current scope, so that the pointer type
1083 -- Tnn, and any subsidiary entities resulting from
1084 -- the analysis of the rewritten reference, go in the
1085 -- right entity chain.
1087 Push_Scope
(STJR
.Ent
);
1089 -- First insert declaration for pointer type
1091 -- type Tnn is access all typ;
1094 Make_Full_Type_Declaration
(Loc
,
1095 Defining_Identifier
=> Tnn
,
1097 Make_Access_To_Object_Definition
(Loc
,
1098 All_Present
=> True,
1099 Subtype_Indication
=>
1100 New_Occurrence_Of
(Typ
, Loc
))));
1102 -- Now we need to rewrite the reference. We have a
1103 -- reference is from level STJE.Lev to level STJ.Lev.
1104 -- The general form of the rewritten reference for
1107 -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X).all
1109 -- where a,b,c,d .. m =
1110 -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev
1112 pragma Assert
(STJR
.Lev
> STJ
.Lev
);
1114 -- Compute the prefix of X. Here are examples to make
1115 -- things clear (with parens to show groupings, the
1116 -- prefix is everything except the .X at the end).
1118 -- level 2 to level 1
1122 -- level 3 to level 1
1124 -- (AREC2F.AREC1U).X
1126 -- level 4 to level 1
1128 -- ((AREC3F.AREC2U).AREC1U).X
1130 -- level 6 to level 2
1132 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1134 Pfx
:= New_Occurrence_Of
(STJR
.ARECnF
, Loc
);
1136 for L
in STJ
.Lev
.. STJR
.Lev
- 2 loop
1137 SI
:= Enclosing_Subp
(SI
);
1139 Make_Selected_Component
(Loc
,
1143 (Subps
.Table
(SI
).ARECnU
, Loc
));
1146 -- Get activation record component (must exist)
1148 Comp
:= Activation_Record_Component
(Ent
);
1149 pragma Assert
(Present
(Comp
));
1151 -- Do the replacement
1154 Make_Explicit_Dereference
(Loc
,
1156 Unchecked_Convert_To
(Tnn
,
1157 Make_Selected_Component
(Loc
,
1160 New_Occurrence_Of
(Comp
, Loc
)))));
1162 -- Analyze and resolve the new expression. We do not
1163 -- need to establish the relevant scope stack entries
1164 -- here, because we have already set all the correct
1165 -- entity references, so no name resolution is needed.
1166 -- We have already set the current scope, so that any
1167 -- new entities created will be in the right scope.
1169 -- We analyze with all checks suppressed (since we do
1170 -- not expect any exceptions, and also we temporarily
1171 -- turn off Unested_Subprogram_Mode to avoid trying to
1172 -- mark uplevel references (not needed at this stage,
1173 -- and in fact causes a bit of recursive chaos).
1175 Opt
.Unnest_Subprogram_Mode
:= False;
1176 Analyze_And_Resolve
(Ref
, Typ
, Suppress
=> All_Checks
);
1177 Opt
.Unnest_Subprogram_Mode
:= True;
1188 end loop Uplev_Refs
;
1190 -- Finally, loop through all calls adding extra actual for the
1191 -- activation record where it is required.
1193 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
1195 -- Process a single call, we are only interested in a call to a
1196 -- subprogram that actually needs a pointer to an activation record,
1197 -- as indicated by the ARECnF entity being set. This excludes the
1198 -- top level subprogram, and any subprogram not having uplevel refs.
1200 Adjust_One_Call
: declare
1201 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1202 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.From
));
1203 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.To
));
1205 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
1213 if Present
(STT
.ARECnF
) then
1215 -- CTJ.N is a call to a subprogram which may require
1216 -- a pointer to an activation record. The subprogram
1217 -- containing the call is CTJ.From and the subprogram being
1218 -- called is CTJ.To, so we have a call from level STF.Lev to
1221 -- There are three possibilities:
1223 -- For a call to the same level, we just pass the activation
1224 -- record passed to the calling subprogram.
1226 if STF
.Lev
= STT
.Lev
then
1227 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1229 -- For a call that goes down a level, we pass a pointer
1230 -- to the activation record constructed wtihin the caller
1231 -- (which may be the outer level subprogram, but also may
1232 -- be a more deeply nested caller).
1234 elsif STT
.Lev
= STF
.Lev
+ 1 then
1235 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
1237 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1238 -- since it is not possible to do a downcall of more than
1241 -- For a call from level STF.Lev to level STT.Lev, we
1242 -- have to find the activation record needed by the
1243 -- callee. This is as follows:
1245 -- ARECaF.ARECbU.ARECcU....ARECm
1247 -- where a,b,c .. m =
1248 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1251 pragma Assert
(STT
.Lev
< STF
.Lev
);
1253 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1254 SubX
:= Subp_Index
(CTJ
.From
);
1255 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
1256 SubX
:= Enclosing_Subp
(SubX
);
1258 Make_Selected_Component
(Loc
,
1262 (Subps
.Table
(SubX
).ARECnU
, Loc
));
1266 -- Extra is the additional parameter to be added. Build a
1267 -- parameter association that we can append to the actuals.
1270 Make_Parameter_Association
(Loc
,
1272 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
1273 Explicit_Actual_Parameter
=> Extra
);
1275 if No
(Parameter_Associations
(CTJ
.N
)) then
1276 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
1279 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
1281 -- We need to deal with the actual parameter chain as well.
1282 -- The newly added parameter is always the last actual.
1284 Act
:= First_Named_Actual
(CTJ
.N
);
1287 Set_First_Named_Actual
(CTJ
.N
, Extra
);
1289 -- Here we must follow the chain and append the new entry
1298 PAN
:= Parent
(Act
);
1299 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
1300 NNA
:= Next_Named_Actual
(PAN
);
1303 Set_Next_Named_Actual
(PAN
, Extra
);
1312 -- Analyze and resolve the new actual. We do not need to
1313 -- establish the relevant scope stack entries here, because
1314 -- we have already set all the correct entity references, so
1315 -- no name resolution is needed.
1317 -- We analyze with all checks suppressed (since we do not
1318 -- expect any exceptions, and also we temporarily turn off
1319 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1320 -- references (not needed at this stage, and in fact causes
1321 -- a bit of recursive chaos).
1323 Opt
.Unnest_Subprogram_Mode
:= False;
1325 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
1326 Opt
.Unnest_Subprogram_Mode
:= True;
1328 end Adjust_One_Call
;
1329 end loop Adjust_Calls
;
1332 end Unnest_Subprogram
;