1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-2019, 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 if Is_Formal (E) then
253 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
254 Typ := Full_View (Typ);
257 return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
261 end Needs_Fat_Pointer;
267 function Subp_Index (Sub : Entity_Id) return SI_Type is
268 E : Entity_Id := Sub;
271 pragma Assert (Is_Subprogram (E));
273 if Subps_Index (E) = Uint_0 then
274 E := Ultimate_Alias (E);
276 -- The body of a protected operation has a different name and
277 -- has been scanned at this point, and thus has an entry in the
280 if E = Sub and then Convention (E) = Convention_Protected then
281 E := Protected_Body_Subprogram (E);
284 if Ekind (E) = E_Function
285 and then Rewritten_For_C (E)
286 and then Present (Corresponding_Procedure (E))
288 E := Corresponding_Procedure (E);
292 pragma Assert (Subps_Index (E) /= Uint_0);
293 return SI_Type (UI_To_Int (Subps_Index (E)));
296 -----------------------
297 -- Unnest_Subprogram --
298 -----------------------
300 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
301 function AREC_Name (J : Pos; S : String) return Name_Id;
302 -- Returns name for string ARECjS, where j is the decimal value of j
304 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
305 -- Subp is the index of a subprogram which has a Lev greater than 1.
306 -- This function returns the index of the enclosing subprogram which
307 -- will have a Lev value one less than this.
309 function Img_Pos (N : Pos) return String;
310 -- Return image of N without leading blank
315 Clist : List_Id) return Name_Id;
316 -- This function returns the name to be used in the activation record to
317 -- reference the variable uplevel. Clist is the list of components that
318 -- have been created in the activation record so far. Normally the name
319 -- is just a copy of the Chars field of the entity. The exception is
320 -- when the name has already been used, in which case we suffix the name
321 -- with the index value Index to avoid duplication. This happens with
322 -- declare blocks and generic parameters at least.
328 function AREC_Name (J : Pos; S : String) return Name_Id is
330 return Name_Find ("AREC" & Img_Pos (J) & S);
337 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
338 STJ : Subp_Entry renames Subps.Table (Subp);
339 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
341 pragma Assert (STJ.Lev > 1);
342 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
350 function Img_Pos (N : Pos) return String is
351 Buf : String (1 .. 20);
359 Buf (Ptr) := Character'Val (48 + NV mod 10);
364 return Buf (Ptr + 1 .. Buf'Last);
374 Clist : List_Id) return Name_Id
383 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
385 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
392 -- Start of processing for Unnest_Subprogram
395 -- Nothing to do inside a generic (all processing is for instance)
397 if Inside_A_Generic then
401 -- If the main unit is a package body then we need to examine the spec
402 -- to determine whether the main unit is generic (the scope stack is not
403 -- present when this is called on the main unit).
405 if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
406 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
411 -- Only unnest when generating code for the main source unit
413 if not In_Extended_Main_Code_Unit (Subp_Body) then
417 -- This routine is called late, after the scope stack is gone. The
418 -- following creates a suitable dummy scope stack to be used for the
419 -- analyze/expand calls made from this routine.
423 -- First step, we must mark all nested subprograms that require a static
424 -- link (activation record) because either they contain explicit uplevel
425 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
426 -- this point), or they make calls to other subprograms in the same nest
427 -- that require a static link (in which case we set this flag).
429 -- This is a recursive definition, and to implement this, we have to
430 -- build a call graph for the set of nested subprograms, and then go
431 -- over this graph to implement recursively the invariant that if a
432 -- subprogram has a call to a subprogram requiring a static link, then
433 -- the calling subprogram requires a static link.
435 -- First populate the above tables
437 Subps_First := Subps.Last + 1;
441 Build_Tables : declare
442 Current_Subprogram : Entity_Id := Empty;
443 -- When we scan a subprogram body, we set Current_Subprogram to the
444 -- corresponding entity. This gets recursively saved and restored.
446 function Visit_Node (N : Node_Id) return Traverse_Result;
447 -- Visit a single node in Subp
453 procedure Visit is new Traverse_Proc (Visit_Node);
454 -- Used to traverse the body of Subp, populating the tables
460 function Visit_Node (N : Node_Id) return Traverse_Result is
465 procedure Check_Static_Type
469 Check_Designated : Boolean := False);
470 -- Given a type T, checks if it is a static type defined as a type
471 -- with no dynamic bounds in sight. If so, the only action is to
472 -- set Is_Static_Type True for T. If T is not a static type, then
473 -- all types with dynamic bounds associated with T are detected,
474 -- and their bounds are marked as uplevel referenced if not at the
475 -- library level, and DT is set True. If N is specified, it's the
476 -- node that will need to be replaced. If not specified, it means
477 -- we can't do a replacement because the bound is implicit.
479 -- If Check_Designated is True and T or its full view is an access
480 -- type, check whether the designated type has dynamic bounds.
482 procedure Note_Uplevel_Ref
487 -- Called when we detect an explicit or implicit uplevel reference
488 -- from within Caller to entity E declared in Callee. E can be a
489 -- an object or a type.
491 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
492 -- Enter a subprogram whose body is visible or which is a
493 -- subprogram instance into the subprogram table.
495 -----------------------
496 -- Check_Static_Type --
497 -----------------------
499 procedure Check_Static_Type
503 Check_Designated : Boolean := False)
505 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
506 -- N is the bound of a dynamic type. This procedure notes that
507 -- this bound is uplevel referenced, it can handle references
508 -- to entities (typically _FIRST and _LAST entities), and also
509 -- attribute references of the form T'name (name is typically
510 -- FIRST or LAST) where T is the uplevel referenced bound.
511 -- Ref, if Present, is the location of the reference to
514 ------------------------
515 -- Note_Uplevel_Bound --
516 ------------------------
518 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
520 -- Entity name case. Make sure that the entity is declared
521 -- in a subprogram. This may not be the case for for a type
522 -- in a loop appearing in a precondition.
523 -- Exclude explicitly discriminants (that can appear
524 -- in bounds of discriminated components).
526 if Is_Entity_Name (N) then
527 if Present (Entity (N))
528 and then not Is_Type (Entity (N))
529 and then Present (Enclosing_Subprogram (Entity (N)))
530 and then Ekind (Entity (N)) /= E_Discriminant
535 Caller => Current_Subprogram,
536 Callee => Enclosing_Subprogram (Entity (N)));
539 -- Attribute or indexed component case
541 elsif Nkind_In (N, N_Attribute_Reference,
544 Note_Uplevel_Bound (Prefix (N), Ref);
546 -- The indices of the indexed components, or the
547 -- associated expressions of an attribute reference,
548 -- may also involve uplevel references.
554 Expr := First (Expressions (N));
555 while Present (Expr) loop
556 Note_Uplevel_Bound (Expr, Ref);
561 -- The type of the prefix may be have an uplevel
562 -- reference if this needs bounds.
564 if Nkind (N) = N_Attribute_Reference then
566 Attr : constant Attribute_Id :=
567 Get_Attribute_Id (Attribute_Name (N));
568 DT : Boolean := False;
571 if (Attr = Attribute_First
572 or else Attr = Attribute_Last
573 or else Attr = Attribute_Length)
574 and then Is_Constrained (Etype (Prefix (N)))
577 (Etype (Prefix (N)), Empty, DT);
582 -- Binary operator cases. These can apply to arrays for
583 -- which we may need bounds.
585 elsif Nkind (N) in N_Binary_Op then
586 Note_Uplevel_Bound (Left_Opnd (N), Ref);
587 Note_Uplevel_Bound (Right_Opnd (N), Ref);
589 -- Unary operator case
591 elsif Nkind (N) in N_Unary_Op then
592 Note_Uplevel_Bound (Right_Opnd (N), Ref);
594 -- Explicit dereference and selected component case
596 elsif Nkind_In (N, N_Explicit_Dereference,
597 N_Selected_Component)
599 Note_Uplevel_Bound (Prefix (N), Ref);
601 -- Conditional expressions.
603 elsif Nkind (N) = N_If_Expression then
608 Expr := First (Expressions (N));
609 while Present (Expr) loop
610 Note_Uplevel_Bound (Expr, Ref);
615 elsif Nkind (N) = N_Case_Expression then
617 Alternative : Node_Id;
620 Note_Uplevel_Bound (Expression (N), Ref);
622 Alternative := First (Alternatives (N));
623 while Present (Alternative) loop
624 Note_Uplevel_Bound (Expression (Alternative), Ref);
630 elsif Nkind (N) = N_Type_Conversion then
631 Note_Uplevel_Bound (Expression (N), Ref);
633 end Note_Uplevel_Bound;
635 -- Start of processing for Check_Static_Type
638 -- If already marked static, immediate return
640 if Is_Static_Type (T) and then not Check_Designated then
644 -- If the type is at library level, always consider it static,
645 -- since such uplevel references are irrelevant.
647 if Is_Library_Level_Entity (T) then
648 Set_Is_Static_Type (T);
652 -- Otherwise figure out what the story is with this type
654 -- For a scalar type, check bounds
656 if Is_Scalar_Type (T) then
658 -- If both bounds static, then this is a static type
661 LB : constant Node_Id := Type_Low_Bound (T);
662 UB : constant Node_Id := Type_High_Bound (T);
665 if not Is_Static_Expression (LB) then
666 Note_Uplevel_Bound (LB, N);
670 if not Is_Static_Expression (UB) then
671 Note_Uplevel_Bound (UB, N);
676 -- For record type, check all components and discriminant
677 -- constraints if present.
679 elsif Is_Record_Type (T) then
685 C := First_Component_Or_Discriminant (T);
686 while Present (C) loop
687 Check_Static_Type (Etype (C), N, DT);
688 Next_Component_Or_Discriminant (C);
691 if Has_Discriminants (T)
692 and then Present (Discriminant_Constraint (T))
694 D := First_Elmt (Discriminant_Constraint (T));
695 while Present (D) loop
696 if not Is_Static_Expression (Node (D)) then
697 Note_Uplevel_Bound (Node (D), N);
706 -- For array type, check index types and component type
708 elsif Is_Array_Type (T) then
712 Check_Static_Type (Component_Type (T), N, DT);
714 IX := First_Index (T);
715 while Present (IX) loop
716 Check_Static_Type (Etype (IX), N, DT);
721 -- For private type, examine whether full view is static
723 elsif Is_Incomplete_Or_Private_Type (T)
724 and then Present (Full_View (T))
726 Check_Static_Type (Full_View (T), N, DT, Check_Designated);
728 if Is_Static_Type (Full_View (T)) then
729 Set_Is_Static_Type (T);
732 -- For access types, check designated type when required
734 elsif Is_Access_Type (T) and then Check_Designated then
735 Check_Static_Type (Directly_Designated_Type (T), N, DT);
737 -- For now, ignore other types
744 Set_Is_Static_Type (T);
746 end Check_Static_Type;
748 ----------------------
749 -- Note_Uplevel_Ref --
750 ----------------------
752 procedure Note_Uplevel_Ref
758 Full_E : Entity_Id := E;
760 -- Nothing to do for static type
762 if Is_Static_Type (E) then
766 -- Nothing to do if Caller and Callee are the same
768 if Caller = Callee then
771 -- Callee may be a function that returns an array, and that has
772 -- been rewritten as a procedure. If caller is that procedure,
773 -- nothing to do either.
775 elsif Ekind (Callee) = E_Function
776 and then Rewritten_For_C (Callee)
777 and then Corresponding_Procedure (Callee) = Caller
781 elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then
785 -- We have a new uplevel referenced entity
787 if Ekind (E) = E_Constant and then Present (Full_View (E)) then
788 Full_E := Full_View (E);
791 -- All we do at this stage is to add the uplevel reference to
792 -- the table. It's too early to do anything else, since this
793 -- uplevel reference may come from an unreachable subprogram
794 -- in which case the entry will be deleted.
796 Urefs.Append ((N, Full_E, Caller, Callee));
797 end Note_Uplevel_Ref;
799 -------------------------
800 -- Register_Subprogram --
801 -------------------------
803 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
804 L : constant Nat := Get_Level (Subp, E);
807 -- Subprograms declared in tasks and protected types cannot be
808 -- eliminated because calls to them may be in other units, so
809 -- they must be treated as reachable.
815 Reachable => In_Synchronized_Unit (E)
816 or else Address_Taken (E),
818 Declares_AREC => False,
828 Set_Subps_Index (E, UI_From_Int (Subps.Last));
830 -- If we marked this reachable because it's in a synchronized
831 -- unit, we have to mark all enclosing subprograms as reachable
834 if In_Synchronized_Unit (E) then
839 for J in reverse 1 .. L - 1 loop
840 S := Enclosing_Subprogram (S);
841 Subps.Table (Subp_Index (S)).Reachable := True;
845 end Register_Subprogram;
847 -- Start of processing for Visit_Node
852 -- Record a subprogram call
855 | N_Procedure_Call_Statement
857 -- We are only interested in direct calls, not indirect
858 -- calls (where Name (N) is an explicit dereference) at
861 if Nkind (Name (N)) in N_Has_Entity then
862 Ent := Entity (Name (N));
864 -- We are only interested in calls to subprograms nested
865 -- within Subp. Calls to Subp itself or to subprograms
866 -- outside the nested structure do not affect us.
868 if Scope_Within (Ent, Subp)
869 and then Is_Subprogram (Ent)
870 and then not Is_Imported (Ent)
872 Append_Unique_Call ((N, Current_Subprogram, Ent));
876 -- For all calls where the formal is an unconstrained array
877 -- and the actual is constrained we need to check the bounds
878 -- for uplevel references.
882 DT : Boolean := False;
887 if Nkind (Name (N)) = N_Explicit_Dereference then
888 Subp := Etype (Name (N));
890 Subp := Entity (Name (N));
893 Actual := First_Actual (N);
894 Formal := First_Formal_With_Extras (Subp);
895 while Present (Actual) loop
896 if Is_Array_Type (Etype (Formal))
897 and then not Is_Constrained (Etype (Formal))
898 and then Is_Constrained (Etype (Actual))
900 Check_Static_Type (Etype (Actual), Empty, DT);
903 Next_Actual (Actual);
904 Next_Formal_With_Extras (Formal);
908 -- An At_End_Proc in a statement sequence indicates that there
909 -- is a call from the enclosing construct or block to that
910 -- subprogram. As above, the called entity must be local and
913 when N_Handled_Sequence_Of_Statements =>
914 if Present (At_End_Proc (N))
915 and then Scope_Within (Entity (At_End_Proc (N)), Subp)
916 and then not Is_Imported (Entity (At_End_Proc (N)))
919 ((N, Current_Subprogram, Entity (At_End_Proc (N))));
922 -- Similarly, the following constructs include a semantic
923 -- attribute Procedure_To_Call that must be handled like
924 -- other calls. Likewise for attribute Storage_Pool.
927 | N_Extended_Return_Statement
929 | N_Simple_Return_Statement
932 Pool : constant Entity_Id := Storage_Pool (N);
933 Proc : constant Entity_Id := Procedure_To_Call (N);
937 and then Scope_Within (Proc, Subp)
938 and then not Is_Imported (Proc)
940 Append_Unique_Call ((N, Current_Subprogram, Proc));
944 and then not Is_Library_Level_Entity (Pool)
945 and then Scope_Within_Or_Same (Scope (Pool), Subp)
947 Caller := Current_Subprogram;
948 Callee := Enclosing_Subprogram (Pool);
950 if Callee /= Caller then
951 Note_Uplevel_Ref (Pool, Empty, Caller, Callee);
956 -- For an allocator with a qualified expression, check type
957 -- of expression being qualified. The explicit type name is
958 -- handled as an entity reference.
960 if Nkind (N) = N_Allocator
961 and then Nkind (Expression (N)) = N_Qualified_Expression
964 DT : Boolean := False;
967 (Etype (Expression (Expression (N))), Empty, DT);
970 -- For a Return or Free (all other nodes we handle here),
971 -- we usually need the size of the object, so we need to be
972 -- sure that any nonstatic bounds of the expression's type
973 -- that are uplevel are handled.
975 elsif Nkind (N) /= N_Allocator
976 and then Present (Expression (N))
979 DT : Boolean := False;
982 (Etype (Expression (N)),
985 Check_Designated => Nkind (N) = N_Free_Statement);
989 -- A 'Access reference is a (potential) call. So is 'Address,
990 -- in particular on imported subprograms. Other attributes
991 -- require special handling.
993 when N_Attribute_Reference =>
995 Attr : constant Attribute_Id :=
996 Get_Attribute_Id (Attribute_Name (N));
999 when Attribute_Access
1000 | Attribute_Unchecked_Access
1001 | Attribute_Unrestricted_Access
1004 if Nkind (Prefix (N)) in N_Has_Entity then
1005 Ent := Entity (Prefix (N));
1007 -- We only need to examine calls to subprograms
1008 -- nested within current Subp.
1010 if Scope_Within (Ent, Subp) then
1011 if Is_Imported (Ent) then
1014 elsif Is_Subprogram (Ent) then
1016 ((N, Current_Subprogram, Ent));
1021 -- References to bounds can be uplevel references if
1022 -- the type isn't static.
1024 when Attribute_First
1028 -- Special-case attributes of objects whose bounds
1029 -- may be uplevel references. More complex prefixes
1030 -- handled during full traversal. Note that if the
1031 -- nominal subtype of the prefix is unconstrained,
1032 -- the bound must be obtained from the object, not
1033 -- from the (possibly) uplevel reference.
1035 if Is_Constrained (Etype (Prefix (N))) then
1037 DT : Boolean := False;
1040 (Etype (Prefix (N)), Empty, DT);
1051 -- Component associations in aggregates are either static or
1052 -- else the aggregate will be expanded into assignments, in
1053 -- which case the expression is analyzed later and provides
1054 -- no relevant code generation.
1056 when N_Component_Association =>
1057 if No (Expression (N))
1058 or else No (Etype (Expression (N)))
1063 -- Generic associations are not analyzed: the actuals are
1064 -- transferred to renaming and subtype declarations that
1065 -- are the ones that must be examined.
1067 when N_Generic_Association =>
1070 -- Indexed references can be uplevel if the type isn't static
1071 -- and if the lower bound (or an inner bound for a multi-
1072 -- dimensional array) is uplevel.
1074 when N_Indexed_Component
1077 if Is_Constrained (Etype (Prefix (N))) then
1079 DT : Boolean := False;
1081 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1085 -- A selected component can have an implicit up-level
1086 -- reference due to the bounds of previous fields in the
1087 -- record. We simplify the processing here by examining
1088 -- all components of the record.
1090 -- Selected components appear as unit names and end labels
1091 -- for child units. Prefixes of these nodes denote parent
1092 -- units and carry no type information so they are skipped.
1094 when N_Selected_Component =>
1095 if Present (Etype (Prefix (N))) then
1097 DT : Boolean := False;
1099 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1103 -- For EQ/NE comparisons, we need the type of the operands
1104 -- in order to do the comparison, which means we need the
1111 DT : Boolean := False;
1113 Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT);
1114 Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
1117 -- Likewise we need the sizes to compute how much to move in
1120 when N_Assignment_Statement =>
1122 DT : Boolean := False;
1124 Check_Static_Type (Etype (Name (N)), Empty, DT);
1125 Check_Static_Type (Etype (Expression (N)), Empty, DT);
1128 -- Record a subprogram. We record a subprogram body that acts
1129 -- as a spec. Otherwise we record a subprogram declaration,
1130 -- providing that it has a corresponding body we can get hold
1131 -- of. The case of no corresponding body being available is
1134 when N_Subprogram_Body =>
1135 Ent := Unique_Defining_Entity (N);
1137 -- Ignore generic subprogram
1139 if Is_Generic_Subprogram (Ent) then
1143 -- Make new entry in subprogram table if not already made
1145 Register_Subprogram (Ent, N);
1147 -- We make a recursive call to scan the subprogram body, so
1148 -- that we can save and restore Current_Subprogram.
1151 Save_CS : constant Entity_Id := Current_Subprogram;
1155 Current_Subprogram := Ent;
1157 -- Scan declarations
1159 Decl := First (Declarations (N));
1160 while Present (Decl) loop
1167 Visit (Handled_Statement_Sequence (N));
1169 -- Restore current subprogram setting
1171 Current_Subprogram := Save_CS;
1174 -- Now at this level, return skipping the subprogram body
1175 -- descendants, since we already took care of them!
1179 -- If we have a body stub, visit the associated subunit, which
1180 -- is a semantic descendant of the stub.
1183 Visit (Library_Unit (N));
1185 -- A declaration of a wrapper package indicates a subprogram
1186 -- instance for which there is no explicit body. Enter the
1187 -- subprogram instance in the table.
1189 when N_Package_Declaration =>
1190 if Is_Wrapper_Package (Defining_Entity (N)) then
1192 (Related_Instance (Defining_Entity (N)), Empty);
1195 -- Skip generic declarations
1197 when N_Generic_Declaration =>
1200 -- Skip generic package body
1202 when N_Package_Body =>
1203 if Present (Corresponding_Spec (N))
1204 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
1209 -- Pragmas and component declarations are ignored. Quantified
1210 -- expressions are expanded into explicit loops and the
1211 -- original epression must be ignored.
1213 when N_Component_Declaration
1215 | N_Quantified_Expression
1219 -- We want to skip the function spec for a generic function
1220 -- to avoid looking at any generic types that might be in
1223 when N_Function_Specification =>
1224 if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then
1228 -- Otherwise record an uplevel reference in a local identifier
1231 if Nkind (N) in N_Has_Entity
1232 and then Present (Entity (N))
1236 -- Only interested in entities declared within our nest
1238 if not Is_Library_Level_Entity (Ent)
1239 and then Scope_Within_Or_Same (Scope (Ent), Subp)
1241 -- Skip entities defined in inlined subprograms
1244 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
1246 -- Constants and variables are potentially uplevel
1247 -- references to global declarations.
1250 (Ekind_In (Ent, E_Constant,
1254 -- Formals are interesting, but not if being used
1255 -- as mere names of parameters for name notation
1261 (Nkind (Parent (N)) = N_Parameter_Association
1262 and then Selector_Name (Parent (N)) = N))
1264 -- Types other than known Is_Static types are
1265 -- potentially interesting.
1268 (Is_Type (Ent) and then not Is_Static_Type (Ent)))
1270 -- Here we have a potentially interesting uplevel
1271 -- reference to examine.
1273 if Is_Type (Ent) then
1275 DT : Boolean := False;
1278 Check_Static_Type (Ent, N, DT);
1283 Caller := Current_Subprogram;
1284 Callee := Enclosing_Subprogram (Ent);
1287 and then (not Is_Static_Type (Ent)
1288 or else Needs_Fat_Pointer (Ent))
1290 Note_Uplevel_Ref (Ent, N, Caller, Callee);
1292 -- Check the type of a formal parameter of the current
1293 -- subprogram, whose formal type may be an uplevel
1296 elsif Is_Formal (Ent)
1297 and then Scope (Ent) = Current_Subprogram
1300 DT : Boolean := False;
1303 Check_Static_Type (Etype (Ent), Empty, DT);
1310 -- Fall through to continue scanning children of this node
1315 -- Start of processing for Build_Tables
1318 -- Traverse the body to get subprograms, calls and uplevel references
1323 -- Now do the first transitive closure which determines which
1324 -- subprograms in the nest are actually reachable.
1326 Reachable_Closure : declare
1330 Subps.Table (Subps_First).Reachable := True;
1332 -- We use a simple minded algorithm as follows (obviously this can
1333 -- be done more efficiently, using one of the standard algorithms
1334 -- for efficient transitive closure computation, but this is simple
1335 -- and most likely fast enough that its speed does not matter).
1337 -- Repeatedly scan the list of calls. Any time we find a call from
1338 -- A to B, where A is reachable, but B is not, then B is reachable,
1339 -- and note that we have made a change by setting Modified True. We
1340 -- repeat this until we make a pass with no modifications.
1344 Inner : for J in Calls.First .. Calls.Last loop
1346 CTJ : Call_Entry renames Calls.Table (J);
1348 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1349 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1351 SUBF : Subp_Entry renames Subps.Table (SINF);
1352 SUBT : Subp_Entry renames Subps.Table (SINT);
1355 if SUBF.Reachable and then not SUBT.Reachable then
1356 SUBT.Reachable := True;
1362 exit Outer when not Modified;
1364 end Reachable_Closure;
1366 -- Remove calls from unreachable subprograms
1373 for J in Calls.First .. Calls.Last loop
1375 CTJ : Call_Entry renames Calls.Table (J);
1377 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1378 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1380 SUBF : Subp_Entry renames Subps.Table (SINF);
1381 SUBT : Subp_Entry renames Subps.Table (SINT);
1384 if SUBF.Reachable then
1385 pragma Assert (SUBT.Reachable);
1386 New_Index := New_Index + 1;
1387 Calls.Table (New_Index) := Calls.Table (J);
1392 Calls.Set_Last (New_Index);
1395 -- Remove uplevel references from unreachable subprograms
1402 for J in Urefs.First .. Urefs.Last loop
1404 URJ : Uref_Entry renames Urefs.Table (J);
1406 SINF : constant SI_Type := Subp_Index (URJ.Caller);
1407 SINT : constant SI_Type := Subp_Index (URJ.Callee);
1409 SUBF : Subp_Entry renames Subps.Table (SINF);
1410 SUBT : Subp_Entry renames Subps.Table (SINT);
1415 -- Keep reachable reference
1417 if SUBF.Reachable then
1418 New_Index := New_Index + 1;
1419 Urefs.Table (New_Index) := Urefs.Table (J);
1421 -- And since we know we are keeping this one, this is a good
1422 -- place to fill in information for a good reference.
1424 -- Mark all enclosing subprograms need to declare AREC
1428 S := Enclosing_Subprogram (S);
1430 -- If we are at the top level, as can happen with
1431 -- references to formals in aspects of nested subprogram
1432 -- declarations, there are no further subprograms to mark
1433 -- as requiring activation records.
1438 SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
1440 SUBI.Declares_AREC := True;
1442 -- If this entity was marked reachable because it is
1443 -- in a task or protected type, there may not appear
1444 -- to be any calls to it, which would normally adjust
1445 -- the levels of the parent subprograms. So we need to
1446 -- be sure that the uplevel reference of that entity
1447 -- takes into account possible calls.
1449 if In_Synchronized_Unit (SUBF.Ent)
1450 and then SUBT.Lev < SUBI.Uplevel_Ref
1452 SUBI.Uplevel_Ref := SUBT.Lev;
1456 exit when S = URJ.Callee;
1459 -- Add to list of uplevel referenced entities for Callee.
1460 -- We do not add types to this list, only actual references
1461 -- to objects that will be referenced uplevel, and we use
1462 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1463 -- duplicate entries in the list. Discriminants are also
1464 -- excluded, only the enclosing object can appear in the
1467 if not Is_Uplevel_Referenced_Entity (URJ.Ent)
1468 and then Ekind (URJ.Ent) /= E_Discriminant
1470 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
1471 Append_New_Elmt (URJ.Ent, SUBT.Uents);
1474 -- And set uplevel indication for caller
1476 if SUBT.Lev < SUBF.Uplevel_Ref then
1477 SUBF.Uplevel_Ref := SUBT.Lev;
1483 Urefs.Set_Last (New_Index);
1486 -- Remove unreachable subprograms from Subps table. Note that we do
1487 -- this after eliminating entries from the other two tables, since
1488 -- those elimination steps depend on referencing the Subps table.
1494 New_SI := Subps_First - 1;
1495 for J in Subps_First .. Subps.Last loop
1497 STJ : Subp_Entry renames Subps.Table (J);
1502 -- Subprogram is reachable, copy and reset index
1504 if STJ.Reachable then
1505 New_SI := New_SI + 1;
1506 Subps.Table (New_SI) := STJ;
1507 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
1509 -- Subprogram is not reachable
1512 -- Clear index, since no longer active
1514 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
1516 -- Output debug information if -gnatd.3 set
1518 if Debug_Flag_Dot_3 then
1519 Write_Str ("Eliminate ");
1520 Write_Name (Chars (Subps.Table (J).Ent));
1522 Write_Location (Sloc (Subps.Table (J).Ent));
1523 Write_Str (" (not referenced)");
1527 -- Rewrite declaration, body, and corresponding freeze node
1528 -- to null statements.
1530 -- A subprogram instantiation does not have an explicit
1531 -- body. If unused, we could remove the corresponding
1532 -- wrapper package and its body (TBD).
1534 if Present (STJ.Bod) then
1535 Spec := Corresponding_Spec (STJ.Bod);
1537 if Present (Spec) then
1538 Decl := Parent (Declaration_Node (Spec));
1539 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
1541 if Present (Freeze_Node (Spec)) then
1542 Rewrite (Freeze_Node (Spec),
1543 Make_Null_Statement (Sloc (Decl)));
1547 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
1553 Subps.Set_Last (New_SI);
1556 -- Now it is time for the second transitive closure, which follows calls
1557 -- and makes sure that A calls B, and B has uplevel references, then A
1558 -- is also marked as having uplevel references.
1560 Closure_Uplevel : declare
1564 -- We use a simple minded algorithm as follows (obviously this can
1565 -- be done more efficiently, using one of the standard algorithms
1566 -- for efficient transitive closure computation, but this is simple
1567 -- and most likely fast enough that its speed does not matter).
1569 -- Repeatedly scan the list of calls. Any time we find a call from
1570 -- A to B, where B has uplevel references, make sure that A is marked
1571 -- as having at least the same level of uplevel referencing.
1575 Inner2 : for J in Calls.First .. Calls.Last loop
1577 CTJ : Call_Entry renames Calls.Table (J);
1578 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1579 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1580 SUBF : Subp_Entry renames Subps.Table (SINF);
1581 SUBT : Subp_Entry renames Subps.Table (SINT);
1583 if SUBT.Lev > SUBT.Uplevel_Ref
1584 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
1586 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
1592 exit Outer2 when not Modified;
1594 end Closure_Uplevel;
1596 -- We have one more step before the tables are complete. An uplevel
1597 -- call from subprogram A to subprogram B where subprogram B has uplevel
1598 -- references is in effect an uplevel reference, and must arrange for
1599 -- the proper activation link to be passed.
1601 for J in Calls.First .. Calls.Last loop
1603 CTJ : Call_Entry renames Calls.Table (J);
1605 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1606 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1608 SUBF : Subp_Entry renames Subps.Table (SINF);
1609 SUBT : Subp_Entry renames Subps.Table (SINT);
1614 -- If callee has uplevel references
1616 if SUBT.Uplevel_Ref < SUBT.Lev
1618 -- And this is an uplevel call
1620 and then SUBT.Lev < SUBF.Lev
1622 -- We need to arrange for finding the uplink
1626 A := Enclosing_Subprogram (A);
1627 Subps.Table (Subp_Index (A)).Declares_AREC := True;
1628 exit when A = CTJ.Callee;
1630 -- In any case exit when we get to the outer level. This
1631 -- happens in some odd cases with generics (in particular
1632 -- sem_ch3.adb does not compile without this kludge ???).
1640 -- The tables are now complete, so we can record the last index in the
1641 -- Subps table for later reference in Cprint.
1643 Subps.Table (Subps_First).Last := Subps.Last;
1645 -- Next step, create the entities for code we will insert. We do this
1646 -- at the start so that all the entities are defined, regardless of the
1647 -- order in which we do the code insertions.
1649 Create_Entities : for J in Subps_First .. Subps.Last loop
1651 STJ : Subp_Entry renames Subps.Table (J);
1652 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1655 -- First we create the ARECnF entity for the additional formal for
1656 -- all subprograms which need an activation record passed.
1658 if STJ.Uplevel_Ref < STJ.Lev then
1660 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
1663 -- Define the AREC entities for the activation record if needed
1665 if STJ.Declares_AREC then
1667 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
1669 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
1671 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
1673 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
1675 -- Define uplink component entity if inner nesting case
1677 if Present (STJ.ARECnF) then
1679 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1683 end loop Create_Entities;
1685 -- Loop through subprograms
1688 Addr : Entity_Id := Empty;
1691 for J in Subps_First .. Subps.Last loop
1693 STJ : Subp_Entry renames Subps.Table (J);
1696 -- First add the extra formal if needed. This applies to all
1697 -- nested subprograms that require an activation record to be
1698 -- passed, as indicated by ARECnF being defined.
1700 if Present (STJ.ARECnF) then
1702 -- Here we need the extra formal. We do the expansion and
1703 -- analysis of this manually, since it is fairly simple,
1704 -- and it is not obvious how we can get what we want if we
1705 -- try to use the normal Analyze circuit.
1707 Add_Extra_Formal : declare
1708 Encl : constant SI_Type := Enclosing_Subp (J);
1709 STJE : Subp_Entry renames Subps.Table (Encl);
1710 -- Index and Subp_Entry for enclosing routine
1712 Form : constant Entity_Id := STJ.ARECnF;
1713 -- The formal to be added. Note that n here is one less
1714 -- than the level of the subprogram itself (STJ.Ent).
1716 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1717 -- S is an N_Function/Procedure_Specification node, and F
1718 -- is the new entity to add to this subprogramn spec as
1719 -- the last Extra_Formal.
1721 ----------------------
1722 -- Add_Form_To_Spec --
1723 ----------------------
1725 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1726 Sub : constant Entity_Id := Defining_Entity (S);
1730 -- Case of at least one Extra_Formal is present, set
1731 -- ARECnF as the new last entry in the list.
1733 if Present (Extra_Formals (Sub)) then
1734 Ent := Extra_Formals (Sub);
1735 while Present (Extra_Formal (Ent)) loop
1736 Ent := Extra_Formal (Ent);
1739 Set_Extra_Formal (Ent, F);
1741 -- No Extra formals present
1744 Set_Extra_Formals (Sub, F);
1745 Ent := Last_Formal (Sub);
1747 if Present (Ent) then
1748 Set_Extra_Formal (Ent, F);
1751 end Add_Form_To_Spec;
1753 -- Start of processing for Add_Extra_Formal
1756 -- Decorate the new formal entity
1758 Set_Scope (Form, STJ.Ent);
1759 Set_Ekind (Form, E_In_Parameter);
1760 Set_Etype (Form, STJE.ARECnPT);
1761 Set_Mechanism (Form, By_Copy);
1762 Set_Never_Set_In_Source (Form, True);
1763 Set_Analyzed (Form, True);
1764 Set_Comes_From_Source (Form, False);
1765 Set_Is_Activation_Record (Form, True);
1767 -- Case of only body present
1769 if Acts_As_Spec (STJ.Bod) then
1770 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1772 -- Case of separate spec
1775 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1777 end Add_Extra_Formal;
1780 -- Processing for subprograms that declare an activation record
1782 if Present (STJ.ARECn) then
1784 -- Local declarations for one such subprogram
1787 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1789 Decls : constant List_Id := New_List;
1790 -- List of new declarations we create
1795 Decl_Assign : Node_Id;
1796 -- Assigment to set uplink, Empty if none
1798 Decl_ARECnT : Node_Id;
1799 Decl_ARECnPT : Node_Id;
1800 Decl_ARECn : Node_Id;
1801 Decl_ARECnP : Node_Id;
1802 -- Declaration nodes for the AREC entities we build
1805 -- Build list of component declarations for ARECnT and
1806 -- load System.Address.
1808 Clist := Empty_List;
1811 Addr := RTE (RE_Address);
1814 -- If we are in a subprogram that has a static link that
1815 -- is passed in (as indicated by ARECnF being defined),
1816 -- then include ARECnU : ARECmPT where ARECmPT comes from
1817 -- the level one higher than the current level, and the
1818 -- entity ARECnPT comes from the enclosing subprogram.
1820 if Present (STJ.ARECnF) then
1823 renames Subps.Table (Enclosing_Subp (J));
1826 Make_Component_Declaration (Loc,
1827 Defining_Identifier => STJ.ARECnU,
1828 Component_Definition =>
1829 Make_Component_Definition (Loc,
1830 Subtype_Indication =>
1831 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1835 -- Add components for uplevel referenced entities
1837 if Present (STJ.Uents) then
1844 -- 1's origin of index in list of elements. This is
1845 -- used to uniquify names if needed in Upref_Name.
1848 Elmt := First_Elmt (STJ.Uents);
1850 while Present (Elmt) loop
1851 Uent := Node (Elmt);
1855 Make_Defining_Identifier (Loc,
1856 Chars => Upref_Name (Uent, Indx, Clist));
1858 Set_Activation_Record_Component
1861 if Needs_Fat_Pointer (Uent) then
1863 -- Build corresponding access type
1866 Build_Access_Type_Decl
1867 (Etype (Uent), STJ.Ent);
1868 Append_To (Decls, Ptr_Decl);
1870 -- And use its type in the corresponding
1874 Make_Component_Declaration (Loc,
1875 Defining_Identifier => Comp,
1876 Component_Definition =>
1877 Make_Component_Definition (Loc,
1878 Subtype_Indication =>
1880 (Defining_Identifier (Ptr_Decl),
1884 Make_Component_Declaration (Loc,
1885 Defining_Identifier => Comp,
1886 Component_Definition =>
1887 Make_Component_Definition (Loc,
1888 Subtype_Indication =>
1889 New_Occurrence_Of (Addr, Loc))));
1896 -- Now we can insert the AREC declarations into the body
1897 -- type ARECnT is record .. end record;
1898 -- pragma Suppress_Initialization (ARECnT);
1900 -- Note that we need to set the Suppress_Initialization
1901 -- flag after Decl_ARECnT has been analyzed.
1904 Make_Full_Type_Declaration (Loc,
1905 Defining_Identifier => STJ.ARECnT,
1907 Make_Record_Definition (Loc,
1909 Make_Component_List (Loc,
1910 Component_Items => Clist)));
1911 Append_To (Decls, Decl_ARECnT);
1913 -- type ARECnPT is access all ARECnT;
1916 Make_Full_Type_Declaration (Loc,
1917 Defining_Identifier => STJ.ARECnPT,
1919 Make_Access_To_Object_Definition (Loc,
1920 All_Present => True,
1921 Subtype_Indication =>
1922 New_Occurrence_Of (STJ.ARECnT, Loc)));
1923 Append_To (Decls, Decl_ARECnPT);
1925 -- ARECn : aliased ARECnT;
1928 Make_Object_Declaration (Loc,
1929 Defining_Identifier => STJ.ARECn,
1930 Aliased_Present => True,
1931 Object_Definition =>
1932 New_Occurrence_Of (STJ.ARECnT, Loc));
1933 Append_To (Decls, Decl_ARECn);
1935 -- ARECnP : constant ARECnPT := ARECn'Access;
1938 Make_Object_Declaration (Loc,
1939 Defining_Identifier => STJ.ARECnP,
1940 Constant_Present => True,
1941 Object_Definition =>
1942 New_Occurrence_Of (STJ.ARECnPT, Loc),
1944 Make_Attribute_Reference (Loc,
1946 New_Occurrence_Of (STJ.ARECn, Loc),
1947 Attribute_Name => Name_Access));
1948 Append_To (Decls, Decl_ARECnP);
1950 -- If we are in a subprogram that has a static link that
1951 -- is passed in (as indicated by ARECnF being defined),
1952 -- then generate ARECn.ARECmU := ARECmF where m is
1953 -- one less than the current level to set the uplink.
1955 if Present (STJ.ARECnF) then
1957 Make_Assignment_Statement (Loc,
1959 Make_Selected_Component (Loc,
1961 New_Occurrence_Of (STJ.ARECn, Loc),
1963 New_Occurrence_Of (STJ.ARECnU, Loc)),
1965 New_Occurrence_Of (STJ.ARECnF, Loc));
1966 Append_To (Decls, Decl_Assign);
1969 Decl_Assign := Empty;
1972 if No (Declarations (STJ.Bod)) then
1973 Set_Declarations (STJ.Bod, Decls);
1975 Prepend_List_To (Declarations (STJ.Bod), Decls);
1978 -- Analyze the newly inserted declarations. Note that we
1979 -- do not need to establish the whole scope stack, since
1980 -- we have already set all entity fields (so there will
1981 -- be no searching of upper scopes to resolve names). But
1982 -- we do set the scope of the current subprogram, so that
1983 -- newly created entities go in the right entity chain.
1985 -- We analyze with all checks suppressed (since we do
1986 -- not expect any exceptions).
1988 Push_Scope (STJ.Ent);
1989 Analyze (Decl_ARECnT, Suppress => All_Checks);
1991 -- Note that we need to call Set_Suppress_Initialization
1992 -- after Decl_ARECnT has been analyzed, but before
1993 -- analyzing Decl_ARECnP so that the flag is properly
1994 -- taking into account.
1996 Set_Suppress_Initialization (STJ.ARECnT);
1998 Analyze (Decl_ARECnPT, Suppress => All_Checks);
1999 Analyze (Decl_ARECn, Suppress => All_Checks);
2000 Analyze (Decl_ARECnP, Suppress => All_Checks);
2002 if Present (Decl_Assign) then
2003 Analyze (Decl_Assign, Suppress => All_Checks);
2008 -- Next step, for each uplevel referenced entity, add
2009 -- assignment operations to set the component in the
2010 -- activation record.
2012 if Present (STJ.Uents) then
2017 Elmt := First_Elmt (STJ.Uents);
2018 while Present (Elmt) loop
2020 Ent : constant Entity_Id := Node (Elmt);
2021 Loc : constant Source_Ptr := Sloc (Ent);
2022 Dec : constant Node_Id :=
2023 Declaration_Node (Ent);
2032 -- For parameters, we insert the assignment
2033 -- right after the declaration of ARECnP.
2034 -- For all other entities, we insert the
2035 -- assignment immediately after the
2036 -- declaration of the entity or after the
2037 -- freeze node if present.
2039 -- Note: we don't need to mark the entity
2040 -- as being aliased, because the address
2041 -- attribute will mark it as Address_Taken,
2042 -- and that is good enough.
2044 if Is_Formal (Ent) then
2047 elsif Has_Delayed_Freeze (Ent) then
2048 Ins := Freeze_Node (Ent);
2054 -- Build and insert the assignment:
2055 -- ARECn.nam := nam'Address
2056 -- or else 'Access for unconstrained array
2058 if Needs_Fat_Pointer (Ent) then
2059 Attr := Name_Access;
2061 Attr := Name_Address;
2065 Make_Attribute_Reference (Loc,
2067 New_Occurrence_Of (Ent, Loc),
2068 Attribute_Name => Attr);
2070 -- If the entity is an unconstrained formal
2071 -- we wrap the attribute reference in an
2072 -- unchecked conversion to the type of the
2073 -- activation record component, to prevent
2074 -- spurious subtype conformance errors within
2078 and then not Is_Constrained (Etype (Ent))
2080 -- Find target component and its type
2082 Comp := First_Component (STJ.ARECnT);
2083 while Chars (Comp) /= Chars (Ent) loop
2084 Comp := Next_Component (Comp);
2088 Unchecked_Convert_To (Etype (Comp), Rhs);
2092 Make_Assignment_Statement (Loc,
2094 Make_Selected_Component (Loc,
2096 New_Occurrence_Of (STJ.ARECn, Loc),
2099 (Activation_Record_Component
2104 -- If we have a loop parameter, we have
2105 -- to insert before the first statement
2106 -- of the loop. Ins points to the
2107 -- N_Loop_Parameter_Specification or to
2108 -- an N_Iterator_Specification.
2111 (Ins, N_Iterator_Specification,
2112 N_Loop_Parameter_Specification)
2114 -- Quantified expression are rewritten as
2115 -- loops during expansion.
2117 if Nkind (Parent (Ins)) =
2118 N_Quantified_Expression
2126 (Parent (Parent (Ins))));
2127 Insert_Before (Ins, Asn);
2131 Insert_After (Ins, Asn);
2134 -- Analyze the assignment statement. We do
2135 -- not need to establish the relevant scope
2136 -- stack entries here, because we have
2137 -- already set the correct entity references,
2138 -- so no name resolution is required, and no
2139 -- new entities are created, so we don't even
2140 -- need to set the current scope.
2142 -- We analyze with all checks suppressed
2143 -- (since we do not expect any exceptions).
2145 Analyze (Asn, Suppress => All_Checks);
2158 -- Next step, process uplevel references. This has to be done in a
2159 -- separate pass, after completing the processing in Sub_Loop because we
2160 -- need all the AREC declarations generated, inserted, and analyzed so
2161 -- that the uplevel references can be successfully analyzed.
2163 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
2165 UPJ : Uref_Entry renames Urefs.Table (J);
2168 -- Ignore type references, these are implicit references that do
2169 -- not need rewriting (e.g. the appearence in a conversion).
2170 -- Also ignore if no reference was specified or if the rewriting
2171 -- has already been done (this can happen if the N_Identifier
2172 -- occurs more than one time in the tree).
2175 or else not Is_Entity_Name (UPJ.Ref)
2176 or else not Present (Entity (UPJ.Ref))
2181 -- Rewrite one reference
2183 Rewrite_One_Ref : declare
2184 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
2185 -- Source location for the reference
2187 Typ : constant Entity_Id := Etype (UPJ.Ent);
2188 -- The type of the referenced entity
2191 -- The actual subtype of the reference
2193 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
2194 -- Subp_Index for caller containing reference
2196 STJR : Subp_Entry renames Subps.Table (RS_Caller);
2197 -- Subp_Entry for subprogram containing reference
2199 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
2200 -- Subp_Index for subprogram containing referenced entity
2202 STJE : Subp_Entry renames Subps.Table (RS_Callee);
2203 -- Subp_Entry for subprogram containing referenced entity
2210 Atyp := Etype (UPJ.Ref);
2212 if Ekind (Atyp) /= E_Record_Subtype then
2213 Atyp := Get_Actual_Subtype (UPJ.Ref);
2216 -- Ignore if no ARECnF entity for enclosing subprogram which
2217 -- probably happens as a result of not properly treating
2218 -- instance bodies. To be examined ???
2220 -- If this test is omitted, then the compilation of freeze.adb
2221 -- and inline.adb fail in unnesting mode.
2223 if No (STJR.ARECnF) then
2227 -- If this is a reference to a global constant, use its value
2228 -- rather than create a reference. It is more efficient and
2229 -- furthermore indispensable if the context requires a
2230 -- constant, such as a branch of a case statement.
2232 if Ekind (UPJ.Ent) = E_Constant
2233 and then Is_True_Constant (UPJ.Ent)
2234 and then Present (Constant_Value (UPJ.Ent))
2235 and then Is_Static_Expression (Constant_Value (UPJ.Ent))
2237 Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent)));
2241 -- Push the current scope, so that the pointer type Tnn, and
2242 -- any subsidiary entities resulting from the analysis of the
2243 -- rewritten reference, go in the right entity chain.
2245 Push_Scope (STJR.Ent);
2247 -- Now we need to rewrite the reference. We have a reference
2248 -- from level STJR.Lev to level STJE.Lev. The general form of
2249 -- the rewritten reference for entity X is:
2251 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
2253 -- where a,b,c,d .. m =
2254 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
2256 pragma Assert (STJR.Lev > STJE.Lev);
2258 -- Compute the prefix of X. Here are examples to make things
2259 -- clear (with parens to show groupings, the prefix is
2260 -- everything except the .X at the end).
2262 -- level 2 to level 1
2266 -- level 3 to level 1
2268 -- (AREC2F.AREC1U).X
2270 -- level 4 to level 1
2272 -- ((AREC3F.AREC2U).AREC1U).X
2274 -- level 6 to level 2
2276 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
2278 -- In the above, ARECnF and ARECnU are pointers, so there are
2279 -- explicit dereferences required for these occurrences.
2282 Make_Explicit_Dereference (Loc,
2283 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
2285 for L in STJE.Lev .. STJR.Lev - 2 loop
2286 SI := Enclosing_Subp (SI);
2288 Make_Explicit_Dereference (Loc,
2290 Make_Selected_Component (Loc,
2293 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
2296 -- Get activation record component (must exist)
2298 Comp := Activation_Record_Component (UPJ.Ent);
2299 pragma Assert (Present (Comp));
2301 -- Do the replacement. If the component type is an access type,
2302 -- this is an uplevel reference for an entity that requires a
2303 -- fat pointer, so dereference the component.
2305 if Is_Access_Type (Etype (Comp)) then
2307 Make_Explicit_Dereference (Loc,
2309 Make_Selected_Component (Loc,
2312 New_Occurrence_Of (Comp, Loc))));
2316 Make_Attribute_Reference (Loc,
2317 Prefix => New_Occurrence_Of (Atyp, Loc),
2318 Attribute_Name => Name_Deref,
2319 Expressions => New_List (
2320 Make_Selected_Component (Loc,
2323 New_Occurrence_Of (Comp, Loc)))));
2326 -- Analyze and resolve the new expression. We do not need to
2327 -- establish the relevant scope stack entries here, because we
2328 -- have already set all the correct entity references, so no
2329 -- name resolution is needed. We have already set the current
2330 -- scope, so that any new entities created will be in the right
2333 -- We analyze with all checks suppressed (since we do not
2334 -- expect any exceptions)
2336 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
2338 end Rewrite_One_Ref;
2343 end loop Uplev_Refs;
2345 -- Finally, loop through all calls adding extra actual for the
2346 -- activation record where it is required.
2348 Adjust_Calls : for J in Calls.First .. Calls.Last loop
2350 -- Process a single call, we are only interested in a call to a
2351 -- subprogram that actually needs a pointer to an activation record,
2352 -- as indicated by the ARECnF entity being set. This excludes the
2353 -- top level subprogram, and any subprogram not having uplevel refs.
2355 Adjust_One_Call : declare
2356 CTJ : Call_Entry renames Calls.Table (J);
2357 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
2358 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
2360 Loc : constant Source_Ptr := Sloc (CTJ.N);
2368 if Present (STT.ARECnF)
2369 and then Nkind (CTJ.N) in N_Subprogram_Call
2371 -- CTJ.N is a call to a subprogram which may require a pointer
2372 -- to an activation record. The subprogram containing the call
2373 -- is CTJ.From and the subprogram being called is CTJ.To, so we
2374 -- have a call from level STF.Lev to level STT.Lev.
2376 -- There are three possibilities:
2378 -- For a call to the same level, we just pass the activation
2379 -- record passed to the calling subprogram.
2381 if STF.Lev = STT.Lev then
2382 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2384 -- For a call that goes down a level, we pass a pointer to the
2385 -- activation record constructed within the caller (which may
2386 -- be the outer-level subprogram, but also may be a more deeply
2389 elsif STT.Lev = STF.Lev + 1 then
2390 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
2392 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
2393 -- since it is not possible to do a downcall of more than
2396 -- For a call from level STF.Lev to level STT.Lev, we
2397 -- have to find the activation record needed by the
2398 -- callee. This is as follows:
2400 -- ARECaF.ARECbU.ARECcU....ARECmU
2402 -- where a,b,c .. m =
2403 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
2406 pragma Assert (STT.Lev < STF.Lev);
2408 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2409 SubX := Subp_Index (CTJ.Caller);
2410 for K in reverse STT.Lev .. STF.Lev - 1 loop
2411 SubX := Enclosing_Subp (SubX);
2413 Make_Selected_Component (Loc,
2417 (Subps.Table (SubX).ARECnU, Loc));
2421 -- Extra is the additional parameter to be added. Build a
2422 -- parameter association that we can append to the actuals.
2425 Make_Parameter_Association (Loc,
2427 New_Occurrence_Of (STT.ARECnF, Loc),
2428 Explicit_Actual_Parameter => Extra);
2430 if No (Parameter_Associations (CTJ.N)) then
2431 Set_Parameter_Associations (CTJ.N, Empty_List);
2434 Append (ExtraP, Parameter_Associations (CTJ.N));
2436 -- We need to deal with the actual parameter chain as well. The
2437 -- newly added parameter is always the last actual.
2439 Act := First_Named_Actual (CTJ.N);
2442 Set_First_Named_Actual (CTJ.N, Extra);
2444 -- If call has been relocated (as with an expression in
2445 -- an aggregate), set First_Named pointer in original node
2446 -- as well, because that's the parent of the parameter list.
2448 Set_First_Named_Actual
2449 (Parent (List_Containing (ExtraP)), Extra);
2451 -- Here we must follow the chain and append the new entry
2460 PAN := Parent (Act);
2461 pragma Assert (Nkind (PAN) = N_Parameter_Association);
2462 NNA := Next_Named_Actual (PAN);
2465 Set_Next_Named_Actual (PAN, Extra);
2474 -- Analyze and resolve the new actual. We do not need to
2475 -- establish the relevant scope stack entries here, because
2476 -- we have already set all the correct entity references, so
2477 -- no name resolution is needed.
2479 -- We analyze with all checks suppressed (since we do not
2480 -- expect any exceptions, and also we temporarily turn off
2481 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2482 -- references (not needed at this stage, and in fact causes
2483 -- a bit of recursive chaos).
2485 Opt.Unnest_Subprogram_Mode := False;
2487 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
2488 Opt.Unnest_Subprogram_Mode := True;
2490 end Adjust_One_Call;
2491 end loop Adjust_Calls;
2494 end Unnest_Subprogram;
2496 ------------------------
2497 -- Unnest_Subprograms --
2498 ------------------------
2500 procedure Unnest_Subprograms (N : Node_Id) is
2501 function Search_Subprograms (N : Node_Id) return Traverse_Result;
2502 -- Tree visitor that search for outer level procedures with nested
2503 -- subprograms and invokes Unnest_Subprogram()
2509 procedure Do_Search is new Traverse_Proc (Search_Subprograms);
2510 -- Subtree visitor instantiation
2512 ------------------------
2513 -- Search_Subprograms --
2514 ------------------------
2516 function Search_Subprograms (N : Node_Id) return Traverse_Result is
2518 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
2520 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
2523 -- We are only interested in subprograms (not generic
2524 -- subprograms), that have nested subprograms.
2526 if Is_Subprogram (Spec_Id)
2527 and then Has_Nested_Subprogram (Spec_Id)
2528 and then Is_Library_Level_Entity (Spec_Id)
2530 Unnest_Subprogram (Spec_Id, N);
2534 -- The proper body of a stub may contain nested subprograms, and
2535 -- therefore must be visited explicitly. Nested stubs are examined
2536 -- recursively in Visit_Node.
2538 elsif Nkind (N) in N_Body_Stub then
2539 Do_Search (Library_Unit (N));
2541 -- Skip generic packages
2543 elsif Nkind (N) = N_Package_Body
2544 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
2550 end Search_Subprograms;
2552 -- Start of processing for Unnest_Subprograms
2555 if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then
2559 -- A specification will contain bodies if it contains instantiations so
2560 -- examine package or subprogram declaration of the main unit, when it
2563 if Nkind (Unit (N)) = N_Package_Body
2564 or else (Nkind (Unit (N)) = N_Subprogram_Body
2565 and then not Acts_As_Spec (N))
2567 Do_Search (Library_Unit (N));
2571 end Unnest_Subprograms;