1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Output
; use Output
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Mech
; use Sem_Mech
;
41 with Sem_Res
; use Sem_Res
;
42 with Sem_Util
; use Sem_Util
;
43 with Sinfo
; use Sinfo
;
44 with Sinput
; use Sinput
;
45 with Snames
; use Snames
;
46 with Stand
; use Stand
;
47 with Tbuild
; use Tbuild
;
48 with Uintp
; use Uintp
;
50 package body Exp_Unst
is
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
);
57 -- Subp is a library-level subprogram which has nested subprograms, and
58 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
59 -- declares the AREC types and objects, adds assignments to the AREC record
60 -- as required, defines the xxxPTR types for uplevel referenced objects,
61 -- adds the ARECP parameter to all nested subprograms which need it, and
62 -- modifies all uplevel references appropriately.
68 -- Table to record calls within the nest being analyzed. These are the
69 -- calls which may need to have an AREC actual added. This table is built
70 -- new for each subprogram nest and cleared at the end of processing each
73 type Call_Entry
is record
78 -- Entity of the subprogram containing the call (can be at any level)
81 -- Entity of the subprogram called (always at level 2 or higher). Note
82 -- that in accordance with the basic rules of nesting, the level of To
83 -- is either less than or equal to the level of From, or one greater.
86 package Calls
is new Table
.Table
(
87 Table_Component_Type
=> Call_Entry
,
88 Table_Index_Type
=> Nat
,
91 Table_Increment
=> 200,
92 Table_Name
=> "Unnest_Calls");
93 -- Records each call within the outer subprogram and all nested subprograms
94 -- that are to other subprograms nested within the outer subprogram. These
95 -- are the calls that may need an additional parameter.
97 procedure Append_Unique_Call
(Call
: Call_Entry
);
98 -- Append a call entry to the Calls table. A check is made to see if the
99 -- table already contains this entry and if so it has no effect.
101 ----------------------------------
102 -- Subprograms For Fat Pointers --
103 ----------------------------------
105 function Build_Access_Type_Decl
107 Scop
: Entity_Id
) return Node_Id
;
108 -- For an uplevel reference that involves an unconstrained array type,
109 -- build an access type declaration for the corresponding activation
110 -- record component. The relevant attributes of the access type are
111 -- set here to avoid a full analysis that would require a scope stack.
113 function Needs_Fat_Pointer
(E
: Entity_Id
) return Boolean;
114 -- A formal parameter of an unconstrained array type that appears in an
115 -- uplevel reference requires the construction of an access type, to be
116 -- used in the corresponding component declaration.
122 -- Table to record explicit uplevel references to objects (variables,
123 -- constants, formal parameters). These are the references that will
124 -- need rewriting to use the activation table (AREC) pointers. Also
125 -- included are implicit and explicit uplevel references to types, but
126 -- these do not get rewritten by the front end. This table is built new
127 -- for each subprogram nest and cleared at the end of processing each
130 type Uref_Entry
is record
132 -- The reference itself. For objects this is always an entity reference
133 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
134 -- flag set and will appear in the Uplevel_Referenced_Entities list of
135 -- the subprogram declaring this entity.
138 -- The Entity_Id of the uplevel referenced object or type
141 -- The entity for the subprogram immediately containing this entity
144 -- The entity for the subprogram containing the referenced entity. Note
145 -- that the level of Callee must be less than the level of Caller, since
146 -- this is an uplevel reference.
149 package Urefs
is new Table
.Table
(
150 Table_Component_Type
=> Uref_Entry
,
151 Table_Index_Type
=> Nat
,
152 Table_Low_Bound
=> 1,
153 Table_Initial
=> 100,
154 Table_Increment
=> 200,
155 Table_Name
=> "Unnest_Urefs");
157 ------------------------
158 -- Append_Unique_Call --
159 ------------------------
161 procedure Append_Unique_Call
(Call
: Call_Entry
) is
163 for J
in Calls
.First
.. Calls
.Last
loop
164 if Calls
.Table
(J
) = Call
then
170 end Append_Unique_Call
;
172 -----------------------------
173 -- Build_Access_Type_Decl --
174 -----------------------------
176 function Build_Access_Type_Decl
178 Scop
: Entity_Id
) return Node_Id
180 Loc
: constant Source_Ptr
:= Sloc
(E
);
184 Typ
:= Make_Temporary
(Loc
, 'S');
185 Set_Ekind
(Typ
, E_General_Access_Type
);
186 Set_Etype
(Typ
, Typ
);
187 Set_Scope
(Typ
, Scop
);
188 Set_Directly_Designated_Type
(Typ
, Etype
(E
));
191 Make_Full_Type_Declaration
(Loc
,
192 Defining_Identifier
=> Typ
,
194 Make_Access_To_Object_Definition
(Loc
,
195 Subtype_Indication
=> New_Occurrence_Of
(Etype
(E
), Loc
)));
196 end Build_Access_Type_Decl
;
202 function Get_Level
(Subp
: Entity_Id
; Sub
: Entity_Id
) return Nat
is
214 S
:= Enclosing_Subprogram
(S
);
219 --------------------------
220 -- In_Synchronized_Unit --
221 --------------------------
223 function In_Synchronized_Unit
(Subp
: Entity_Id
) return Boolean is
224 S
: Entity_Id
:= Scope
(Subp
);
227 while Present
(S
) and then S
/= Standard_Standard
loop
228 if Is_Concurrent_Type
(S
) then
231 elsif Is_Private_Type
(S
)
232 and then Present
(Full_View
(S
))
233 and then Is_Concurrent_Type
(Full_View
(S
))
242 end In_Synchronized_Unit
;
244 -----------------------
245 -- Needs_Fat_Pointer --
246 -----------------------
248 function Needs_Fat_Pointer
(E
: Entity_Id
) return Boolean is
251 and then Is_Array_Type
(Etype
(E
))
252 and then not Is_Constrained
(Etype
(E
));
253 end Needs_Fat_Pointer
;
259 function Subp_Index
(Sub
: Entity_Id
) return SI_Type
is
260 E
: Entity_Id
:= Sub
;
263 pragma Assert
(Is_Subprogram
(E
));
265 if Subps_Index
(E
) = Uint_0
then
266 E
:= Ultimate_Alias
(E
);
268 -- The body of a protected operation has a different name and
269 -- has been scanned at this point, and thus has an entry in the
272 if E
= Sub
and then Convention
(E
) = Convention_Protected
then
273 E
:= Protected_Body_Subprogram
(E
);
276 if Ekind
(E
) = E_Function
277 and then Rewritten_For_C
(E
)
278 and then Present
(Corresponding_Procedure
(E
))
280 E
:= Corresponding_Procedure
(E
);
284 pragma Assert
(Subps_Index
(E
) /= Uint_0
);
285 return SI_Type
(UI_To_Int
(Subps_Index
(E
)));
288 -----------------------
289 -- Unnest_Subprogram --
290 -----------------------
292 procedure Unnest_Subprogram
(Subp
: Entity_Id
; Subp_Body
: Node_Id
) is
293 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
;
294 -- Returns name for string ARECjS, where j is the decimal value of j
296 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
;
297 -- Subp is the index of a subprogram which has a Lev greater than 1.
298 -- This function returns the index of the enclosing subprogram which
299 -- will have a Lev value one less than this.
301 function Img_Pos
(N
: Pos
) return String;
302 -- Return image of N without leading blank
307 Clist
: List_Id
) return Name_Id
;
308 -- This function returns the name to be used in the activation record to
309 -- reference the variable uplevel. Clist is the list of components that
310 -- have been created in the activation record so far. Normally the name
311 -- is just a copy of the Chars field of the entity. The exception is
312 -- when the name has already been used, in which case we suffix the name
313 -- with the index value Index to avoid duplication. This happens with
314 -- declare blocks and generic parameters at least.
320 function AREC_Name
(J
: Pos
; S
: String) return Name_Id
is
322 return Name_Find
("AREC" & Img_Pos
(J
) & S
);
329 function Enclosing_Subp
(Subp
: SI_Type
) return SI_Type
is
330 STJ
: Subp_Entry
renames Subps
.Table
(Subp
);
331 Ret
: constant SI_Type
:= Subp_Index
(Enclosing_Subprogram
(STJ
.Ent
));
333 pragma Assert
(STJ
.Lev
> 1);
334 pragma Assert
(Subps
.Table
(Ret
).Lev
= STJ
.Lev
- 1);
342 function Img_Pos
(N
: Pos
) return String is
343 Buf
: String (1 .. 20);
351 Buf
(Ptr
) := Character'Val (48 + NV
mod 10);
356 return Buf
(Ptr
+ 1 .. Buf
'Last);
366 Clist
: List_Id
) return Name_Id
375 elsif Chars
(Defining_Identifier
(C
)) = Chars
(Ent
) then
377 Name_Find
(Get_Name_String
(Chars
(Ent
)) & Img_Pos
(Index
));
384 -- Start of processing for Unnest_Subprogram
387 -- Nothing to do inside a generic (all processing is for instance)
389 if Inside_A_Generic
then
393 -- If the main unit is a package body then we need to examine the spec
394 -- to determine whether the main unit is generic (the scope stack is not
395 -- present when this is called on the main unit).
397 if Ekind
(Cunit_Entity
(Main_Unit
)) = E_Package_Body
398 and then Is_Generic_Unit
(Spec_Entity
(Cunit_Entity
(Main_Unit
)))
403 -- Only unnest when generating code for the main source unit
405 if not In_Extended_Main_Code_Unit
(Subp_Body
) then
409 -- This routine is called late, after the scope stack is gone. The
410 -- following creates a suitable dummy scope stack to be used for the
411 -- analyze/expand calls made from this routine.
415 -- First step, we must mark all nested subprograms that require a static
416 -- link (activation record) because either they contain explicit uplevel
417 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
418 -- this point), or they make calls to other subprograms in the same nest
419 -- that require a static link (in which case we set this flag).
421 -- This is a recursive definition, and to implement this, we have to
422 -- build a call graph for the set of nested subprograms, and then go
423 -- over this graph to implement recursively the invariant that if a
424 -- subprogram has a call to a subprogram requiring a static link, then
425 -- the calling subprogram requires a static link.
427 -- First populate the above tables
429 Subps_First
:= Subps
.Last
+ 1;
433 Build_Tables
: declare
434 Current_Subprogram
: Entity_Id
;
435 -- When we scan a subprogram body, we set Current_Subprogram to the
436 -- corresponding entity. This gets recursively saved and restored.
438 function Visit_Node
(N
: Node_Id
) return Traverse_Result
;
439 -- Visit a single node in Subp
445 procedure Visit
is new Traverse_Proc
(Visit_Node
);
446 -- Used to traverse the body of Subp, populating the tables
452 function Visit_Node
(N
: Node_Id
) return Traverse_Result
is
457 procedure Check_Static_Type
458 (T
: Entity_Id
; N
: Node_Id
; DT
: in out Boolean);
459 -- Given a type T, checks if it is a static type defined as a type
460 -- with no dynamic bounds in sight. If so, the only action is to
461 -- set Is_Static_Type True for T. If T is not a static type, then
462 -- all types with dynamic bounds associated with T are detected,
463 -- and their bounds are marked as uplevel referenced if not at the
464 -- library level, and DT is set True. If N is specified, it's the
465 -- node that will need to be replaced. If not specified, it means
466 -- we can't do a replacement because the bound is implicit.
468 procedure Note_Uplevel_Ref
473 -- Called when we detect an explicit or implicit uplevel reference
474 -- from within Caller to entity E declared in Callee. E can be a
475 -- an object or a type.
477 procedure Register_Subprogram
(E
: Entity_Id
; Bod
: Node_Id
);
478 -- Enter a subprogram whose body is visible or which is a
479 -- subprogram instance into the subprogram table.
481 -----------------------
482 -- Check_Static_Type --
483 -----------------------
485 procedure Check_Static_Type
486 (T
: Entity_Id
; N
: Node_Id
; DT
: in out Boolean)
488 procedure Note_Uplevel_Bound
(N
: Node_Id
; Ref
: Node_Id
);
489 -- N is the bound of a dynamic type. This procedure notes that
490 -- this bound is uplevel referenced, it can handle references
491 -- to entities (typically _FIRST and _LAST entities), and also
492 -- attribute references of the form T'name (name is typically
493 -- FIRST or LAST) where T is the uplevel referenced bound.
494 -- Ref, if Present, is the location of the reference to
497 ------------------------
498 -- Note_Uplevel_Bound --
499 ------------------------
501 procedure Note_Uplevel_Bound
(N
: Node_Id
; Ref
: Node_Id
) is
503 -- Entity name case. Make sure that the entity is declared
504 -- in a subprogram. This may not be the case for for a type
505 -- in a loop appearing in a precondition.
506 -- Exclude explicitly discriminants (that can appear
507 -- in bounds of discriminated components).
509 if Is_Entity_Name
(N
) then
510 if Present
(Entity
(N
))
511 and then not Is_Type
(Entity
(N
))
512 and then Present
(Enclosing_Subprogram
(Entity
(N
)))
513 and then Ekind
(Entity
(N
)) /= E_Discriminant
518 Caller
=> Current_Subprogram
,
519 Callee
=> Enclosing_Subprogram
(Entity
(N
)));
522 -- Attribute or indexed component case
524 elsif Nkind_In
(N
, N_Attribute_Reference
,
527 Note_Uplevel_Bound
(Prefix
(N
), Ref
);
529 -- The indices of the indexed components, or the
530 -- associated expressions of an attribute reference,
531 -- may also involve uplevel references.
537 Expr
:= First
(Expressions
(N
));
538 while Present
(Expr
) loop
539 Note_Uplevel_Bound
(Expr
, Ref
);
544 -- The type of the prefix may be have an uplevel
545 -- reference if this needs bounds.
547 if Nkind
(N
) = N_Attribute_Reference
then
549 Attr
: constant Attribute_Id
:=
550 Get_Attribute_Id
(Attribute_Name
(N
));
551 DT
: Boolean := False;
554 if (Attr
= Attribute_First
555 or else Attr
= Attribute_Last
556 or else Attr
= Attribute_Length
)
557 and then Is_Constrained
(Etype
(Prefix
(N
)))
560 (Etype
(Prefix
(N
)), Empty
, DT
);
565 -- Binary operator cases. These can apply to arrays for
566 -- which we may need bounds.
568 elsif Nkind
(N
) in N_Binary_Op
then
569 Note_Uplevel_Bound
(Left_Opnd
(N
), Ref
);
570 Note_Uplevel_Bound
(Right_Opnd
(N
), Ref
);
572 -- Unary operator case
574 elsif Nkind
(N
) in N_Unary_Op
then
575 Note_Uplevel_Bound
(Right_Opnd
(N
), Ref
);
577 -- Explicit dereference and selected component case
579 elsif Nkind_In
(N
, N_Explicit_Dereference
,
580 N_Selected_Component
)
582 Note_Uplevel_Bound
(Prefix
(N
), Ref
);
586 elsif Nkind
(N
) = N_Type_Conversion
then
587 Note_Uplevel_Bound
(Expression
(N
), Ref
);
589 end Note_Uplevel_Bound
;
591 -- Start of processing for Check_Static_Type
594 -- If already marked static, immediate return
596 if Is_Static_Type
(T
) then
600 -- If the type is at library level, always consider it static,
601 -- since such uplevel references are irrelevant.
603 if Is_Library_Level_Entity
(T
) then
604 Set_Is_Static_Type
(T
);
608 -- Otherwise figure out what the story is with this type
610 -- For a scalar type, check bounds
612 if Is_Scalar_Type
(T
) then
614 -- If both bounds static, then this is a static type
617 LB
: constant Node_Id
:= Type_Low_Bound
(T
);
618 UB
: constant Node_Id
:= Type_High_Bound
(T
);
621 if not Is_Static_Expression
(LB
) then
622 Note_Uplevel_Bound
(LB
, N
);
626 if not Is_Static_Expression
(UB
) then
627 Note_Uplevel_Bound
(UB
, N
);
632 -- For record type, check all components and discriminant
633 -- constraints if present.
635 elsif Is_Record_Type
(T
) then
641 C
:= First_Component_Or_Discriminant
(T
);
642 while Present
(C
) loop
643 Check_Static_Type
(Etype
(C
), N
, DT
);
644 Next_Component_Or_Discriminant
(C
);
647 if Has_Discriminants
(T
)
648 and then Present
(Discriminant_Constraint
(T
))
650 D
:= First_Elmt
(Discriminant_Constraint
(T
));
651 while Present
(D
) loop
652 if not Is_Static_Expression
(Node
(D
)) then
653 Note_Uplevel_Bound
(Node
(D
), N
);
662 -- For array type, check index types and component type
664 elsif Is_Array_Type
(T
) then
668 Check_Static_Type
(Component_Type
(T
), N
, DT
);
670 IX
:= First_Index
(T
);
671 while Present
(IX
) loop
672 Check_Static_Type
(Etype
(IX
), N
, DT
);
677 -- For private type, examine whether full view is static
679 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
680 Check_Static_Type
(Full_View
(T
), N
, DT
);
682 if Is_Static_Type
(Full_View
(T
)) then
683 Set_Is_Static_Type
(T
);
686 -- For now, ignore other types
693 Set_Is_Static_Type
(T
);
695 end Check_Static_Type
;
697 ----------------------
698 -- Note_Uplevel_Ref --
699 ----------------------
701 procedure Note_Uplevel_Ref
707 Full_E
: Entity_Id
:= E
;
709 -- Nothing to do for static type
711 if Is_Static_Type
(E
) then
715 -- Nothing to do if Caller and Callee are the same
717 if Caller
= Callee
then
720 -- Callee may be a function that returns an array, and that has
721 -- been rewritten as a procedure. If caller is that procedure,
722 -- nothing to do either.
724 elsif Ekind
(Callee
) = E_Function
725 and then Rewritten_For_C
(Callee
)
726 and then Corresponding_Procedure
(Callee
) = Caller
730 elsif Ekind_In
(Callee
, E_Entry
, E_Entry_Family
) then
734 -- We have a new uplevel referenced entity
736 if Ekind
(E
) = E_Constant
and then Present
(Full_View
(E
)) then
737 Full_E
:= Full_View
(E
);
740 -- All we do at this stage is to add the uplevel reference to
741 -- the table. It's too early to do anything else, since this
742 -- uplevel reference may come from an unreachable subprogram
743 -- in which case the entry will be deleted.
745 Urefs
.Append
((N
, Full_E
, Caller
, Callee
));
746 end Note_Uplevel_Ref
;
748 -------------------------
749 -- Register_Subprogram --
750 -------------------------
752 procedure Register_Subprogram
(E
: Entity_Id
; Bod
: Node_Id
) is
753 L
: constant Nat
:= Get_Level
(Subp
, E
);
755 -- Subprograms declared in tasks and protected types cannot
756 -- be eliminated because calls to them may be in other units,
757 -- so they must be treated as reachable.
760 -- Subprograms declared in tasks and protected types cannot
761 -- be eliminated because calls to them may be in other units,
762 -- so they must be treated as reachable.
768 Reachable
=> In_Synchronized_Unit
(E
),
770 Declares_AREC
=> False,
780 Set_Subps_Index
(E
, UI_From_Int
(Subps
.Last
));
782 -- If we marked this reachable because it's in a synchronized
783 -- unit, we have to mark all enclosing subprograms as reachable
786 if In_Synchronized_Unit
(E
) then
791 for J
in reverse 1 .. L
- 1 loop
792 S
:= Enclosing_Subprogram
(S
);
793 Subps
.Table
(Subp_Index
(S
)).Reachable
:= True;
797 end Register_Subprogram
;
799 -- Start of processing for Visit_Node
804 -- Record a subprogram call
807 | N_Procedure_Call_Statement
809 -- We are only interested in direct calls, not indirect
810 -- calls (where Name (N) is an explicit dereference) at
813 if Nkind
(Name
(N
)) in N_Has_Entity
then
814 Ent
:= Entity
(Name
(N
));
816 -- We are only interested in calls to subprograms nested
817 -- within Subp. Calls to Subp itself or to subprograms
818 -- outside the nested structure do not affect us.
820 if Scope_Within
(Ent
, Subp
)
821 and then Is_Subprogram
(Ent
)
822 and then not Is_Imported
(Ent
)
824 Append_Unique_Call
((N
, Current_Subprogram
, Ent
));
828 -- For all calls where the formal is an unconstrained array
829 -- and the actual is constrained we need to check the bounds
830 -- for uplevel references.
834 DT
: Boolean := False;
839 if Nkind
(Name
(N
)) = N_Explicit_Dereference
then
840 Subp
:= Etype
(Name
(N
));
842 Subp
:= Entity
(Name
(N
));
845 Actual
:= First_Actual
(N
);
846 Formal
:= First_Formal_With_Extras
(Subp
);
847 while Present
(Actual
) loop
848 if Is_Array_Type
(Etype
(Formal
))
849 and then not Is_Constrained
(Etype
(Formal
))
850 and then Is_Constrained
(Etype
(Actual
))
852 Check_Static_Type
(Etype
(Actual
), Empty
, DT
);
855 Next_Actual
(Actual
);
856 Next_Formal_With_Extras
(Formal
);
860 -- An At_End_Proc in a statement sequence indicates that there
861 -- is a call from the enclosing construct or block to that
862 -- subprogram. As above, the called entity must be local and
865 when N_Handled_Sequence_Of_Statements
=>
866 if Present
(At_End_Proc
(N
))
867 and then Scope_Within
(Entity
(At_End_Proc
(N
)), Subp
)
868 and then not Is_Imported
(Entity
(At_End_Proc
(N
)))
871 ((N
, Current_Subprogram
, Entity
(At_End_Proc
(N
))));
874 -- Similarly, the following constructs include a semantic
875 -- attribute Procedure_To_Call that must be handled like
876 -- other calls. Likewise for attribute Storage_Pool.
879 | N_Extended_Return_Statement
881 | N_Simple_Return_Statement
884 Pool
: constant Entity_Id
:= Storage_Pool
(N
);
885 Proc
: constant Entity_Id
:= Procedure_To_Call
(N
);
889 and then Scope_Within
(Proc
, Subp
)
890 and then not Is_Imported
(Proc
)
892 Append_Unique_Call
((N
, Current_Subprogram
, Proc
));
896 and then not Is_Library_Level_Entity
(Pool
)
897 and then Scope_Within_Or_Same
(Scope
(Pool
), Subp
)
899 Caller
:= Current_Subprogram
;
900 Callee
:= Enclosing_Subprogram
(Pool
);
902 if Callee
/= Caller
then
903 Note_Uplevel_Ref
(Pool
, Empty
, Caller
, Callee
);
908 -- For an allocator with a qualified expression, check type
909 -- of expression being qualified. The explicit type name is
910 -- handled as an entity reference.
912 if Nkind
(N
) = N_Allocator
913 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
916 DT
: Boolean := False;
919 (Etype
(Expression
(Expression
(N
))), Empty
, DT
);
922 -- For a Return or Free (all other nodes we handle here),
923 -- we usually need the size of the object, so we need to be
924 -- sure that any nonstatic bounds of the expression's type
925 -- that are uplevel are handled.
927 elsif Nkind
(N
) /= N_Allocator
928 and then Present
(Expression
(N
))
931 DT
: Boolean := False;
933 Check_Static_Type
(Etype
(Expression
(N
)), Empty
, DT
);
937 -- A 'Access reference is a (potential) call. So is 'Address,
938 -- in particular on imported subprograms. Other attributes
939 -- require special handling.
941 when N_Attribute_Reference
=>
943 Attr
: constant Attribute_Id
:=
944 Get_Attribute_Id
(Attribute_Name
(N
));
947 when Attribute_Access
948 | Attribute_Unchecked_Access
949 | Attribute_Unrestricted_Access
952 if Nkind
(Prefix
(N
)) in N_Has_Entity
then
953 Ent
:= Entity
(Prefix
(N
));
955 -- We only need to examine calls to subprograms
956 -- nested within current Subp.
958 if Scope_Within
(Ent
, Subp
) then
959 if Is_Imported
(Ent
) then
962 elsif Is_Subprogram
(Ent
) then
964 ((N
, Current_Subprogram
, Ent
));
969 -- References to bounds can be uplevel references if
970 -- the type isn't static.
976 -- Special-case attributes of objects whose bounds
977 -- may be uplevel references. More complex prefixes
978 -- handled during full traversal. Note that if the
979 -- nominal subtype of the prefix is unconstrained,
980 -- the bound must be obtained from the object, not
981 -- from the (possibly) uplevel reference.
983 if Is_Constrained
(Etype
(Prefix
(N
))) then
985 DT
: Boolean := False;
988 (Etype
(Prefix
(N
)), Empty
, DT
);
999 -- Component associations in aggregates are either static or
1000 -- else the aggregate will be expanded into assignments, in
1001 -- which case the expression is analyzed later and provides
1002 -- no relevant code generation.
1004 when N_Component_Association
=>
1005 if No
(Expression
(N
))
1006 or else No
(Etype
(Expression
(N
)))
1011 -- Generic associations are not analyzed: the actuals are
1012 -- transferred to renaming and subtype declarations that
1013 -- are the ones that must be examined.
1015 when N_Generic_Association
=>
1018 -- Indexed references can be uplevel if the type isn't static
1019 -- and if the lower bound (or an inner bound for a multi-
1020 -- dimensional array) is uplevel.
1022 when N_Indexed_Component
1025 if Is_Constrained
(Etype
(Prefix
(N
))) then
1027 DT
: Boolean := False;
1029 Check_Static_Type
(Etype
(Prefix
(N
)), Empty
, DT
);
1033 -- A selected component can have an implicit up-level
1034 -- reference due to the bounds of previous fields in the
1035 -- record. We simplify the processing here by examining
1036 -- all components of the record.
1038 -- Selected components appear as unit names and end labels
1039 -- for child units. Prefixes of these nodes denote parent
1040 -- units and carry no type information so they are skipped.
1042 when N_Selected_Component
=>
1043 if Present
(Etype
(Prefix
(N
))) then
1045 DT
: Boolean := False;
1047 Check_Static_Type
(Etype
(Prefix
(N
)), Empty
, DT
);
1051 -- For EQ/NE comparisons, we need the type of the operands
1052 -- in order to do the comparison, which means we need the
1059 DT
: Boolean := False;
1061 Check_Static_Type
(Etype
(Left_Opnd
(N
)), Empty
, DT
);
1062 Check_Static_Type
(Etype
(Right_Opnd
(N
)), Empty
, DT
);
1065 -- Likewise we need the sizes to compute how much to move in
1068 when N_Assignment_Statement
=>
1070 DT
: Boolean := False;
1072 Check_Static_Type
(Etype
(Name
(N
)), Empty
, DT
);
1073 Check_Static_Type
(Etype
(Expression
(N
)), Empty
, DT
);
1076 -- Record a subprogram. We record a subprogram body that acts
1077 -- as a spec. Otherwise we record a subprogram declaration,
1078 -- providing that it has a corresponding body we can get hold
1079 -- of. The case of no corresponding body being available is
1082 when N_Subprogram_Body
=>
1083 Ent
:= Unique_Defining_Entity
(N
);
1085 -- Ignore generic subprogram
1087 if Is_Generic_Subprogram
(Ent
) then
1091 -- Make new entry in subprogram table if not already made
1093 Register_Subprogram
(Ent
, N
);
1095 -- We make a recursive call to scan the subprogram body, so
1096 -- that we can save and restore Current_Subprogram.
1099 Save_CS
: constant Entity_Id
:= Current_Subprogram
;
1103 Current_Subprogram
:= Ent
;
1105 -- Scan declarations
1107 Decl
:= First
(Declarations
(N
));
1108 while Present
(Decl
) loop
1115 Visit
(Handled_Statement_Sequence
(N
));
1117 -- Restore current subprogram setting
1119 Current_Subprogram
:= Save_CS
;
1122 -- Now at this level, return skipping the subprogram body
1123 -- descendants, since we already took care of them!
1127 -- If we have a body stub, visit the associated subunit, which
1128 -- is a semantic descendant of the stub.
1131 Visit
(Library_Unit
(N
));
1133 -- A declaration of a wrapper package indicates a subprogram
1134 -- instance for which there is no explicit body. Enter the
1135 -- subprogram instance in the table.
1137 when N_Package_Declaration
=>
1138 if Is_Wrapper_Package
(Defining_Entity
(N
)) then
1140 (Related_Instance
(Defining_Entity
(N
)), Empty
);
1143 -- Skip generic declarations
1145 when N_Generic_Declaration
=>
1148 -- Skip generic package body
1150 when N_Package_Body
=>
1151 if Present
(Corresponding_Spec
(N
))
1152 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
1157 -- Pragmas and component declarations can be ignored.
1158 -- Quantified expressions are expanded into explicit loops
1159 -- and the original epression must be ignored.
1161 when N_Component_Declaration
1163 | N_Quantified_Expression
1167 -- We want to skip the function spec for a generic function
1168 -- to avoid looking at any generic types that might be in
1171 when N_Function_Specification
=>
1172 if Is_Generic_Subprogram
(Unique_Defining_Entity
(N
)) then
1176 -- Otherwise record an uplevel reference in a local identifier
1179 if Nkind
(N
) in N_Has_Entity
1180 and then Present
(Entity
(N
))
1184 -- Only interested in entities declared within our nest
1186 if not Is_Library_Level_Entity
(Ent
)
1187 and then Scope_Within_Or_Same
(Scope
(Ent
), Subp
)
1189 -- Skip entities defined in inlined subprograms
1192 Chars
(Enclosing_Subprogram
(Ent
)) /= Name_uParent
1194 -- Constants and variables are potentially uplevel
1195 -- references to global declarations.
1198 (Ekind_In
(Ent
, E_Constant
,
1202 -- Formals are interesting, but not if being used
1203 -- as mere names of parameters for name notation
1209 (Nkind
(Parent
(N
)) = N_Parameter_Association
1210 and then Selector_Name
(Parent
(N
)) = N
))
1212 -- Types other than known Is_Static types are
1213 -- potentially interesting.
1216 (Is_Type
(Ent
) and then not Is_Static_Type
(Ent
)))
1218 -- Here we have a potentially interesting uplevel
1219 -- reference to examine.
1221 if Is_Type
(Ent
) then
1223 DT
: Boolean := False;
1226 Check_Static_Type
(Ent
, N
, DT
);
1231 Caller
:= Current_Subprogram
;
1232 Callee
:= Enclosing_Subprogram
(Ent
);
1235 and then (not Is_Static_Type
(Ent
)
1236 or else Needs_Fat_Pointer
(Ent
))
1238 Note_Uplevel_Ref
(Ent
, N
, Caller
, Callee
);
1240 -- Check the type of a formal parameter of the current
1241 -- subprogram, whose formal type may be an uplevel
1244 elsif Is_Formal
(Ent
)
1245 and then Scope
(Ent
) = Current_Subprogram
1248 DT
: Boolean := False;
1251 Check_Static_Type
(Etype
(Ent
), Empty
, DT
);
1258 -- Fall through to continue scanning children of this node
1263 -- Start of processing for Build_Tables
1266 -- Traverse the body to get subprograms, calls and uplevel references
1271 -- Now do the first transitive closure which determines which
1272 -- subprograms in the nest are actually reachable.
1274 Reachable_Closure
: declare
1278 Subps
.Table
(Subps_First
).Reachable
:= True;
1280 -- We use a simple minded algorithm as follows (obviously this can
1281 -- be done more efficiently, using one of the standard algorithms
1282 -- for efficient transitive closure computation, but this is simple
1283 -- and most likely fast enough that its speed does not matter).
1285 -- Repeatedly scan the list of calls. Any time we find a call from
1286 -- A to B, where A is reachable, but B is not, then B is reachable,
1287 -- and note that we have made a change by setting Modified True. We
1288 -- repeat this until we make a pass with no modifications.
1292 Inner
: for J
in Calls
.First
.. Calls
.Last
loop
1294 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1296 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1297 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1299 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1300 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1303 if SUBF
.Reachable
and then not SUBT
.Reachable
then
1304 SUBT
.Reachable
:= True;
1310 exit Outer
when not Modified
;
1312 end Reachable_Closure
;
1314 -- Remove calls from unreachable subprograms
1321 for J
in Calls
.First
.. Calls
.Last
loop
1323 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1325 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1326 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1328 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1329 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1332 if SUBF
.Reachable
then
1333 pragma Assert
(SUBT
.Reachable
);
1334 New_Index
:= New_Index
+ 1;
1335 Calls
.Table
(New_Index
) := Calls
.Table
(J
);
1340 Calls
.Set_Last
(New_Index
);
1343 -- Remove uplevel references from unreachable subprograms
1350 for J
in Urefs
.First
.. Urefs
.Last
loop
1352 URJ
: Uref_Entry
renames Urefs
.Table
(J
);
1354 SINF
: constant SI_Type
:= Subp_Index
(URJ
.Caller
);
1355 SINT
: constant SI_Type
:= Subp_Index
(URJ
.Callee
);
1357 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1358 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1363 -- Keep reachable reference
1365 if SUBF
.Reachable
then
1366 New_Index
:= New_Index
+ 1;
1367 Urefs
.Table
(New_Index
) := Urefs
.Table
(J
);
1369 -- And since we know we are keeping this one, this is a good
1370 -- place to fill in information for a good reference.
1372 -- Mark all enclosing subprograms need to declare AREC
1376 S
:= Enclosing_Subprogram
(S
);
1378 -- If we are at the top level, as can happen with
1379 -- references to formals in aspects of nested subprogram
1380 -- declarations, there are no further subprograms to mark
1381 -- as requiring activation records.
1386 SUBI
: Subp_Entry
renames Subps
.Table
(Subp_Index
(S
));
1388 SUBI
.Declares_AREC
:= True;
1390 -- If this entity was marked reachable because it is
1391 -- in a task or protected type, there may not appear
1392 -- to be any calls to it, which would normally
1393 -- adjust the levels of the parent subprograms.
1394 -- So we need to be sure that the uplevel reference
1395 -- of that entity takes into account possible calls.
1397 if In_Synchronized_Unit
(SUBF
.Ent
)
1398 and then SUBT
.Lev
< SUBI
.Uplevel_Ref
1400 SUBI
.Uplevel_Ref
:= SUBT
.Lev
;
1404 exit when S
= URJ
.Callee
;
1407 -- Add to list of uplevel referenced entities for Callee.
1408 -- We do not add types to this list, only actual references
1409 -- to objects that will be referenced uplevel, and we use
1410 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1411 -- duplicate entries in the list.
1412 -- Discriminants are also excluded, only the enclosing
1413 -- object can appear in the list.
1415 if not Is_Uplevel_Referenced_Entity
(URJ
.Ent
)
1416 and then Ekind
(URJ
.Ent
) /= E_Discriminant
1418 Set_Is_Uplevel_Referenced_Entity
(URJ
.Ent
);
1419 Append_New_Elmt
(URJ
.Ent
, SUBT
.Uents
);
1422 -- And set uplevel indication for caller
1424 if SUBT
.Lev
< SUBF
.Uplevel_Ref
then
1425 SUBF
.Uplevel_Ref
:= SUBT
.Lev
;
1431 Urefs
.Set_Last
(New_Index
);
1434 -- Remove unreachable subprograms from Subps table. Note that we do
1435 -- this after eliminating entries from the other two tables, since
1436 -- those elimination steps depend on referencing the Subps table.
1442 New_SI
:= Subps_First
- 1;
1443 for J
in Subps_First
.. Subps
.Last
loop
1445 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1450 -- Subprogram is reachable, copy and reset index
1452 if STJ
.Reachable
then
1453 New_SI
:= New_SI
+ 1;
1454 Subps
.Table
(New_SI
) := STJ
;
1455 Set_Subps_Index
(STJ
.Ent
, UI_From_Int
(New_SI
));
1457 -- Subprogram is not reachable
1460 -- Clear index, since no longer active
1462 Set_Subps_Index
(Subps
.Table
(J
).Ent
, Uint_0
);
1464 -- Output debug information if -gnatd.3 set
1466 if Debug_Flag_Dot_3
then
1467 Write_Str
("Eliminate ");
1468 Write_Name
(Chars
(Subps
.Table
(J
).Ent
));
1470 Write_Location
(Sloc
(Subps
.Table
(J
).Ent
));
1471 Write_Str
(" (not referenced)");
1475 -- Rewrite declaration, body, and corresponding freeze node
1476 -- to null statements.
1478 -- A subprogram instantiation does not have an explicit
1479 -- body. If unused, we could remove the corresponding
1480 -- wrapper package and its body (TBD).
1482 if Present
(STJ
.Bod
) then
1483 Spec
:= Corresponding_Spec
(STJ
.Bod
);
1485 if Present
(Spec
) then
1486 Decl
:= Parent
(Declaration_Node
(Spec
));
1487 Rewrite
(Decl
, Make_Null_Statement
(Sloc
(Decl
)));
1489 if Present
(Freeze_Node
(Spec
)) then
1490 Rewrite
(Freeze_Node
(Spec
),
1491 Make_Null_Statement
(Sloc
(Decl
)));
1495 Rewrite
(STJ
.Bod
, Make_Null_Statement
(Sloc
(STJ
.Bod
)));
1501 Subps
.Set_Last
(New_SI
);
1504 -- Now it is time for the second transitive closure, which follows calls
1505 -- and makes sure that A calls B, and B has uplevel references, then A
1506 -- is also marked as having uplevel references.
1508 Closure_Uplevel
: declare
1512 -- We use a simple minded algorithm as follows (obviously this can
1513 -- be done more efficiently, using one of the standard algorithms
1514 -- for efficient transitive closure computation, but this is simple
1515 -- and most likely fast enough that its speed does not matter).
1517 -- Repeatedly scan the list of calls. Any time we find a call from
1518 -- A to B, where B has uplevel references, make sure that A is marked
1519 -- as having at least the same level of uplevel referencing.
1523 Inner2
: for J
in Calls
.First
.. Calls
.Last
loop
1525 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1526 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1527 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1528 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1529 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1531 if SUBT
.Lev
> SUBT
.Uplevel_Ref
1532 and then SUBF
.Uplevel_Ref
> SUBT
.Uplevel_Ref
1534 SUBF
.Uplevel_Ref
:= SUBT
.Uplevel_Ref
;
1540 exit Outer2
when not Modified
;
1542 end Closure_Uplevel
;
1544 -- We have one more step before the tables are complete. An uplevel
1545 -- call from subprogram A to subprogram B where subprogram B has uplevel
1546 -- references is in effect an uplevel reference, and must arrange for
1547 -- the proper activation link to be passed.
1549 for J
in Calls
.First
.. Calls
.Last
loop
1551 CTJ
: Call_Entry
renames Calls
.Table
(J
);
1553 SINF
: constant SI_Type
:= Subp_Index
(CTJ
.Caller
);
1554 SINT
: constant SI_Type
:= Subp_Index
(CTJ
.Callee
);
1556 SUBF
: Subp_Entry
renames Subps
.Table
(SINF
);
1557 SUBT
: Subp_Entry
renames Subps
.Table
(SINT
);
1562 -- If callee has uplevel references
1564 if SUBT
.Uplevel_Ref
< SUBT
.Lev
1566 -- And this is an uplevel call
1568 and then SUBT
.Lev
< SUBF
.Lev
1570 -- We need to arrange for finding the uplink
1574 A
:= Enclosing_Subprogram
(A
);
1575 Subps
.Table
(Subp_Index
(A
)).Declares_AREC
:= True;
1576 exit when A
= CTJ
.Callee
;
1578 -- In any case exit when we get to the outer level. This
1579 -- happens in some odd cases with generics (in particular
1580 -- sem_ch3.adb does not compile without this kludge ???).
1588 -- The tables are now complete, so we can record the last index in the
1589 -- Subps table for later reference in Cprint.
1591 Subps
.Table
(Subps_First
).Last
:= Subps
.Last
;
1593 -- Next step, create the entities for code we will insert. We do this
1594 -- at the start so that all the entities are defined, regardless of the
1595 -- order in which we do the code insertions.
1597 Create_Entities
: for J
in Subps_First
.. Subps
.Last
loop
1599 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1600 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1603 -- First we create the ARECnF entity for the additional formal for
1604 -- all subprograms which need an activation record passed.
1606 if STJ
.Uplevel_Ref
< STJ
.Lev
then
1608 Make_Defining_Identifier
(Loc
, Chars
=> AREC_Name
(J
, "F"));
1611 -- Define the AREC entities for the activation record if needed
1613 if STJ
.Declares_AREC
then
1615 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, ""));
1617 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "T"));
1619 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "PT"));
1621 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "P"));
1623 -- Define uplink component entity if inner nesting case
1625 if Present
(STJ
.ARECnF
) then
1627 Make_Defining_Identifier
(Loc
, AREC_Name
(J
, "U"));
1631 end loop Create_Entities
;
1633 -- Loop through subprograms
1636 Addr
: Entity_Id
:= Empty
;
1639 for J
in Subps_First
.. Subps
.Last
loop
1641 STJ
: Subp_Entry
renames Subps
.Table
(J
);
1644 -- First add the extra formal if needed. This applies to all
1645 -- nested subprograms that require an activation record to be
1646 -- passed, as indicated by ARECnF being defined.
1648 if Present
(STJ
.ARECnF
) then
1650 -- Here we need the extra formal. We do the expansion and
1651 -- analysis of this manually, since it is fairly simple,
1652 -- and it is not obvious how we can get what we want if we
1653 -- try to use the normal Analyze circuit.
1655 Add_Extra_Formal
: declare
1656 Encl
: constant SI_Type
:= Enclosing_Subp
(J
);
1657 STJE
: Subp_Entry
renames Subps
.Table
(Encl
);
1658 -- Index and Subp_Entry for enclosing routine
1660 Form
: constant Entity_Id
:= STJ
.ARECnF
;
1661 -- The formal to be added. Note that n here is one less
1662 -- than the level of the subprogram itself (STJ.Ent).
1664 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
);
1665 -- S is an N_Function/Procedure_Specification node, and F
1666 -- is the new entity to add to this subprogramn spec as
1667 -- the last Extra_Formal.
1669 ----------------------
1670 -- Add_Form_To_Spec --
1671 ----------------------
1673 procedure Add_Form_To_Spec
(F
: Entity_Id
; S
: Node_Id
) is
1674 Sub
: constant Entity_Id
:= Defining_Entity
(S
);
1678 -- Case of at least one Extra_Formal is present, set
1679 -- ARECnF as the new last entry in the list.
1681 if Present
(Extra_Formals
(Sub
)) then
1682 Ent
:= Extra_Formals
(Sub
);
1683 while Present
(Extra_Formal
(Ent
)) loop
1684 Ent
:= Extra_Formal
(Ent
);
1687 Set_Extra_Formal
(Ent
, F
);
1689 -- No Extra formals present
1692 Set_Extra_Formals
(Sub
, F
);
1693 Ent
:= Last_Formal
(Sub
);
1695 if Present
(Ent
) then
1696 Set_Extra_Formal
(Ent
, F
);
1699 end Add_Form_To_Spec
;
1701 -- Start of processing for Add_Extra_Formal
1704 -- Decorate the new formal entity
1706 Set_Scope
(Form
, STJ
.Ent
);
1707 Set_Ekind
(Form
, E_In_Parameter
);
1708 Set_Etype
(Form
, STJE
.ARECnPT
);
1709 Set_Mechanism
(Form
, By_Copy
);
1710 Set_Never_Set_In_Source
(Form
, True);
1711 Set_Analyzed
(Form
, True);
1712 Set_Comes_From_Source
(Form
, False);
1713 Set_Is_Activation_Record
(Form
, True);
1715 -- Case of only body present
1717 if Acts_As_Spec
(STJ
.Bod
) then
1718 Add_Form_To_Spec
(Form
, Specification
(STJ
.Bod
));
1720 -- Case of separate spec
1723 Add_Form_To_Spec
(Form
, Parent
(STJ
.Ent
));
1725 end Add_Extra_Formal
;
1728 -- Processing for subprograms that declare an activation record
1730 if Present
(STJ
.ARECn
) then
1732 -- Local declarations for one such subprogram
1735 Loc
: constant Source_Ptr
:= Sloc
(STJ
.Bod
);
1737 Decls
: constant List_Id
:= New_List
;
1738 -- List of new declarations we create
1743 Decl_Assign
: Node_Id
;
1744 -- Assigment to set uplink, Empty if none
1746 Decl_ARECnT
: Node_Id
;
1747 Decl_ARECnPT
: Node_Id
;
1748 Decl_ARECn
: Node_Id
;
1749 Decl_ARECnP
: Node_Id
;
1750 -- Declaration nodes for the AREC entities we build
1753 -- Build list of component declarations for ARECnT
1754 -- and load System.Address.
1756 Clist
:= Empty_List
;
1759 Addr
:= RTE
(RE_Address
);
1762 -- If we are in a subprogram that has a static link that
1763 -- is passed in (as indicated by ARECnF being defined),
1764 -- then include ARECnU : ARECmPT where ARECmPT comes from
1765 -- the level one higher than the current level, and the
1766 -- entity ARECnPT comes from the enclosing subprogram.
1768 if Present
(STJ
.ARECnF
) then
1771 renames Subps
.Table
(Enclosing_Subp
(J
));
1774 Make_Component_Declaration
(Loc
,
1775 Defining_Identifier
=> STJ
.ARECnU
,
1776 Component_Definition
=>
1777 Make_Component_Definition
(Loc
,
1778 Subtype_Indication
=>
1779 New_Occurrence_Of
(STJE
.ARECnPT
, Loc
))));
1783 -- Add components for uplevel referenced entities
1785 if Present
(STJ
.Uents
) then
1792 -- 1's origin of index in list of elements. This is
1793 -- used to uniquify names if needed in Upref_Name.
1796 Elmt
:= First_Elmt
(STJ
.Uents
);
1798 while Present
(Elmt
) loop
1799 Uent
:= Node
(Elmt
);
1803 Make_Defining_Identifier
(Loc
,
1804 Chars
=> Upref_Name
(Uent
, Indx
, Clist
));
1806 Set_Activation_Record_Component
1809 if Needs_Fat_Pointer
(Uent
) then
1811 -- Build corresponding access type
1814 Build_Access_Type_Decl
1815 (Etype
(Uent
), STJ
.Ent
);
1816 Append_To
(Decls
, Ptr_Decl
);
1818 -- And use its type in the corresponding
1822 Make_Component_Declaration
(Loc
,
1823 Defining_Identifier
=> Comp
,
1824 Component_Definition
=>
1825 Make_Component_Definition
(Loc
,
1826 Subtype_Indication
=>
1828 (Defining_Identifier
(Ptr_Decl
),
1832 Make_Component_Declaration
(Loc
,
1833 Defining_Identifier
=> Comp
,
1834 Component_Definition
=>
1835 Make_Component_Definition
(Loc
,
1836 Subtype_Indication
=>
1837 New_Occurrence_Of
(Addr
, Loc
))));
1844 -- Now we can insert the AREC declarations into the body
1845 -- type ARECnT is record .. end record;
1846 -- pragma Suppress_Initialization (ARECnT);
1848 -- Note that we need to set the Suppress_Initialization
1849 -- flag after Decl_ARECnT has been analyzed.
1852 Make_Full_Type_Declaration
(Loc
,
1853 Defining_Identifier
=> STJ
.ARECnT
,
1855 Make_Record_Definition
(Loc
,
1857 Make_Component_List
(Loc
,
1858 Component_Items
=> Clist
)));
1859 Append_To
(Decls
, Decl_ARECnT
);
1861 -- type ARECnPT is access all ARECnT;
1864 Make_Full_Type_Declaration
(Loc
,
1865 Defining_Identifier
=> STJ
.ARECnPT
,
1867 Make_Access_To_Object_Definition
(Loc
,
1868 All_Present
=> True,
1869 Subtype_Indication
=>
1870 New_Occurrence_Of
(STJ
.ARECnT
, Loc
)));
1871 Append_To
(Decls
, Decl_ARECnPT
);
1873 -- ARECn : aliased ARECnT;
1876 Make_Object_Declaration
(Loc
,
1877 Defining_Identifier
=> STJ
.ARECn
,
1878 Aliased_Present
=> True,
1879 Object_Definition
=>
1880 New_Occurrence_Of
(STJ
.ARECnT
, Loc
));
1881 Append_To
(Decls
, Decl_ARECn
);
1883 -- ARECnP : constant ARECnPT := ARECn'Access;
1886 Make_Object_Declaration
(Loc
,
1887 Defining_Identifier
=> STJ
.ARECnP
,
1888 Constant_Present
=> True,
1889 Object_Definition
=>
1890 New_Occurrence_Of
(STJ
.ARECnPT
, Loc
),
1892 Make_Attribute_Reference
(Loc
,
1894 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1895 Attribute_Name
=> Name_Access
));
1896 Append_To
(Decls
, Decl_ARECnP
);
1898 -- If we are in a subprogram that has a static link that
1899 -- is passed in (as indicated by ARECnF being defined),
1900 -- then generate ARECn.ARECmU := ARECmF where m is
1901 -- one less than the current level to set the uplink.
1903 if Present
(STJ
.ARECnF
) then
1905 Make_Assignment_Statement
(Loc
,
1907 Make_Selected_Component
(Loc
,
1909 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
1911 New_Occurrence_Of
(STJ
.ARECnU
, Loc
)),
1913 New_Occurrence_Of
(STJ
.ARECnF
, Loc
));
1914 Append_To
(Decls
, Decl_Assign
);
1917 Decl_Assign
:= Empty
;
1920 if No
(Declarations
(STJ
.Bod
)) then
1921 Set_Declarations
(STJ
.Bod
, Decls
);
1923 Prepend_List_To
(Declarations
(STJ
.Bod
), Decls
);
1926 -- Analyze the newly inserted declarations. Note that we
1927 -- do not need to establish the whole scope stack, since
1928 -- we have already set all entity fields (so there will
1929 -- be no searching of upper scopes to resolve names). But
1930 -- we do set the scope of the current subprogram, so that
1931 -- newly created entities go in the right entity chain.
1933 -- We analyze with all checks suppressed (since we do
1934 -- not expect any exceptions).
1936 Push_Scope
(STJ
.Ent
);
1937 Analyze
(Decl_ARECnT
, Suppress
=> All_Checks
);
1939 -- Note that we need to call Set_Suppress_Initialization
1940 -- after Decl_ARECnT has been analyzed, but before
1941 -- analyzing Decl_ARECnP so that the flag is properly
1942 -- taking into account.
1944 Set_Suppress_Initialization
(STJ
.ARECnT
);
1946 Analyze
(Decl_ARECnPT
, Suppress
=> All_Checks
);
1947 Analyze
(Decl_ARECn
, Suppress
=> All_Checks
);
1948 Analyze
(Decl_ARECnP
, Suppress
=> All_Checks
);
1950 if Present
(Decl_Assign
) then
1951 Analyze
(Decl_Assign
, Suppress
=> All_Checks
);
1956 -- Next step, for each uplevel referenced entity, add
1957 -- assignment operations to set the component in the
1958 -- activation record.
1960 if Present
(STJ
.Uents
) then
1965 Elmt
:= First_Elmt
(STJ
.Uents
);
1966 while Present
(Elmt
) loop
1968 Ent
: constant Entity_Id
:= Node
(Elmt
);
1969 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
1970 Dec
: constant Node_Id
:=
1971 Declaration_Node
(Ent
);
1980 -- For parameters, we insert the assignment
1981 -- right after the declaration of ARECnP.
1982 -- For all other entities, we insert the
1983 -- assignment immediately after the
1984 -- declaration of the entity or after the
1985 -- freeze node if present.
1987 -- Note: we don't need to mark the entity
1988 -- as being aliased, because the address
1989 -- attribute will mark it as Address_Taken,
1990 -- and that is good enough.
1992 if Is_Formal
(Ent
) then
1995 elsif Has_Delayed_Freeze
(Ent
) then
1996 Ins
:= Freeze_Node
(Ent
);
2002 -- Build and insert the assignment:
2003 -- ARECn.nam := nam'Address
2004 -- or else 'Access for unconstrained array
2006 if Needs_Fat_Pointer
(Ent
) then
2007 Attr
:= Name_Access
;
2009 Attr
:= Name_Address
;
2012 Rhs
:= Make_Attribute_Reference
(Loc
,
2014 New_Occurrence_Of
(Ent
, Loc
),
2015 Attribute_Name
=> Attr
);
2017 -- If the entity is an unconstrained formal
2018 -- we wrap the attribute reference in an
2019 -- unchecked conversion to the type of the
2020 -- activation record component, to prevent
2021 -- spurious subtype conformance errors within
2025 and then not Is_Constrained
(Etype
(Ent
))
2027 -- Find target component and its type.
2029 Comp
:= First_Component
(STJ
.ARECnT
);
2030 while Chars
(Comp
) /= Chars
(Ent
) loop
2031 Comp
:= Next_Component
(Comp
);
2034 Rhs
:= Unchecked_Convert_To
(
2039 Make_Assignment_Statement
(Loc
,
2041 Make_Selected_Component
(Loc
,
2043 New_Occurrence_Of
(STJ
.ARECn
, Loc
),
2046 (Activation_Record_Component
2051 -- If we have a loop parameter, we have
2052 -- to insert before the first statement
2053 -- of the loop. Ins points to the
2054 -- N_Loop_Parameter_Specification or to
2055 -- an N_Iterator_Specification.
2058 (Ins
, N_Iterator_Specification
,
2059 N_Loop_Parameter_Specification
)
2061 -- Quantified expression are rewritten as
2062 -- loops during expansion.
2064 if Nkind
(Parent
(Ins
)) =
2065 N_Quantified_Expression
2073 (Parent
(Parent
(Ins
))));
2074 Insert_Before
(Ins
, Asn
);
2078 Insert_After
(Ins
, Asn
);
2081 -- Analyze the assignment statement. We do
2082 -- not need to establish the relevant scope
2083 -- stack entries here, because we have
2084 -- already set the correct entity references,
2085 -- so no name resolution is required, and no
2086 -- new entities are created, so we don't even
2087 -- need to set the current scope.
2089 -- We analyze with all checks suppressed
2090 -- (since we do not expect any exceptions).
2092 Analyze
(Asn
, Suppress
=> All_Checks
);
2105 -- Next step, process uplevel references. This has to be done in a
2106 -- separate pass, after completing the processing in Sub_Loop because we
2107 -- need all the AREC declarations generated, inserted, and analyzed so
2108 -- that the uplevel references can be successfully analyzed.
2110 Uplev_Refs
: for J
in Urefs
.First
.. Urefs
.Last
loop
2112 UPJ
: Uref_Entry
renames Urefs
.Table
(J
);
2115 -- Ignore type references, these are implicit references that do
2116 -- not need rewriting (e.g. the appearence in a conversion).
2117 -- Also ignore if no reference was specified or if the rewriting
2118 -- has already been done (this can happen if the N_Identifier
2119 -- occurs more than one time in the tree).
2122 or else not Is_Entity_Name
(UPJ
.Ref
)
2123 or else not Present
(Entity
(UPJ
.Ref
))
2128 -- Rewrite one reference
2130 Rewrite_One_Ref
: declare
2131 Loc
: constant Source_Ptr
:= Sloc
(UPJ
.Ref
);
2132 -- Source location for the reference
2134 Typ
: constant Entity_Id
:= Etype
(UPJ
.Ent
);
2135 -- The type of the referenced entity
2138 -- The actual subtype of the reference
2140 RS_Caller
: constant SI_Type
:= Subp_Index
(UPJ
.Caller
);
2141 -- Subp_Index for caller containing reference
2143 STJR
: Subp_Entry
renames Subps
.Table
(RS_Caller
);
2144 -- Subp_Entry for subprogram containing reference
2146 RS_Callee
: constant SI_Type
:= Subp_Index
(UPJ
.Callee
);
2147 -- Subp_Index for subprogram containing referenced entity
2149 STJE
: Subp_Entry
renames Subps
.Table
(RS_Callee
);
2150 -- Subp_Entry for subprogram containing referenced entity
2157 Atyp
:= Etype
(UPJ
.Ref
);
2159 if Ekind
(Atyp
) /= E_Record_Subtype
then
2160 Atyp
:= Get_Actual_Subtype
(UPJ
.Ref
);
2163 -- Ignore if no ARECnF entity for enclosing subprogram which
2164 -- probably happens as a result of not properly treating
2165 -- instance bodies. To be examined ???
2167 -- If this test is omitted, then the compilation of freeze.adb
2168 -- and inline.adb fail in unnesting mode.
2170 if No
(STJR
.ARECnF
) then
2174 -- Push the current scope, so that the pointer type Tnn, and
2175 -- any subsidiary entities resulting from the analysis of the
2176 -- rewritten reference, go in the right entity chain.
2178 Push_Scope
(STJR
.Ent
);
2180 -- Now we need to rewrite the reference. We have a reference
2181 -- from level STJR.Lev to level STJE.Lev. The general form of
2182 -- the rewritten reference for entity X is:
2184 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
2186 -- where a,b,c,d .. m =
2187 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
2189 pragma Assert
(STJR
.Lev
> STJE
.Lev
);
2191 -- Compute the prefix of X. Here are examples to make things
2192 -- clear (with parens to show groupings, the prefix is
2193 -- everything except the .X at the end).
2195 -- level 2 to level 1
2199 -- level 3 to level 1
2201 -- (AREC2F.AREC1U).X
2203 -- level 4 to level 1
2205 -- ((AREC3F.AREC2U).AREC1U).X
2207 -- level 6 to level 2
2209 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
2211 -- In the above, ARECnF and ARECnU are pointers, so there are
2212 -- explicit dereferences required for these occurrences.
2215 Make_Explicit_Dereference
(Loc
,
2216 Prefix
=> New_Occurrence_Of
(STJR
.ARECnF
, Loc
));
2218 for L
in STJE
.Lev
.. STJR
.Lev
- 2 loop
2219 SI
:= Enclosing_Subp
(SI
);
2221 Make_Explicit_Dereference
(Loc
,
2223 Make_Selected_Component
(Loc
,
2226 New_Occurrence_Of
(Subps
.Table
(SI
).ARECnU
, Loc
)));
2229 -- Get activation record component (must exist)
2231 Comp
:= Activation_Record_Component
(UPJ
.Ent
);
2232 pragma Assert
(Present
(Comp
));
2234 -- Do the replacement. If the component type is an access type,
2235 -- this is an uplevel reference for an entity that requires a
2236 -- fat pointer, so dereference the component.
2238 if Is_Access_Type
(Etype
(Comp
)) then
2240 Make_Explicit_Dereference
(Loc
,
2242 Make_Selected_Component
(Loc
,
2245 New_Occurrence_Of
(Comp
, Loc
))));
2249 Make_Attribute_Reference
(Loc
,
2250 Prefix
=> New_Occurrence_Of
(Atyp
, Loc
),
2251 Attribute_Name
=> Name_Deref
,
2252 Expressions
=> New_List
(
2253 Make_Selected_Component
(Loc
,
2256 New_Occurrence_Of
(Comp
, Loc
)))));
2259 -- Analyze and resolve the new expression. We do not need to
2260 -- establish the relevant scope stack entries here, because we
2261 -- have already set all the correct entity references, so no
2262 -- name resolution is needed. We have already set the current
2263 -- scope, so that any new entities created will be in the right
2266 -- We analyze with all checks suppressed (since we do not
2267 -- expect any exceptions)
2269 Analyze_And_Resolve
(UPJ
.Ref
, Typ
, Suppress
=> All_Checks
);
2271 end Rewrite_One_Ref
;
2276 end loop Uplev_Refs
;
2278 -- Finally, loop through all calls adding extra actual for the
2279 -- activation record where it is required.
2281 Adjust_Calls
: for J
in Calls
.First
.. Calls
.Last
loop
2283 -- Process a single call, we are only interested in a call to a
2284 -- subprogram that actually needs a pointer to an activation record,
2285 -- as indicated by the ARECnF entity being set. This excludes the
2286 -- top level subprogram, and any subprogram not having uplevel refs.
2288 Adjust_One_Call
: declare
2289 CTJ
: Call_Entry
renames Calls
.Table
(J
);
2290 STF
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Caller
));
2291 STT
: Subp_Entry
renames Subps
.Table
(Subp_Index
(CTJ
.Callee
));
2293 Loc
: constant Source_Ptr
:= Sloc
(CTJ
.N
);
2301 if Present
(STT
.ARECnF
)
2302 and then Nkind
(CTJ
.N
) in N_Subprogram_Call
2304 -- CTJ.N is a call to a subprogram which may require a pointer
2305 -- to an activation record. The subprogram containing the call
2306 -- is CTJ.From and the subprogram being called is CTJ.To, so we
2307 -- have a call from level STF.Lev to level STT.Lev.
2309 -- There are three possibilities:
2311 -- For a call to the same level, we just pass the activation
2312 -- record passed to the calling subprogram.
2314 if STF
.Lev
= STT
.Lev
then
2315 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
2317 -- For a call that goes down a level, we pass a pointer to the
2318 -- activation record constructed within the caller (which may
2319 -- be the outer-level subprogram, but also may be a more deeply
2322 elsif STT
.Lev
= STF
.Lev
+ 1 then
2323 Extra
:= New_Occurrence_Of
(STF
.ARECnP
, Loc
);
2325 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
2326 -- since it is not possible to do a downcall of more than
2329 -- For a call from level STF.Lev to level STT.Lev, we
2330 -- have to find the activation record needed by the
2331 -- callee. This is as follows:
2333 -- ARECaF.ARECbU.ARECcU....ARECmU
2335 -- where a,b,c .. m =
2336 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
2339 pragma Assert
(STT
.Lev
< STF
.Lev
);
2341 Extra
:= New_Occurrence_Of
(STF
.ARECnF
, Loc
);
2342 SubX
:= Subp_Index
(CTJ
.Caller
);
2343 for K
in reverse STT
.Lev
.. STF
.Lev
- 1 loop
2344 SubX
:= Enclosing_Subp
(SubX
);
2346 Make_Selected_Component
(Loc
,
2350 (Subps
.Table
(SubX
).ARECnU
, Loc
));
2354 -- Extra is the additional parameter to be added. Build a
2355 -- parameter association that we can append to the actuals.
2358 Make_Parameter_Association
(Loc
,
2360 New_Occurrence_Of
(STT
.ARECnF
, Loc
),
2361 Explicit_Actual_Parameter
=> Extra
);
2363 if No
(Parameter_Associations
(CTJ
.N
)) then
2364 Set_Parameter_Associations
(CTJ
.N
, Empty_List
);
2367 Append
(ExtraP
, Parameter_Associations
(CTJ
.N
));
2369 -- We need to deal with the actual parameter chain as well. The
2370 -- newly added parameter is always the last actual.
2372 Act
:= First_Named_Actual
(CTJ
.N
);
2375 Set_First_Named_Actual
(CTJ
.N
, Extra
);
2377 -- If call has been relocated (as with an expression in
2378 -- an aggregate), set First_Named pointer in original node
2379 -- as well, because that's the parent of the parameter list.
2381 Set_First_Named_Actual
2382 (Parent
(List_Containing
(ExtraP
)), Extra
);
2384 -- Here we must follow the chain and append the new entry
2393 PAN
:= Parent
(Act
);
2394 pragma Assert
(Nkind
(PAN
) = N_Parameter_Association
);
2395 NNA
:= Next_Named_Actual
(PAN
);
2398 Set_Next_Named_Actual
(PAN
, Extra
);
2407 -- Analyze and resolve the new actual. We do not need to
2408 -- establish the relevant scope stack entries here, because
2409 -- we have already set all the correct entity references, so
2410 -- no name resolution is needed.
2412 -- We analyze with all checks suppressed (since we do not
2413 -- expect any exceptions, and also we temporarily turn off
2414 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2415 -- references (not needed at this stage, and in fact causes
2416 -- a bit of recursive chaos).
2418 Opt
.Unnest_Subprogram_Mode
:= False;
2420 (Extra
, Etype
(STT
.ARECnF
), Suppress
=> All_Checks
);
2421 Opt
.Unnest_Subprogram_Mode
:= True;
2423 end Adjust_One_Call
;
2424 end loop Adjust_Calls
;
2427 end Unnest_Subprogram
;
2429 ------------------------
2430 -- Unnest_Subprograms --
2431 ------------------------
2433 procedure Unnest_Subprograms
(N
: Node_Id
) is
2434 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
;
2435 -- Tree visitor that search for outer level procedures with nested
2436 -- subprograms and invokes Unnest_Subprogram()
2442 procedure Do_Search
is new Traverse_Proc
(Search_Subprograms
);
2443 -- Subtree visitor instantiation
2445 ------------------------
2446 -- Search_Subprograms --
2447 ------------------------
2449 function Search_Subprograms
(N
: Node_Id
) return Traverse_Result
is
2451 if Nkind_In
(N
, N_Subprogram_Body
, N_Subprogram_Body_Stub
) then
2453 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
2456 -- We are only interested in subprograms (not generic
2457 -- subprograms), that have nested subprograms.
2459 if Is_Subprogram
(Spec_Id
)
2460 and then Has_Nested_Subprogram
(Spec_Id
)
2461 and then Is_Library_Level_Entity
(Spec_Id
)
2463 Unnest_Subprogram
(Spec_Id
, N
);
2467 -- The proper body of a stub may contain nested subprograms, and
2468 -- therefore must be visited explicitly. Nested stubs are examined
2469 -- recursively in Visit_Node.
2471 elsif Nkind
(N
) in N_Body_Stub
then
2472 Do_Search
(Library_Unit
(N
));
2474 -- Skip generic packages
2476 elsif Nkind
(N
) = N_Package_Body
2477 and then Ekind
(Corresponding_Spec
(N
)) = E_Generic_Package
2483 end Search_Subprograms
;
2485 -- Start of processing for Unnest_Subprograms
2488 if not Opt
.Unnest_Subprogram_Mode
or not Opt
.Expander_Active
then
2492 -- A specification will contain bodies if it contains instantiations so
2493 -- examine package or subprogram declaration of the main unit, when it
2496 if Nkind
(Unit
(N
)) = N_Package_Body
2497 or else (Nkind
(Unit
(N
)) = N_Subprogram_Body
2498 and then not Acts_As_Spec
(N
))
2500 Do_Search
(Library_Unit
(N
));
2504 end Unnest_Subprograms
;