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 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_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 Sinput
; use Sinput
;
44 with Snames
; use Snames
;
45 with Tbuild
; use Tbuild
;
46 with Uintp
; use Uintp
;
48 package body Exp_Unst
is
54 -- Table to record calls within the nest being analyzed. These are the
55 -- calls which may need to have an AREC actual added. This table is built
56 -- new for each subprogram nest and cleared at the end of processing each
59 type Call_Entry
is record
64 -- Entity of the subprogram containing the call (can be at any level)
67 -- Entity of the subprogram called (always at level 2 or higher). Note
68 -- that in accordance with the basic rules of nesting, the level of To
69 -- is either less than or equal to the level of From, or one greater.
72 package Calls
is new Table
.Table
(
73 Table_Component_Type
=> Call_Entry
,
74 Table_Index_Type
=> Nat
,
77 Table_Increment
=> 200,
78 Table_Name
=> "Unnest_Calls");
79 -- Records each call within the outer subprogram and all nested subprograms
80 -- that are to other subprograms nested within the outer subprogram. These
81 -- are the calls that may need an additional parameter.
87 -- Table to record explicit uplevel references to objects (variables,
88 -- constants, formal parameters). These are the references that will
89 -- need rewriting to use the activation table (AREC) pointers. Also
90 -- included are implicit and explicit uplevel references to types, but
91 -- these do not get rewritten by the front end. This table is built new
92 -- for each subprogram nest and cleared at the end of processing each
95 type Uref_Entry
is record
97 -- The reference itself. For objects this is always an entity reference
98 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
99 -- flag set and will appear in the Uplevel_Referenced_Entities list of
100 -- the subprogram declaring this entity.
103 -- The Entity_Id of the uplevel referenced object or type
106 -- The entity for the subprogram immediately containing this entity
109 -- The entity for the subprogram containing the referenced entity. Note
110 -- that the level of Callee must be less than the level of Caller, since
111 -- this is an uplevel reference.
114 package Urefs
is new Table
.Table
(
115 Table_Component_Type
=> Uref_Entry
,
116 Table_Index_Type
=> Nat
,
117 Table_Low_Bound
=> 1,
118 Table_Initial
=> 100,
119 Table_Increment
=> 200,
120 Table_Name
=> "Unnest_Urefs");
122 -----------------------
123 -- Unnest_Subprogram --
124 -----------------------
126 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
) is
127 function AREC_String
(Lev
: Pos
) return String;
128 -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
130 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
131 -- Subp is the index of a subprogram which has a Lev greater than 1.
132 -- This function returns the index of the enclosing subprogram which
133 -- will have a Lev value one less than this.
135 function Get_Level
(Sub
: Entity_Id
) return Nat
;
136 -- Sub is either Subp itself, or a subprogram nested within Subp. This
137 -- function returns the level of nesting (Subp = 1, subprograms that
138 -- are immediately nested within Subp = 2, etc).
140 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
;
141 -- Given the entity for a subprogram, return corresponding Subps index
143 function Suffixed_Name
(Ent
: Entity_Id
) return Name_Id
;
144 -- Given an entity Ent, return its name (Char (Ent)) suffixed with
145 -- two underscores and the entity number, to ensure a unique name.
147 function Upref_Name
(Ent
: Entity_Id
; Clist
: List_Id
) return Name_Id
;
148 -- This function returns the name to be used in the activation record to
149 -- reference the variable uplevel. Clist is the list of components that
150 -- have been created in the activation record so far. Normally this is
151 -- just a copy of the Chars field of the entity. The exception is when
152 -- the name has already been used, in which case we suffix the name with
153 -- the entity number to avoid duplication. This happens with declare
154 -- blocks and generic parameters at least.
160 function AREC_String
(Lev
: Pos
) return String is
163 return AREC_String
(Lev
/ 10) & Character'Val (Lev
mod 10 + 48);
165 return "AREC" & Character'Val (Lev
+ 48);
173 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
174 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
175 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
177 pragma Assert
(STJ
.Lev
> 1);
178 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
186 function Get_Level
(Sub
: Entity_Id
) return Nat
is
196 S
:= Enclosing_Subprogram
(S
);
206 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
208 pragma Assert
(Is_Subprogram
(Sub
));
209 return SI_Type
(UI_To_Int
(Subps_Index
(Sub
)));
216 function Suffixed_Name
(Ent
: Entity_Id
) return Name_Id
is
218 Get_Name_String
(Chars
(Ent
));
219 Add_Str_To_Name_Buffer
("__");
220 Add_Nat_To_Name_Buffer
(Nat
(Ent
));
228 function Upref_Name
(Ent
: Entity_Id
; Clist
: List_Id
) return Name_Id
is
235 elsif Chars
(Defining_Identifier
(C
)) = Chars
(Ent
) then
236 return Suffixed_Name
(Ent
);
243 -- Start of processing for Unnest_Subprogram
246 -- Nothing to do inside a generic (all processing is for instance)
248 if Inside_A_Generic
then
252 -- At least for now, do not unnest anything but main source unit
254 if not In_Extended_Main_Source_Unit
(Subp_Body
) then
258 -- This routine is called late, after the scope stack is gone. The
259 -- following creates a suitable dummy scope stack to be used for the
260 -- analyze/expand calls made from this routine.
264 -- First step, we must mark all nested subprograms that require a static
265 -- link (activation record) because either they contain explicit uplevel
266 -- references (as indicated by ??? being set at this
267 -- point), or they make calls to other subprograms in the same nest that
268 -- require a static link (in which case we set this flag).
270 -- This is a recursive definition, and to implement this, we have to
271 -- build a call graph for the set of nested subprograms, and then go
272 -- over this graph to implement recursively the invariant that if a
273 -- subprogram has a call to a subprogram requiring a static link, then
274 -- the calling subprogram requires a static link.
276 -- First populate the above tables
278 Subps_First
:= Subps
.Last
+ 1;
282 Build_Tables
: declare
283 Current_Subprogram
: Entity_Id
;
284 -- When we scan a subprogram body, we set Current_Subprogram to the
285 -- corresponding entity. This gets recursively saved and restored.
287 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
288 -- Visit a single node in Subp
294 procedure Visit
is new Traverse_Proc
(Visit_Node
);
295 -- Used to traverse the body of Subp, populating the tables
301 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
306 procedure Check_Static_Type
(T
: Entity_Id
; DT
: in out Boolean);
307 -- Given a type T, checks if it is a static type defined as a
308 -- type with no dynamic bounds in sight. If so, the only action
309 -- is to set Is_Static_Type True for T. If T is not a static
310 -- type, then all types with dynamic bounds associated with
311 -- T are detected, and their bounds are marked as uplevel
312 -- referenced if not at the library level, and DT is set True.
314 procedure Note_Uplevel_Ref
318 -- Called when we detect an explicit or implicit uplevel reference
319 -- from within Caller to entity E declared in Callee. E can be a
320 -- an object or a type.
322 -----------------------
323 -- Check_Static_Type --
324 -----------------------
326 procedure Check_Static_Type
(T
: Entity_Id
; DT
: in out Boolean) is
327 procedure Note_Uplevel_Bound
(N
: Node_Id
);
328 -- N is the bound of a dynamic type. This procedure notes that
329 -- this bound is uplevel referenced, it can handle references
330 -- to entities (typically _FIRST and _LAST entities), and also
331 -- attribute references of the form T'name (name is typically
332 -- FIRST or LAST) where T is the uplevel referenced bound.
334 ------------------------
335 -- Note_Uplevel_Bound --
336 ------------------------
338 procedure Note_Uplevel_Bound
(N
: Node_Id
) is
342 if Is_Entity_Name
(N
) then
343 if Present
(Entity
(N
)) then
346 Caller
=> Current_Subprogram
,
347 Callee
=> Enclosing_Subprogram
(Entity
(N
)));
352 elsif Nkind
(N
) = N_Attribute_Reference
then
353 Note_Uplevel_Bound
(Prefix
(N
));
355 end Note_Uplevel_Bound
;
357 -- Start of processing for Check_Static_Type
360 -- If already marked static, immediate return
362 if Is_Static_Type
(T
) then
366 -- If the type is at library level, always consider it static,
367 -- since such uplevel references are irrelevant.
369 if Is_Library_Level_Entity
(T
) then
370 Set_Is_Static_Type
(T
);
374 -- Otherwise figure out what the story is with this type
376 -- For a scalar type, check bounds
378 if Is_Scalar_Type
(T
) then
380 -- If both bounds static, then this is a static type
383 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
384 UB
: constant Node_Id
:= Type_High_Bound
(T
);
387 if not Is_Static_Expression
(LB
) then
388 Note_Uplevel_Bound
(LB
);
392 if not Is_Static_Expression
(UB
) then
393 Note_Uplevel_Bound
(UB
);
398 -- For record type, check all components
400 elsif Is_Record_Type
(T
) then
404 C
:= First_Component_Or_Discriminant
(T
);
405 while Present
(C
) loop
406 Check_Static_Type
(Etype
(C
), DT
);
407 Next_Component_Or_Discriminant
(C
);
411 -- For array type, check index types and component type
413 elsif Is_Array_Type
(T
) then
417 Check_Static_Type
(Component_Type
(T
), DT
);
419 IX
:= First_Index
(T
);
420 while Present
(IX
) loop
421 Check_Static_Type
(Etype
(IX
), DT
);
426 -- For now, ignore other types
433 Set_Is_Static_Type
(T
);
435 end Check_Static_Type
;
437 ----------------------
438 -- Note_Uplevel_Ref --
439 ----------------------
441 procedure Note_Uplevel_Ref
447 -- Nothing to do for static type
449 if Is_Static_Type
(E
) then
453 -- Nothing to do if Caller and Callee are the same
455 if Caller
= Callee
then
459 -- We have a new uplevel referenced entity
461 -- All we do at this stage is to add the uplevel reference to
462 -- the table. It's too earch to do anything else, since this
463 -- uplevel reference may come from an unreachable subprogram
464 -- in which case the entry will be deleted.
466 Urefs
.Append
((N
, E
, Caller
, Callee
));
467 end Note_Uplevel_Ref
;
469 -- Start of processing for Visit_Node
474 if Nkind_In
(N
, N_Procedure_Call_Statement
, N_Function_Call
)
476 -- We are only interested in direct calls, not indirect calls
477 -- (where Name (N) is an explicit dereference) at least for now!
479 and then Nkind
(Name
(N
)) in N_Has_Entity
481 Ent
:= Entity
(Name
(N
));
483 -- We are only interested in calls to subprograms nested
484 -- within Subp. Calls to Subp itself or to subprograms that
485 -- are outside the nested structure do not affect us.
487 if Scope_Within
(Ent
, Subp
) then
489 -- Ignore calls to imported routines
491 if Is_Imported
(Ent
) then
494 -- Here we have a call to keep and analyze
497 -- Both caller and callee must be subprograms
499 if Is_Subprogram
(Ent
) then
500 Calls
.Append
((N
, Current_Subprogram
, Ent
));
505 -- Record a subprogram. We record a subprogram body that acts as
506 -- a spec. Otherwise we record a subprogram declaration, providing
507 -- that it has a corresponding body we can get hold of. The case
508 -- of no corresponding body being available is ignored for now.
510 elsif Nkind
(N
) = N_Subprogram_Body
then
511 Ent
:= Corresponding_Spec_Of
(N
);
513 -- Ignore generic subprogram
515 if Is_Generic_Subprogram
(Ent
) then
519 -- Make new entry in subprogram table if not already made
522 L
: constant Nat
:= Get_Level
(Ent
);
530 Declares_AREC
=> False,
539 Set_Subps_Index
(Ent
, UI_From_Int
(Subps
.Last
));
542 -- We make a recursive call to scan the subprogram body, so
543 -- that we can save and restore Current_Subprogram.
546 Save_CS
: constant Entity_Id
:= Current_Subprogram
;
550 Current_Subprogram
:= Ent
;
554 Decl
:= First
(Declarations
(N
));
555 while Present
(Decl
) loop
562 Visit
(Handled_Statement_Sequence
(N
));
564 -- Restore current subprogram setting
566 Current_Subprogram
:= Save_CS
;
569 -- Now at this level, return skipping the subprogram body
570 -- descendents, since we already took care of them!
574 -- Record an uplevel reference
576 elsif Nkind
(N
) in N_Has_Entity
and then Present
(Entity
(N
)) then
579 -- Only interested in entities declared within our nest
581 if not Is_Library_Level_Entity
(Ent
)
582 and then Scope_Within_Or_Same
(Scope
(Ent
), Subp
)
585 -- Constants and variables are interesting
587 (Ekind_In
(Ent
, E_Constant
, E_Variable
)
589 -- Formals are interesting, but not if being used as mere
590 -- names of parameters for name notation calls.
595 (Nkind
(Parent
(N
)) = N_Parameter_Association
596 and then Selector_Name
(Parent
(N
)) = N
))
598 -- Types other than known Is_Static types are interesting
600 or else (Is_Type
(Ent
)
601 and then not Is_Static_Type
(Ent
)))
603 -- Here we have a possible interesting uplevel reference
605 if Is_Type
(Ent
) then
607 DT
: Boolean := False;
610 Check_Static_Type
(Ent
, DT
);
612 if Is_Static_Type
(Ent
) then
618 Caller
:= Current_Subprogram
;
619 Callee
:= Enclosing_Subprogram
(Ent
);
621 if Callee
/= Caller
and then not Is_Static_Type
(Ent
) then
622 Note_Uplevel_Ref
(Ent
, Caller
, Callee
);
626 -- If we have a body stub, visit the associated subunit
628 elsif Nkind
(N
) in N_Body_Stub
then
629 Visit
(Library_Unit
(N
));
631 -- Skip generic declarations
633 elsif Nkind
(N
) in N_Generic_Declaration
then
636 -- Skip generic package body
638 elsif Nkind
(N
) = N_Package_Body
639 and then Present
(Corresponding_Spec
(N
))
640 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
645 -- Fall through to continue scanning children of this node
650 -- Start of processing for Build_Tables
653 -- Traverse the body to get subprograms, calls and uplevel references
658 -- Now do the first transitive closure which determines which
659 -- subprograms in the nest are actually reachable.
661 Reachable_Closure
: declare
665 Subps
.Table
(1).Reachable
:= True;
667 -- We use a simple minded algorithm as follows (obviously this can
668 -- be done more efficiently, using one of the standard algorithms
669 -- for efficient transitive closure computation, but this is simple
670 -- and most likely fast enough that its speed does not matter).
672 -- Repeatedly scan the list of calls. Any time we find a call from
673 -- A to B, where A is reachable, but B is not, then B is reachable,
674 -- and note that we have made a change by setting Modified True. We
675 -- repeat this until we make a pass with no modifications.
679 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
681 CTJ
: Call_Entry
renames Calls
.Table
(J
);
683 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
684 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
686 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
687 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
690 if SUBF
.Reachable
and then not SUBT
.Reachable
then
691 SUBT
.Reachable
:= True;
697 exit Outer
when not Modified
;
699 end Reachable_Closure
;
701 -- Remove calls from unreachable subprograms
708 for J
in Calls
.First
.. Calls
.Last
loop
710 CTJ
: Call_Entry
renames Calls
.Table
(J
);
712 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
713 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
715 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
716 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
719 if SUBF
.Reachable
then
720 pragma Assert
(SUBT
.Reachable
);
721 New_Index
:= New_Index
+ 1;
722 Calls
.Table
(New_Index
) := Calls
.Table
(J
);
727 Calls
.Set_Last
(New_Index
);
730 -- Remove uplevel references from unreachable subprograms
737 for J
in Urefs
.First
.. Urefs
.Last
loop
739 URJ
: Uref_Entry
renames Urefs
.Table
(J
);
741 SINF
: constant SI_Type
:= Subp_Index
(URJ
.Caller
);
742 SINT
: constant SI_Type
:= Subp_Index
(URJ
.Callee
);
744 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
745 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
750 -- Keep reachable reference
752 if SUBF
.Reachable
then
753 New_Index
:= New_Index
+ 1;
754 Urefs
.Table
(New_Index
) := Urefs
.Table
(J
);
756 -- And since we know we are keeping this one, this is a good
757 -- place to fill in information for a good reference.
759 -- Mark all enclosing subprograms need to declare AREC
763 S
:= Enclosing_Subprogram
(S
);
764 Subps
.Table
(Subp_Index
(S
)).Declares_AREC
:= True;
765 exit when S
= URJ
.Callee
;
768 -- Add to list of uplevel referenced entities for Callee.
769 -- We do not add types to this list, only actual references
770 -- to objects that will be referenced uplevel, and we use
771 -- the flag Is_Uplevel_Referenced_Entity to avoid making
772 -- duplicate entries in the list.
774 if not Is_Uplevel_Referenced_Entity
(URJ
.Ent
) then
775 Set_Is_Uplevel_Referenced_Entity
(URJ
.Ent
);
777 if not Is_Type
(URJ
.Ent
) then
778 Append_New_Elmt
(URJ
.Ent
, SUBT
.Uents
);
782 -- And set uplevel indication for caller
784 if SUBT
.Lev
< SUBF
.Uplevel_Ref
then
785 SUBF
.Uplevel_Ref
:= SUBT
.Lev
;
791 Urefs
.Set_Last
(New_Index
);
794 -- Remove unreachable subprograms from Subps table. Note that we do
795 -- this after eliminating entries from the other two tables, since
796 -- thos elimination steps depend on referencing the Subps table.
803 for J
in Subps_First
.. Subps
.Last
loop
805 STJ
: Subp_Entry
renames Subps
.Table
(J
);
810 -- Subprogram is reachable, copy and reset index
812 if STJ
.Reachable
then
813 New_SI
:= New_SI
+ 1;
814 Subps
.Table
(New_SI
) := STJ
;
815 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(New_SI
));
817 -- Subprogram is not reachable
820 -- Clear index, since no longer active
822 Set_Subps_Index
(Subps
.Table
(J
).Ent
, Uint_0
);
824 -- Output debug information if -gnatd.3 set
826 if Debug_Flag_Dot_3
then
827 Write_Str
("Eliminate ");
828 Write_Name
(Chars
(Subps
.Table
(J
).Ent
));
830 Write_Location
(Sloc
(Subps
.Table
(J
).Ent
));
831 Write_Str
(" (not referenced)");
835 -- Rewrite declaration and body to null statements
837 Spec
:= Corresponding_Spec
(STJ
.Bod
);
839 if Present
(Spec
) then
840 Decl
:= Parent
(Declaration_Node
(Spec
));
841 Rewrite
(Decl
, Make_Null_Statement
(Sloc
(Decl
)));
844 Rewrite
(STJ
.Bod
, Make_Null_Statement
(Sloc
(STJ
.Bod
)));
849 Subps
.Set_Last
(New_SI
);
852 -- Now it is time for the second transitive closure, which follows calls
853 -- and makes sure that A calls B, and B has uplevel references, then A
854 -- is also marked as having uplevel references.
856 Closure_Uplevel
: declare
860 -- We use a simple minded algorithm as follows (obviously this can
861 -- be done more efficiently, using one of the standard algorithms
862 -- for efficient transitive closure computation, but this is simple
863 -- and most likely fast enough that its speed does not matter).
865 -- Repeatedly scan the list of calls. Any time we find a call from
866 -- A to B, where B has uplevel references, make sure that A is marked
867 -- as having at least the same level of uplevel referencing.
871 Inner2
: for J
in Calls
.First
.. Calls
.Last
loop
873 CTJ
: Call_Entry
renames Calls
.Table
(J
);
874 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
875 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
876 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
877 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
879 if SUBT
.Lev
> SUBT
.Uplevel_Ref
880 and then SUBF
.Uplevel_Ref
> SUBT
.Uplevel_Ref
882 SUBF
.Uplevel_Ref
:= SUBT
.Uplevel_Ref
;
888 exit Outer2
when not Modified
;
892 -- We have one more step before the tables are complete. An uplevel
893 -- call from subprogram A to subprogram B where subprogram B has uplevel
894 -- references is in effect an uplevel reference, and must arrange for
895 -- the proper activation link to be passed.
897 for J
in Calls
.First
.. Calls
.Last
loop
899 CTJ
: Call_Entry
renames Calls
.Table
(J
);
901 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
902 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
904 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
905 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
910 -- If callee has uplevel references
912 if SUBT
.Uplevel_Ref
< SUBT
.Lev
914 -- And this is an uplevel call
916 and then SUBT
.Lev
< SUBF
.Lev
918 -- We need to arrange for finding the uplink
922 A
:= Enclosing_Subprogram
(A
);
923 Subps
.Table
(Subp_Index
(A
)).Declares_AREC
:= True;
924 exit when A
= CTJ
.Callee
;
926 -- In any case exit when we get to the outer level. This
927 -- happens in some odd cases with generics (in particular
928 -- sem_ch3.adb does not compile without this kludge ???).
936 -- The tables are now complete, so we can record the last index in the
937 -- Subps table for later reference in Cprint.
939 Subps
.Table
(Subps_First
).Last
:= Subps
.Last
;
941 -- Next step, create the entities for code we will insert. We do this
942 -- at the start so that all the entities are defined, regardless of the
943 -- order in which we do the code insertions.
945 Create_Entities
: for J
in Subps_First
.. Subps
.Last
loop
947 STJ
: Subp_Entry
renames Subps
.Table
(J
);
948 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
949 ARS
: constant String := AREC_String
(STJ
.Lev
);
952 -- First we create the ARECnF entity for the additional formal for
953 -- all subprograms which need an activation record passed.
955 if STJ
.Uplevel_Ref
< STJ
.Lev
then
957 Make_Defining_Identifier
(Loc
,
958 Chars
=> Name_Find_Str
(AREC_String
(STJ
.Lev
- 1) & "F"));
961 -- Define the AREC entities for the activation record if needed
963 if STJ
.Declares_AREC
then
965 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
));
967 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "T"));
969 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "PT"));
971 Make_Defining_Identifier
(Loc
, Name_Find_Str
(ARS
& "P"));
973 -- Define uplink component entity if inner nesting case
975 if Present
(STJ
.ARECnF
) then
977 ARS1
: constant String := AREC_String
(STJ
.Lev
- 1);
980 Make_Defining_Identifier
(Loc
,
981 Chars
=> Name_Find_Str
(ARS1
& "U"));
986 end loop Create_Entities
;
988 -- Loop through subprograms
991 Addr
: constant Entity_Id
:= RTE
(RE_Address
);
994 for J
in Subps_First
.. Subps
.Last
loop
996 STJ
: Subp_Entry
renames Subps
.Table
(J
);
999 -- First add the extra formal if needed. This applies to all
1000 -- nested subprograms that require an activation record to be
1001 -- passed, as indicated by ARECnF being defined.
1003 if Present
(STJ
.ARECnF
) then
1005 -- Here we need the extra formal. We do the expansion and
1006 -- analysis of this manually, since it is fairly simple,
1007 -- and it is not obvious how we can get what we want if we
1008 -- try to use the normal Analyze circuit.
1010 Add_Extra_Formal
: declare
1011 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
1012 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
1013 -- Index and Subp_Entry for enclosing routine
1015 Form
: constant Entity_Id
:= STJ
.ARECnF
;
1016 -- The formal to be added. Note that n here is one less
1017 -- than the level of the subprogram itself (STJ.Ent).
1019 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
1020 -- S is an N_Function/Procedure_Specification node, and F
1021 -- is the new entity to add to this subprogramn spec as
1022 -- the last Extra_Formal.
1024 ----------------------
1025 -- Add_Form_To_Spec --
1026 ----------------------
1028 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
1029 Sub
: constant Entity_Id
:= Defining_Entity
(S
);
1033 -- Case of at least one Extra_Formal is present, set
1034 -- ARECnF as the new last entry in the list.
1036 if Present
(Extra_Formals
(Sub
)) then
1037 Ent
:= Extra_Formals
(Sub
);
1038 while Present
(Extra_Formal
(Ent
)) loop
1039 Ent
:= Extra_Formal
(Ent
);
1042 Set_Extra_Formal
(Ent
, F
);
1044 -- No Extra formals present
1047 Set_Extra_Formals
(Sub
, F
);
1048 Ent
:= Last_Formal
(Sub
);
1050 if Present
(Ent
) then
1051 Set_Extra_Formal
(Ent
, F
);
1054 end Add_Form_To_Spec
;
1056 -- Start of processing for Add_Extra_Formal
1059 -- Decorate the new formal entity
1061 Set_Scope
(Form
, STJ
.Ent
);
1062 Set_Ekind
(Form
, E_In_Parameter
);
1063 Set_Etype
(Form
, STJE
.ARECnPT
);
1064 Set_Mechanism
(Form
, By_Copy
);
1065 Set_Never_Set_In_Source
(Form
, True);
1066 Set_Analyzed
(Form
, True);
1067 Set_Comes_From_Source
(Form
, False);
1069 -- Case of only body present
1071 if Acts_As_Spec
(STJ
.Bod
) then
1072 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
1074 -- Case of separate spec
1077 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
1079 end Add_Extra_Formal
;
1082 -- Processing for subprograms that declare an activation record
1084 if Present
(STJ
.ARECn
) then
1086 -- Local declarations for one such subprogram
1089 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1093 Decl_ARECnT
: Node_Id
;
1094 Decl_ARECnPT
: Node_Id
;
1095 Decl_ARECn
: Node_Id
;
1096 Decl_ARECnP
: Node_Id
;
1097 -- Declaration nodes for the AREC entities we build
1099 Decl_Assign
: Node_Id
;
1100 -- Assigment to set uplink, Empty if none
1103 -- List of new declarations we create
1106 -- Suffix the ARECnT and ARECnPT names to make sure that
1107 -- they are unique when Cprint moves the declarations to
1110 Set_Chars
(STJ
.ARECnT
, Suffixed_Name
(STJ
.ARECnT
));
1111 Set_Chars
(STJ
.ARECnPT
, Suffixed_Name
(STJ
.ARECnPT
));
1113 -- Build list of component declarations for ARECnT
1115 Clist
:= Empty_List
;
1117 -- If we are in a subprogram that has a static link that
1118 -- is passed in (as indicated by ARECnF being defined),
1119 -- then include ARECnU : ARECmPT where m is one less than
1120 -- the current level and the entity ARECnPT comes from
1121 -- the enclosing subprogram.
1123 if Present
(STJ
.ARECnF
) then
1126 renames Subps
.Table
(Enclosing_Subp
(J
));
1129 Make_Component_Declaration
(Loc
,
1130 Defining_Identifier
=> STJ
.ARECnU
,
1131 Component_Definition
=>
1132 Make_Component_Definition
(Loc
,
1133 Subtype_Indication
=>
1134 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
))));
1138 -- Add components for uplevel referenced entities
1140 if Present
(STJ
.Uents
) then
1146 Elmt
:= First_Elmt
(STJ
.Uents
);
1147 while Present
(Elmt
) loop
1148 Uent
:= Node
(Elmt
);
1151 Make_Defining_Identifier
(Loc
,
1152 Chars
=> Upref_Name
(Uent
, Clist
));
1154 Set_Activation_Record_Component
1158 Make_Component_Declaration
(Loc
,
1159 Defining_Identifier
=> Comp
,
1160 Component_Definition
=>
1161 Make_Component_Definition
(Loc
,
1162 Subtype_Indication
=>
1163 New_Occurrence_Of
(Addr
, Loc
))));
1170 -- Now we can insert the AREC declarations into the body
1172 -- type ARECnT is record .. end record;
1175 Make_Full_Type_Declaration
(Loc
,
1176 Defining_Identifier
=> STJ
.ARECnT
,
1178 Make_Record_Definition
(Loc
,
1180 Make_Component_List
(Loc
,
1181 Component_Items
=> Clist
)));
1182 Decls
:= New_List
(Decl_ARECnT
);
1184 -- type ARECnPT is access all ARECnT;
1187 Make_Full_Type_Declaration
(Loc
,
1188 Defining_Identifier
=> STJ
.ARECnPT
,
1190 Make_Access_To_Object_Definition
(Loc
,
1191 All_Present
=> True,
1192 Subtype_Indication
=>
1193 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
1194 Append_To
(Decls
, Decl_ARECnPT
);
1196 -- ARECn : aliased ARECnT;
1199 Make_Object_Declaration
(Loc
,
1200 Defining_Identifier
=> STJ
.ARECn
,
1201 Aliased_Present
=> True,
1202 Object_Definition
=>
1203 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
1204 Append_To
(Decls
, Decl_ARECn
);
1206 -- ARECnP : constant ARECnPT := ARECn'Access;
1209 Make_Object_Declaration
(Loc
,
1210 Defining_Identifier
=> STJ
.ARECnP
,
1211 Constant_Present
=> True,
1212 Object_Definition
=>
1213 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
1215 Make_Attribute_Reference
(Loc
,
1217 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1218 Attribute_Name
=> Name_Access
));
1219 Append_To
(Decls
, Decl_ARECnP
);
1221 -- If we are in a subprogram that has a static link that
1222 -- is passed in (as indicated by ARECnF being defined),
1223 -- then generate ARECn.ARECmU := ARECmF where m is
1224 -- one less than the current level to set the uplink.
1226 if Present
(STJ
.ARECnF
) then
1228 Make_Assignment_Statement
(Loc
,
1230 Make_Selected_Component
(Loc
,
1232 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1234 New_Occurrence_Of
(STJ
.ARECnU
, Loc
)),
1236 New_Occurrence_Of
(STJ
.ARECnF
, Loc
));
1237 Append_To
(Decls
, Decl_Assign
);
1240 Decl_Assign
:= Empty
;
1243 Prepend_List_To
(Declarations
(STJ
.Bod
), Decls
);
1245 -- Analyze the newly inserted declarations. Note that we
1246 -- do not need to establish the whole scope stack, since
1247 -- we have already set all entity fields (so there will
1248 -- be no searching of upper scopes to resolve names). But
1249 -- we do set the scope of the current subprogram, so that
1250 -- newly created entities go in the right entity chain.
1252 -- We analyze with all checks suppressed (since we do
1253 -- not expect any exceptions).
1255 Push_Scope
(STJ
.Ent
);
1256 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
1257 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
1258 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
1259 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
1261 if Present
(Decl_Assign
) then
1262 Analyze
(Decl_Assign
, Suppress
=> All_Checks
);
1267 -- Mark the types as needing typedefs
1269 Set_Needs_Typedef
(STJ
.ARECnT
);
1270 Set_Needs_Typedef
(STJ
.ARECnPT
);
1272 -- Next step, for each uplevel referenced entity, add
1273 -- assignment operations to set the component in the
1274 -- activation record.
1276 if Present
(STJ
.Uents
) then
1281 Elmt
:= First_Elmt
(STJ
.Uents
);
1282 while Present
(Elmt
) loop
1284 Ent
: constant Entity_Id
:= Node
(Elmt
);
1285 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
1286 Dec
: constant Node_Id
:=
1287 Declaration_Node
(Ent
);
1292 -- For parameters, we insert the assignment
1293 -- right after the declaration of ARECnP.
1294 -- For all other entities, we insert
1295 -- the assignment immediately after
1296 -- the declaration of the entity.
1298 -- Note: we don't need to mark the entity
1299 -- as being aliased, because the address
1300 -- attribute will mark it as Address_Taken,
1301 -- and that is good enough.
1303 if Is_Formal
(Ent
) then
1309 -- Build and insert the assignment:
1310 -- ARECn.nam := nam'Address
1313 Make_Assignment_Statement
(Loc
,
1315 Make_Selected_Component
(Loc
,
1317 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1320 (Activation_Record_Component
1325 Make_Attribute_Reference
(Loc
,
1327 New_Occurrence_Of
(Ent
, Loc
),
1328 Attribute_Name
=> Name_Address
));
1330 Insert_After
(Ins
, Asn
);
1332 -- Analyze the assignment statement. We do
1333 -- not need to establish the relevant scope
1334 -- stack entries here, because we have
1335 -- already set the correct entity references,
1336 -- so no name resolution is required, and no
1337 -- new entities are created, so we don't even
1338 -- need to set the current scope.
1340 -- We analyze with all checks suppressed
1341 -- (since we do not expect any exceptions).
1343 Analyze
(Asn
, Suppress
=> All_Checks
);
1356 -- Next step, process uplevel references. This has to be done in a
1357 -- separate pass, after completing the processing in Sub_Loop because we
1358 -- need all the AREC declarations generated, inserted, and analyzed so
1359 -- that the uplevel references can be successfully analyzed.
1361 Uplev_Refs
: for J
in Urefs
.First
.. Urefs
.Last
loop
1363 UPJ
: Uref_Entry
renames Urefs
.Table
(J
);
1366 -- Ignore type references, these are implicit references that do
1367 -- not need rewriting (e.g. the appearence in a conversion).
1369 if Is_Type
(UPJ
.Ent
) then
1373 -- Also ignore uplevel references to bounds of types that come
1374 -- from the original type reference.
1376 if Is_Entity_Name
(UPJ
.Ref
)
1377 and then Present
(Entity
(UPJ
.Ref
))
1378 and then Is_Type
(Entity
(UPJ
.Ref
))
1383 -- Rewrite one reference
1385 Rewrite_One_Ref
: declare
1386 Loc
: constant Source_Ptr
:= Sloc
(UPJ
.Ref
);
1387 -- Source location for the reference
1389 Typ
: constant Entity_Id
:= Etype
(UPJ
.Ent
);
1390 -- The type of the referenced entity
1392 Atyp
: constant Entity_Id
:= Get_Actual_Subtype
(UPJ
.Ref
);
1393 -- The actual subtype of the reference
1395 RS_Caller
: constant SI_Type
:= Subp_Index
(UPJ
.Caller
);
1396 -- Subp_Index for caller containing reference
1398 STJR
: Subp_Entry
renames Subps
.Table
(RS_Caller
);
1399 -- Subp_Entry for subprogram containing reference
1401 RS_Callee
: constant SI_Type
:= Subp_Index
(UPJ
.Callee
);
1402 -- Subp_Index for subprogram containing referenced entity
1404 STJE
: Subp_Entry
renames Subps
.Table
(RS_Callee
);
1405 -- Subp_Entry for subprogram containing referenced entity
1412 -- Ignore if no ARECnF entity for enclosing subprogram which
1413 -- probably happens as a result of not properly treating
1414 -- instance bodies. To be examined ???
1416 -- If this test is omitted, then the compilation of
1417 -- freeze.adb and inline.adb fail in unnesting mode.
1419 if No
(STJR
.ARECnF
) then
1423 -- Push the current scope, so that the pointer type Tnn, and
1424 -- any subsidiary entities resulting from the analysis of the
1425 -- rewritten reference, go in the right entity chain.
1427 Push_Scope
(STJR
.Ent
);
1429 -- Now we need to rewrite the reference. We have a
1430 -- reference is from level STJR.Lev to level STJE.Lev.
1431 -- The general form of the rewritten reference for
1434 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
1436 -- where a,b,c,d .. m =
1437 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
1439 pragma Assert
(STJR
.Lev
> STJE
.Lev
);
1441 -- Compute the prefix of X. Here are examples to make things
1442 -- clear (with parens to show groupings, the prefix is
1443 -- everything except the .X at the end).
1445 -- level 2 to level 1
1449 -- level 3 to level 1
1451 -- (AREC2F.AREC1U).X
1453 -- level 4 to level 1
1455 -- ((AREC3F.AREC2U).AREC1U).X
1457 -- level 6 to level 2
1459 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1461 -- In the above, ARECnF and ARECnU are pointers, so there are
1462 -- explicit dereferences required for these occurrences.
1465 Make_Explicit_Dereference
(Loc
,
1466 Prefix
=> New_Occurrence_Of
(STJR
.ARECnF
, Loc
));
1468 for L
in STJE
.Lev
.. STJR
.Lev
- 2 loop
1469 SI
:= Enclosing_Subp
(SI
);
1471 Make_Explicit_Dereference
(Loc
,
1473 Make_Selected_Component
(Loc
,
1476 New_Occurrence_Of
(Subps
.Table
(SI
).ARECnU
, Loc
)));
1479 -- Get activation record component (must exist)
1481 Comp
:= Activation_Record_Component
(UPJ
.Ent
);
1482 pragma Assert
(Present
(Comp
));
1484 -- Do the replacement
1487 Make_Attribute_Reference
(Loc
,
1488 Prefix
=> New_Occurrence_Of
(Atyp
, Loc
),
1489 Attribute_Name
=> Name_Deref
,
1490 Expressions
=> New_List
(
1491 Make_Selected_Component
(Loc
,
1494 New_Occurrence_Of
(Comp
, Loc
)))));
1496 -- Analyze and resolve the new expression. We do not need to
1497 -- establish the relevant scope stack entries here, because we
1498 -- have already set all the correct entity references, so no
1499 -- name resolution is needed. We have already set the current
1500 -- scope, so that any new entities created will be in the right
1503 -- We analyze with all checks suppressed (since we do not
1504 -- expect any exceptions)
1506 Analyze_And_Resolve
(UPJ
.Ref
, Typ
, Suppress
=> All_Checks
);
1508 end Rewrite_One_Ref
;
1513 end loop Uplev_Refs
;
1515 -- Finally, loop through all calls adding extra actual for the
1516 -- activation record where it is required.
1518 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
1520 -- Process a single call, we are only interested in a call to a
1521 -- subprogram that actually needs a pointer to an activation record,
1522 -- as indicated by the ARECnF entity being set. This excludes the
1523 -- top level subprogram, and any subprogram not having uplevel refs.
1525 Adjust_One_Call
: declare
1526 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1527 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Caller
));
1528 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Callee
));
1530 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
1538 if Present
(STT
.ARECnF
) then
1540 -- CTJ.N is a call to a subprogram which may require
1541 -- a pointer to an activation record. The subprogram
1542 -- containing the call is CTJ.From and the subprogram being
1543 -- called is CTJ.To, so we have a call from level STF.Lev to
1546 -- There are three possibilities:
1548 -- For a call to the same level, we just pass the activation
1549 -- record passed to the calling subprogram.
1551 if STF
.Lev
= STT
.Lev
then
1552 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1554 -- For a call that goes down a level, we pass a pointer
1555 -- to the activation record constructed within the caller
1556 -- (which may be the outer level subprogram, but also may
1557 -- be a more deeply nested caller).
1559 elsif STT
.Lev
= STF
.Lev
+ 1 then
1560 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
1562 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1563 -- since it is not possible to do a downcall of more than
1566 -- For a call from level STF.Lev to level STT.Lev, we
1567 -- have to find the activation record needed by the
1568 -- callee. This is as follows:
1570 -- ARECaF.ARECbU.ARECcU....ARECm
1572 -- where a,b,c .. m =
1573 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1576 pragma Assert
(STT
.Lev
< STF
.Lev
);
1578 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
1579 SubX
:= Subp_Index
(CTJ
.Caller
);
1580 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
1581 SubX
:= Enclosing_Subp
(SubX
);
1583 Make_Selected_Component
(Loc
,
1587 (Subps
.Table
(SubX
).ARECnU
, Loc
));
1591 -- Extra is the additional parameter to be added. Build a
1592 -- parameter association that we can append to the actuals.
1595 Make_Parameter_Association
(Loc
,
1597 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
1598 Explicit_Actual_Parameter
=> Extra
);
1600 if No
(Parameter_Associations
(CTJ
.N
)) then
1601 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
1604 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
1606 -- We need to deal with the actual parameter chain as well.
1607 -- The newly added parameter is always the last actual.
1609 Act
:= First_Named_Actual
(CTJ
.N
);
1612 Set_First_Named_Actual
(CTJ
.N
, Extra
);
1614 -- Here we must follow the chain and append the new entry
1623 PAN
:= Parent
(Act
);
1624 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
1625 NNA
:= Next_Named_Actual
(PAN
);
1628 Set_Next_Named_Actual
(PAN
, Extra
);
1637 -- Analyze and resolve the new actual. We do not need to
1638 -- establish the relevant scope stack entries here, because
1639 -- we have already set all the correct entity references, so
1640 -- no name resolution is needed.
1642 -- We analyze with all checks suppressed (since we do not
1643 -- expect any exceptions, and also we temporarily turn off
1644 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1645 -- references (not needed at this stage, and in fact causes
1646 -- a bit of recursive chaos).
1648 Opt
.Unnest_Subprogram_Mode
:= False;
1650 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
1651 Opt
.Unnest_Subprogram_Mode
:= True;
1653 end Adjust_One_Call
;
1654 end loop Adjust_Calls
;
1657 end Unnest_Subprogram
;