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.
105 -- Table to record explicit uplevel references to objects (variables,
106 -- constants, formal parameters). These are the references that will
107 -- need rewriting to use the activation table (AREC) pointers. Also
108 -- included are implicit and explicit uplevel references to types, but
109 -- these do not get rewritten by the front end. This table is built new
110 -- for each subprogram nest and cleared at the end of processing each
113 type Uref_Entry is record
115 -- The reference itself. For objects this is always an entity reference
116 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
117 -- flag set and will appear in the Uplevel_Referenced_Entities list of
118 -- the subprogram declaring this entity.
121 -- The Entity_Id of the uplevel referenced object or type
124 -- The entity for the subprogram immediately containing this entity
127 -- The entity for the subprogram containing the referenced entity. Note
128 -- that the level of Callee must be less than the level of Caller, since
129 -- this is an uplevel reference.
132 package Urefs is new Table.Table (
133 Table_Component_Type => Uref_Entry,
134 Table_Index_Type => Nat,
135 Table_Low_Bound => 1,
136 Table_Initial => 100,
137 Table_Increment => 200,
138 Table_Name => "Unnest_Urefs");
140 ------------------------
141 -- Append_Unique_Call --
142 ------------------------
144 procedure Append_Unique_Call (Call : Call_Entry) is
146 for J in Calls.First .. Calls.Last loop
147 if Calls.Table (J) = Call then
153 end Append_Unique_Call;
159 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
171 S := Enclosing_Subprogram (S);
176 --------------------------
177 -- In_Synchronized_Unit --
178 --------------------------
180 function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is
181 S : Entity_Id := Scope (Subp);
184 while Present (S) and then S /= Standard_Standard loop
185 if Is_Concurrent_Type (S) then
193 end In_Synchronized_Unit;
199 function Subp_Index (Sub : Entity_Id) return SI_Type is
200 E : Entity_Id := Sub;
203 pragma Assert (Is_Subprogram (E));
205 if Subps_Index (E) = Uint_0 then
206 E := Ultimate_Alias (E);
208 if Ekind (E) = E_Function
209 and then Rewritten_For_C (E)
210 and then Present (Corresponding_Procedure (E))
212 E := Corresponding_Procedure (E);
216 pragma Assert (Subps_Index (E) /= Uint_0);
217 return SI_Type (UI_To_Int (Subps_Index (E)));
220 -----------------------
221 -- Unnest_Subprogram --
222 -----------------------
224 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
225 function AREC_Name (J : Pos; S : String) return Name_Id;
226 -- Returns name for string ARECjS, where j is the decimal value of j
228 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
229 -- Subp is the index of a subprogram which has a Lev greater than 1.
230 -- This function returns the index of the enclosing subprogram which
231 -- will have a Lev value one less than this.
233 function Img_Pos (N : Pos) return String;
234 -- Return image of N without leading blank
239 Clist : List_Id) return Name_Id;
240 -- This function returns the name to be used in the activation record to
241 -- reference the variable uplevel. Clist is the list of components that
242 -- have been created in the activation record so far. Normally the name
243 -- is just a copy of the Chars field of the entity. The exception is
244 -- when the name has already been used, in which case we suffix the name
245 -- with the index value Index to avoid duplication. This happens with
246 -- declare blocks and generic parameters at least.
252 function AREC_Name (J : Pos; S : String) return Name_Id is
254 return Name_Find ("AREC" & Img_Pos (J) & S);
261 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
262 STJ : Subp_Entry renames Subps.Table (Subp);
263 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
265 pragma Assert (STJ.Lev > 1);
266 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
274 function Img_Pos (N : Pos) return String is
275 Buf : String (1 .. 20);
283 Buf (Ptr) := Character'Val (48 + NV mod 10);
288 return Buf (Ptr + 1 .. Buf'Last);
298 Clist : List_Id) return Name_Id
307 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
309 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
316 -- Start of processing for Unnest_Subprogram
319 -- Nothing to do inside a generic (all processing is for instance)
321 if Inside_A_Generic then
325 -- If the main unit is a package body then we need to examine the spec
326 -- to determine whether the main unit is generic (the scope stack is not
327 -- present when this is called on the main unit).
329 if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
330 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
335 -- Only unnest when generating code for the main source unit
337 if not In_Extended_Main_Code_Unit (Subp_Body) then
341 -- This routine is called late, after the scope stack is gone. The
342 -- following creates a suitable dummy scope stack to be used for the
343 -- analyze/expand calls made from this routine.
347 -- First step, we must mark all nested subprograms that require a static
348 -- link (activation record) because either they contain explicit uplevel
349 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
350 -- this point), or they make calls to other subprograms in the same nest
351 -- that require a static link (in which case we set this flag).
353 -- This is a recursive definition, and to implement this, we have to
354 -- build a call graph for the set of nested subprograms, and then go
355 -- over this graph to implement recursively the invariant that if a
356 -- subprogram has a call to a subprogram requiring a static link, then
357 -- the calling subprogram requires a static link.
359 -- First populate the above tables
361 Subps_First := Subps.Last + 1;
365 Build_Tables : declare
366 Current_Subprogram : Entity_Id;
367 -- When we scan a subprogram body, we set Current_Subprogram to the
368 -- corresponding entity. This gets recursively saved and restored.
370 function Visit_Node (N : Node_Id) return Traverse_Result;
371 -- Visit a single node in Subp
377 procedure Visit is new Traverse_Proc (Visit_Node);
378 -- Used to traverse the body of Subp, populating the tables
384 function Visit_Node (N : Node_Id) return Traverse_Result is
389 procedure Check_Static_Type
390 (T : Entity_Id; N : Node_Id; DT : in out Boolean);
391 -- Given a type T, checks if it is a static type defined as a type
392 -- with no dynamic bounds in sight. If so, the only action is to
393 -- set Is_Static_Type True for T. If T is not a static type, then
394 -- all types with dynamic bounds associated with T are detected,
395 -- and their bounds are marked as uplevel referenced if not at the
396 -- library level, and DT is set True. If N is specified, it's the
397 -- node that will need to be replaced. If not specified, it means
398 -- we can't do a replacement because the bound is implicit.
400 procedure Note_Uplevel_Ref
405 -- Called when we detect an explicit or implicit uplevel reference
406 -- from within Caller to entity E declared in Callee. E can be a
407 -- an object or a type.
409 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
410 -- Enter a subprogram whose body is visible or which is a
411 -- subprogram instance into the subprogram table.
413 -----------------------
414 -- Check_Static_Type --
415 -----------------------
417 procedure Check_Static_Type
418 (T : Entity_Id; N : Node_Id; DT : in out Boolean)
420 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
421 -- N is the bound of a dynamic type. This procedure notes that
422 -- this bound is uplevel referenced, it can handle references
423 -- to entities (typically _FIRST and _LAST entities), and also
424 -- attribute references of the form T'name (name is typically
425 -- FIRST or LAST) where T is the uplevel referenced bound.
426 -- Ref, if Present, is the location of the reference to
429 ------------------------
430 -- Note_Uplevel_Bound --
431 ------------------------
433 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
435 -- Entity name case. Make sure that the entity is declared
436 -- in a subprogram. This may not be the case for for a type
437 -- in a loop appearing in a precondition.
438 -- Exclude explicitly discriminants (that can appear
439 -- in bounds of discriminated components).
441 if Is_Entity_Name (N) then
442 if Present (Entity (N))
443 and then Present (Enclosing_Subprogram (Entity (N)))
444 and then Ekind (Entity (N)) /= E_Discriminant
449 Caller => Current_Subprogram,
450 Callee => Enclosing_Subprogram (Entity (N)));
453 -- Attribute or indexed component case
455 elsif Nkind_In (N, N_Attribute_Reference,
458 Note_Uplevel_Bound (Prefix (N), Ref);
460 -- The indices of the indexed components, or the
461 -- associated expressions of an attribute reference,
462 -- may also involve uplevel references.
468 Expr := First (Expressions (N));
469 while Present (Expr) loop
470 Note_Uplevel_Bound (Expr, Ref);
477 elsif Nkind (N) = N_Type_Conversion then
478 Note_Uplevel_Bound (Expression (N), Ref);
480 end Note_Uplevel_Bound;
482 -- Start of processing for Check_Static_Type
485 -- If already marked static, immediate return
487 if Is_Static_Type (T) then
491 -- If the type is at library level, always consider it static,
492 -- since such uplevel references are irrelevant.
494 if Is_Library_Level_Entity (T) then
495 Set_Is_Static_Type (T);
499 -- Otherwise figure out what the story is with this type
501 -- For a scalar type, check bounds
503 if Is_Scalar_Type (T) then
505 -- If both bounds static, then this is a static type
508 LB : constant Node_Id := Type_Low_Bound (T);
509 UB : constant Node_Id := Type_High_Bound (T);
512 if not Is_Static_Expression (LB) then
513 Note_Uplevel_Bound (LB, N);
517 if not Is_Static_Expression (UB) then
518 Note_Uplevel_Bound (UB, N);
523 -- For record type, check all components and discriminant
524 -- constraints if present.
526 elsif Is_Record_Type (T) then
532 C := First_Component_Or_Discriminant (T);
533 while Present (C) loop
534 Check_Static_Type (Etype (C), N, DT);
535 Next_Component_Or_Discriminant (C);
538 if Has_Discriminants (T)
539 and then Present (Discriminant_Constraint (T))
541 D := First_Elmt (Discriminant_Constraint (T));
542 while Present (D) loop
543 if not Is_Static_Expression (Node (D)) then
544 Note_Uplevel_Bound (Node (D), N);
553 -- For array type, check index types and component type
555 elsif Is_Array_Type (T) then
559 Check_Static_Type (Component_Type (T), N, DT);
561 IX := First_Index (T);
562 while Present (IX) loop
563 Check_Static_Type (Etype (IX), N, DT);
568 -- For private type, examine whether full view is static
570 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
571 Check_Static_Type (Full_View (T), N, DT);
573 if Is_Static_Type (Full_View (T)) then
574 Set_Is_Static_Type (T);
577 -- For now, ignore other types
584 Set_Is_Static_Type (T);
586 end Check_Static_Type;
588 ----------------------
589 -- Note_Uplevel_Ref --
590 ----------------------
592 procedure Note_Uplevel_Ref
598 Full_E : Entity_Id := E;
600 -- Nothing to do for static type
602 if Is_Static_Type (E) then
606 -- Nothing to do if Caller and Callee are the same
608 if Caller = Callee then
611 -- Callee may be a function that returns an array, and that has
612 -- been rewritten as a procedure. If caller is that procedure,
613 -- nothing to do either.
615 elsif Ekind (Callee) = E_Function
616 and then Rewritten_For_C (Callee)
617 and then Corresponding_Procedure (Callee) = Caller
622 -- We have a new uplevel referenced entity
624 if Ekind (E) = E_Constant and then Present (Full_View (E)) then
625 Full_E := Full_View (E);
628 -- All we do at this stage is to add the uplevel reference to
629 -- the table. It's too early to do anything else, since this
630 -- uplevel reference may come from an unreachable subprogram
631 -- in which case the entry will be deleted.
633 Urefs.Append ((N, Full_E, Caller, Callee));
634 end Note_Uplevel_Ref;
636 -------------------------
637 -- Register_Subprogram --
638 -------------------------
640 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
641 L : constant Nat := Get_Level (Subp, E);
650 Declares_AREC => False,
660 Set_Subps_Index (E, UI_From_Int (Subps.Last));
661 end Register_Subprogram;
663 -- Start of processing for Visit_Node
668 -- Record a subprogram call
671 | N_Procedure_Call_Statement
673 -- We are only interested in direct calls, not indirect
674 -- calls (where Name (N) is an explicit dereference) at
677 if Nkind (Name (N)) in N_Has_Entity then
678 Ent := Entity (Name (N));
680 -- We are only interested in calls to subprograms nested
681 -- within Subp. Calls to Subp itself or to subprograms
682 -- outside the nested structure do not affect us.
684 if Scope_Within (Ent, Subp)
685 and then Is_Subprogram (Ent)
686 and then not Is_Imported (Ent)
688 Append_Unique_Call ((N, Current_Subprogram, Ent));
692 -- For all calls where the formal is an unconstrained array
693 -- and the actual is constrained we need to check the bounds
694 -- for uplevel references.
698 DT : Boolean := False;
703 if Nkind (Name (N)) = N_Explicit_Dereference then
704 Subp := Etype (Name (N));
706 Subp := Entity (Name (N));
709 Actual := First_Actual (N);
710 Formal := First_Formal_With_Extras (Subp);
711 while Present (Actual) loop
712 if Is_Array_Type (Etype (Formal))
713 and then not Is_Constrained (Etype (Formal))
714 and then Is_Constrained (Etype (Actual))
716 Check_Static_Type (Etype (Actual), Empty, DT);
719 Next_Actual (Actual);
720 Next_Formal_With_Extras (Formal);
724 -- An At_End_Proc in a statement sequence indicates that there
725 -- is a call from the enclosing construct or block to that
726 -- subprogram. As above, the called entity must be local and
729 when N_Handled_Sequence_Of_Statements =>
730 if Present (At_End_Proc (N))
731 and then Scope_Within (Entity (At_End_Proc (N)), Subp)
732 and then not Is_Imported (Entity (At_End_Proc (N)))
735 ((N, Current_Subprogram, Entity (At_End_Proc (N))));
738 -- Similarly, the following constructs include a semantic
739 -- attribute Procedure_To_Call that must be handled like
743 | N_Extended_Return_Statement
745 | N_Simple_Return_Statement
748 Proc : constant Entity_Id := Procedure_To_Call (N);
751 and then Scope_Within (Proc, Subp)
752 and then not Is_Imported (Proc)
754 Append_Unique_Call ((N, Current_Subprogram, Proc));
758 -- A 'Access reference is a (potential) call. Other attributes
759 -- require special handling.
761 when N_Attribute_Reference =>
763 Attr : constant Attribute_Id :=
764 Get_Attribute_Id (Attribute_Name (N));
767 when Attribute_Access
768 | Attribute_Unchecked_Access
769 | Attribute_Unrestricted_Access
771 if Nkind (Prefix (N)) in N_Has_Entity then
772 Ent := Entity (Prefix (N));
774 -- We only need to examine calls to subprograms
775 -- nested within current Subp.
777 if Scope_Within (Ent, Subp) then
778 if Is_Imported (Ent) then
781 elsif Is_Subprogram (Ent) then
783 ((N, Current_Subprogram, Ent));
788 -- References to bounds can be uplevel references if
789 -- the type isn't static.
795 -- Special-case attributes of objects whose bounds
796 -- may be uplevel references. More complex prefixes
797 -- handled during full traversal. Note that if the
798 -- nominal subtype of the prefix is unconstrained,
799 -- the bound must be obtained from the object, not
800 -- from the (possibly) uplevel reference.
802 if Is_Constrained (Etype (Prefix (N))) then
804 DT : Boolean := False;
807 (Etype (Prefix (N)), Empty, DT);
818 -- Component associations in aggregates are either static or
819 -- else the aggregate will be expanded into assignments, in
820 -- which case the expression is analyzed later and provides
821 -- no relevant code generation.
823 when N_Component_Association =>
824 if No (Etype (Expression (N))) then
828 -- Generic associations are not analyzed: the actuals are
829 -- transferred to renaming and subtype declarations that
830 -- are the ones that must be examined.
832 when N_Generic_Association =>
835 -- Indexed references can be uplevel if the type isn't static
836 -- and if the lower bound (or an inner bound for a multi-
837 -- dimensional array) is uplevel.
839 when N_Indexed_Component | N_Slice =>
840 if Is_Constrained (Etype (Prefix (N))) then
842 DT : Boolean := False;
844 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
848 -- A selected component can have an implicit up-level
849 -- reference due to the bounds of previous fields in the
850 -- record. We simplify the processing here by examining
851 -- all components of the record.
853 -- Selected components appear as unit names and end labels
854 -- for child units. Prefixes of these nodes denote parent
855 -- units and carry no type information so they are skipped.
857 when N_Selected_Component =>
858 if Present (Etype (Prefix (N))) then
860 DT : Boolean := False;
862 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
866 -- Record a subprogram. We record a subprogram body that acts
867 -- as a spec. Otherwise we record a subprogram declaration,
868 -- providing that it has a corresponding body we can get hold
869 -- of. The case of no corresponding body being available is
872 when N_Subprogram_Body =>
873 Ent := Unique_Defining_Entity (N);
875 -- Ignore generic subprogram
877 if Is_Generic_Subprogram (Ent) then
881 -- Make new entry in subprogram table if not already made
883 Register_Subprogram (Ent, N);
885 -- We make a recursive call to scan the subprogram body, so
886 -- that we can save and restore Current_Subprogram.
889 Save_CS : constant Entity_Id := Current_Subprogram;
893 Current_Subprogram := Ent;
897 Decl := First (Declarations (N));
898 while Present (Decl) loop
905 Visit (Handled_Statement_Sequence (N));
907 -- Restore current subprogram setting
909 Current_Subprogram := Save_CS;
912 -- Now at this level, return skipping the subprogram body
913 -- descendants, since we already took care of them!
917 -- If we have a body stub, visit the associated subunit, which
918 -- is a semantic descendant of the stub.
921 Visit (Library_Unit (N));
923 -- A declaration of a wrapper package indicates a subprogram
924 -- instance for which there is no explicit body. Enter the
925 -- subprogram instance in the table.
927 when N_Package_Declaration =>
928 if Is_Wrapper_Package (Defining_Entity (N)) then
930 (Related_Instance (Defining_Entity (N)), Empty);
933 -- Skip generic declarations
935 when N_Generic_Declaration =>
938 -- Skip generic package body
940 when N_Package_Body =>
941 if Present (Corresponding_Spec (N))
942 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
947 -- Otherwise record an uplevel reference in a local
951 if Nkind (N) in N_Has_Entity
952 and then Present (Entity (N))
956 -- Only interested in entities declared within our nest
958 if not Is_Library_Level_Entity (Ent)
959 and then Scope_Within_Or_Same (Scope (Ent), Subp)
961 -- Skip entities defined in inlined subprograms
964 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
966 -- Constants and variables are potentially uplevel
967 -- references to global declarations.
970 (Ekind_In (Ent, E_Constant, E_Variable)
972 -- Formals are interesting, but not if being used as
973 -- mere names of parameters for name notation calls.
978 (Nkind (Parent (N)) = N_Parameter_Association
979 and then Selector_Name (Parent (N)) = N))
981 -- Types other than known Is_Static types are
982 -- potentially interesting.
984 or else (Is_Type (Ent)
985 and then not Is_Static_Type (Ent)))
987 -- Here we have a potentially interesting uplevel
988 -- reference to examine.
990 if Is_Type (Ent) then
992 DT : Boolean := False;
995 Check_Static_Type (Ent, N, DT);
997 if Is_Static_Type (Ent) then
1003 Caller := Current_Subprogram;
1004 Callee := Enclosing_Subprogram (Ent);
1007 and then not Is_Static_Type (Ent)
1009 Note_Uplevel_Ref (Ent, N, Caller, Callee);
1011 -- Check the type of a formal parameter of the current
1012 -- subprogram, whose formal type may be an uplevel
1015 elsif Is_Formal (Ent)
1016 and then Scope (Ent) = Current_Subprogram
1019 DT : Boolean := False;
1022 Check_Static_Type (Etype (Ent), Empty, DT);
1029 -- Fall through to continue scanning children of this node
1034 -- Start of processing for Build_Tables
1037 -- Traverse the body to get subprograms, calls and uplevel references
1042 -- Now do the first transitive closure which determines which
1043 -- subprograms in the nest are actually reachable.
1045 Reachable_Closure : declare
1049 Subps.Table (Subps_First).Reachable := True;
1051 -- We use a simple minded algorithm as follows (obviously this can
1052 -- be done more efficiently, using one of the standard algorithms
1053 -- for efficient transitive closure computation, but this is simple
1054 -- and most likely fast enough that its speed does not matter).
1056 -- Repeatedly scan the list of calls. Any time we find a call from
1057 -- A to B, where A is reachable, but B is not, then B is reachable,
1058 -- and note that we have made a change by setting Modified True. We
1059 -- repeat this until we make a pass with no modifications.
1063 Inner : for J in Calls.First .. Calls.Last loop
1065 CTJ : Call_Entry renames Calls.Table (J);
1067 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1068 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1070 SUBF : Subp_Entry renames Subps.Table (SINF);
1071 SUBT : Subp_Entry renames Subps.Table (SINT);
1074 if SUBF.Reachable and then not SUBT.Reachable then
1075 SUBT.Reachable := True;
1081 exit Outer when not Modified;
1083 end Reachable_Closure;
1085 -- Remove calls from unreachable subprograms
1092 for J in Calls.First .. Calls.Last loop
1094 CTJ : Call_Entry renames Calls.Table (J);
1096 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1097 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1099 SUBF : Subp_Entry renames Subps.Table (SINF);
1100 SUBT : Subp_Entry renames Subps.Table (SINT);
1103 if SUBF.Reachable then
1104 pragma Assert (SUBT.Reachable);
1105 New_Index := New_Index + 1;
1106 Calls.Table (New_Index) := Calls.Table (J);
1111 Calls.Set_Last (New_Index);
1114 -- Remove uplevel references from unreachable subprograms
1121 for J in Urefs.First .. Urefs.Last loop
1123 URJ : Uref_Entry renames Urefs.Table (J);
1125 SINF : constant SI_Type := Subp_Index (URJ.Caller);
1126 SINT : constant SI_Type := Subp_Index (URJ.Callee);
1128 SUBF : Subp_Entry renames Subps.Table (SINF);
1129 SUBT : Subp_Entry renames Subps.Table (SINT);
1134 -- Keep reachable reference
1136 if SUBF.Reachable then
1137 New_Index := New_Index + 1;
1138 Urefs.Table (New_Index) := Urefs.Table (J);
1140 -- And since we know we are keeping this one, this is a good
1141 -- place to fill in information for a good reference.
1143 -- Mark all enclosing subprograms need to declare AREC
1147 S := Enclosing_Subprogram (S);
1149 -- if we are at the top level, as can happen with
1150 -- references to formals in aspects of nested subprogram
1151 -- declarations, there are no further subprograms to
1152 -- mark as requiring activation records.
1155 Subps.Table (Subp_Index (S)).Declares_AREC := True;
1156 exit when S = URJ.Callee;
1159 -- Add to list of uplevel referenced entities for Callee.
1160 -- We do not add types to this list, only actual references
1161 -- to objects that will be referenced uplevel, and we use
1162 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1163 -- duplicate entries in the list.
1164 -- Discriminants are also excluded, only the enclosing
1165 -- object can appear in the list.
1167 if not Is_Uplevel_Referenced_Entity (URJ.Ent)
1168 and then Ekind (URJ.Ent) /= E_Discriminant
1170 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
1172 if not Is_Type (URJ.Ent) then
1173 Append_New_Elmt (URJ.Ent, SUBT.Uents);
1177 -- And set uplevel indication for caller
1179 if SUBT.Lev < SUBF.Uplevel_Ref then
1180 SUBF.Uplevel_Ref := SUBT.Lev;
1186 Urefs.Set_Last (New_Index);
1189 -- Remove unreachable subprograms from Subps table. Note that we do
1190 -- this after eliminating entries from the other two tables, since
1191 -- those elimination steps depend on referencing the Subps table.
1197 New_SI := Subps_First - 1;
1198 for J in Subps_First .. Subps.Last loop
1200 STJ : Subp_Entry renames Subps.Table (J);
1205 -- Subprograms declared in tasks and protected types are
1206 -- reachable and cannot be eliminated.
1208 if In_Synchronized_Unit (STJ.Ent) then
1209 STJ.Reachable := True;
1212 -- Subprogram is reachable, copy and reset index
1214 if STJ.Reachable then
1215 New_SI := New_SI + 1;
1216 Subps.Table (New_SI) := STJ;
1217 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
1219 -- Subprogram is not reachable
1222 -- Clear index, since no longer active
1224 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
1226 -- Output debug information if -gnatd.3 set
1228 if Debug_Flag_Dot_3 then
1229 Write_Str ("Eliminate ");
1230 Write_Name (Chars (Subps.Table (J).Ent));
1232 Write_Location (Sloc (Subps.Table (J).Ent));
1233 Write_Str (" (not referenced)");
1237 -- Rewrite declaration and body to null statements
1239 -- A subprogram instantiation does not have an explicit
1240 -- body. If unused, we could remove the corresponding
1241 -- wrapper package and its body (TBD).
1243 if Present (STJ.Bod) then
1244 Spec := Corresponding_Spec (STJ.Bod);
1246 if Present (Spec) then
1247 Decl := Parent (Declaration_Node (Spec));
1248 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
1251 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
1257 Subps.Set_Last (New_SI);
1260 -- Now it is time for the second transitive closure, which follows calls
1261 -- and makes sure that A calls B, and B has uplevel references, then A
1262 -- is also marked as having uplevel references.
1264 Closure_Uplevel : declare
1268 -- We use a simple minded algorithm as follows (obviously this can
1269 -- be done more efficiently, using one of the standard algorithms
1270 -- for efficient transitive closure computation, but this is simple
1271 -- and most likely fast enough that its speed does not matter).
1273 -- Repeatedly scan the list of calls. Any time we find a call from
1274 -- A to B, where B has uplevel references, make sure that A is marked
1275 -- as having at least the same level of uplevel referencing.
1279 Inner2 : for J in Calls.First .. Calls.Last loop
1281 CTJ : Call_Entry renames Calls.Table (J);
1282 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1283 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1284 SUBF : Subp_Entry renames Subps.Table (SINF);
1285 SUBT : Subp_Entry renames Subps.Table (SINT);
1287 if SUBT.Lev > SUBT.Uplevel_Ref
1288 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
1290 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
1296 exit Outer2 when not Modified;
1298 end Closure_Uplevel;
1300 -- We have one more step before the tables are complete. An uplevel
1301 -- call from subprogram A to subprogram B where subprogram B has uplevel
1302 -- references is in effect an uplevel reference, and must arrange for
1303 -- the proper activation link to be passed.
1305 for J in Calls.First .. Calls.Last loop
1307 CTJ : Call_Entry renames Calls.Table (J);
1309 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1310 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1312 SUBF : Subp_Entry renames Subps.Table (SINF);
1313 SUBT : Subp_Entry renames Subps.Table (SINT);
1318 -- If callee has uplevel references
1320 if SUBT.Uplevel_Ref < SUBT.Lev
1322 -- And this is an uplevel call
1324 and then SUBT.Lev < SUBF.Lev
1326 -- We need to arrange for finding the uplink
1330 A := Enclosing_Subprogram (A);
1331 Subps.Table (Subp_Index (A)).Declares_AREC := True;
1332 exit when A = CTJ.Callee;
1334 -- In any case exit when we get to the outer level. This
1335 -- happens in some odd cases with generics (in particular
1336 -- sem_ch3.adb does not compile without this kludge ???).
1344 -- The tables are now complete, so we can record the last index in the
1345 -- Subps table for later reference in Cprint.
1347 Subps.Table (Subps_First).Last := Subps.Last;
1349 -- Next step, create the entities for code we will insert. We do this
1350 -- at the start so that all the entities are defined, regardless of the
1351 -- order in which we do the code insertions.
1353 Create_Entities : for J in Subps_First .. Subps.Last loop
1355 STJ : Subp_Entry renames Subps.Table (J);
1356 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1359 -- First we create the ARECnF entity for the additional formal for
1360 -- all subprograms which need an activation record passed.
1362 if STJ.Uplevel_Ref < STJ.Lev then
1364 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
1367 -- Define the AREC entities for the activation record if needed
1369 if STJ.Declares_AREC then
1371 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
1373 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
1375 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
1377 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
1379 -- Define uplink component entity if inner nesting case
1381 if Present (STJ.ARECnF) then
1383 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1387 end loop Create_Entities;
1389 -- Loop through subprograms
1392 Addr : constant Entity_Id := RTE (RE_Address);
1395 for J in Subps_First .. Subps.Last loop
1397 STJ : Subp_Entry renames Subps.Table (J);
1400 -- First add the extra formal if needed. This applies to all
1401 -- nested subprograms that require an activation record to be
1402 -- passed, as indicated by ARECnF being defined.
1404 if Present (STJ.ARECnF) then
1406 -- Here we need the extra formal. We do the expansion and
1407 -- analysis of this manually, since it is fairly simple,
1408 -- and it is not obvious how we can get what we want if we
1409 -- try to use the normal Analyze circuit.
1411 Add_Extra_Formal : declare
1412 Encl : constant SI_Type := Enclosing_Subp (J);
1413 STJE : Subp_Entry renames Subps.Table (Encl);
1414 -- Index and Subp_Entry for enclosing routine
1416 Form : constant Entity_Id := STJ.ARECnF;
1417 -- The formal to be added. Note that n here is one less
1418 -- than the level of the subprogram itself (STJ.Ent).
1420 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1421 -- S is an N_Function/Procedure_Specification node, and F
1422 -- is the new entity to add to this subprogramn spec as
1423 -- the last Extra_Formal.
1425 ----------------------
1426 -- Add_Form_To_Spec --
1427 ----------------------
1429 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1430 Sub : constant Entity_Id := Defining_Entity (S);
1434 -- Case of at least one Extra_Formal is present, set
1435 -- ARECnF as the new last entry in the list.
1437 if Present (Extra_Formals (Sub)) then
1438 Ent := Extra_Formals (Sub);
1439 while Present (Extra_Formal (Ent)) loop
1440 Ent := Extra_Formal (Ent);
1443 Set_Extra_Formal (Ent, F);
1445 -- No Extra formals present
1448 Set_Extra_Formals (Sub, F);
1449 Ent := Last_Formal (Sub);
1451 if Present (Ent) then
1452 Set_Extra_Formal (Ent, F);
1455 end Add_Form_To_Spec;
1457 -- Start of processing for Add_Extra_Formal
1460 -- Decorate the new formal entity
1462 Set_Scope (Form, STJ.Ent);
1463 Set_Ekind (Form, E_In_Parameter);
1464 Set_Etype (Form, STJE.ARECnPT);
1465 Set_Mechanism (Form, By_Copy);
1466 Set_Never_Set_In_Source (Form, True);
1467 Set_Analyzed (Form, True);
1468 Set_Comes_From_Source (Form, False);
1469 Set_Is_Activation_Record (Form, True);
1471 -- Case of only body present
1473 if Acts_As_Spec (STJ.Bod) then
1474 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1476 -- Case of separate spec
1479 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1481 end Add_Extra_Formal;
1484 -- Processing for subprograms that declare an activation record
1486 if Present (STJ.ARECn) then
1488 -- Local declarations for one such subprogram
1491 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1495 Decl_ARECnT : Node_Id;
1496 Decl_ARECnPT : Node_Id;
1497 Decl_ARECn : Node_Id;
1498 Decl_ARECnP : Node_Id;
1499 -- Declaration nodes for the AREC entities we build
1501 Decl_Assign : Node_Id;
1502 -- Assigment to set uplink, Empty if none
1505 -- List of new declarations we create
1508 -- Build list of component declarations for ARECnT
1510 Clist := Empty_List;
1512 -- If we are in a subprogram that has a static link that
1513 -- is passed in (as indicated by ARECnF being defined),
1514 -- then include ARECnU : ARECmPT where ARECmPT comes from
1515 -- the level one higher than the current level, and the
1516 -- entity ARECnPT comes from the enclosing subprogram.
1518 if Present (STJ.ARECnF) then
1521 renames Subps.Table (Enclosing_Subp (J));
1524 Make_Component_Declaration (Loc,
1525 Defining_Identifier => STJ.ARECnU,
1526 Component_Definition =>
1527 Make_Component_Definition (Loc,
1528 Subtype_Indication =>
1529 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1533 -- Add components for uplevel referenced entities
1535 if Present (STJ.Uents) then
1541 -- 1's origin of index in list of elements. This is
1542 -- used to uniquify names if needed in Upref_Name.
1545 Elmt := First_Elmt (STJ.Uents);
1547 while Present (Elmt) loop
1548 Uent := Node (Elmt);
1552 Make_Defining_Identifier (Loc,
1553 Chars => Upref_Name (Uent, Indx, Clist));
1555 Set_Activation_Record_Component
1559 Make_Component_Declaration (Loc,
1560 Defining_Identifier => Comp,
1561 Component_Definition =>
1562 Make_Component_Definition (Loc,
1563 Subtype_Indication =>
1564 New_Occurrence_Of (Addr, Loc))));
1571 -- Now we can insert the AREC declarations into the body
1573 -- type ARECnT is record .. end record;
1574 -- pragma Suppress_Initialization (ARECnT);
1576 -- Note that we need to set the Suppress_Initialization
1577 -- flag after Decl_ARECnT has been analyzed.
1580 Make_Full_Type_Declaration (Loc,
1581 Defining_Identifier => STJ.ARECnT,
1583 Make_Record_Definition (Loc,
1585 Make_Component_List (Loc,
1586 Component_Items => Clist)));
1587 Decls := New_List (Decl_ARECnT);
1589 -- type ARECnPT is access all ARECnT;
1592 Make_Full_Type_Declaration (Loc,
1593 Defining_Identifier => STJ.ARECnPT,
1595 Make_Access_To_Object_Definition (Loc,
1596 All_Present => True,
1597 Subtype_Indication =>
1598 New_Occurrence_Of (STJ.ARECnT, Loc)));
1599 Append_To (Decls, Decl_ARECnPT);
1601 -- ARECn : aliased ARECnT;
1604 Make_Object_Declaration (Loc,
1605 Defining_Identifier => STJ.ARECn,
1606 Aliased_Present => True,
1607 Object_Definition =>
1608 New_Occurrence_Of (STJ.ARECnT, Loc));
1609 Append_To (Decls, Decl_ARECn);
1611 -- ARECnP : constant ARECnPT := ARECn'Access;
1614 Make_Object_Declaration (Loc,
1615 Defining_Identifier => STJ.ARECnP,
1616 Constant_Present => True,
1617 Object_Definition =>
1618 New_Occurrence_Of (STJ.ARECnPT, Loc),
1620 Make_Attribute_Reference (Loc,
1622 New_Occurrence_Of (STJ.ARECn, Loc),
1623 Attribute_Name => Name_Access));
1624 Append_To (Decls, Decl_ARECnP);
1626 -- If we are in a subprogram that has a static link that
1627 -- is passed in (as indicated by ARECnF being defined),
1628 -- then generate ARECn.ARECmU := ARECmF where m is
1629 -- one less than the current level to set the uplink.
1631 if Present (STJ.ARECnF) then
1633 Make_Assignment_Statement (Loc,
1635 Make_Selected_Component (Loc,
1637 New_Occurrence_Of (STJ.ARECn, Loc),
1639 New_Occurrence_Of (STJ.ARECnU, Loc)),
1641 New_Occurrence_Of (STJ.ARECnF, Loc));
1642 Append_To (Decls, Decl_Assign);
1645 Decl_Assign := Empty;
1648 Prepend_List_To (Declarations (STJ.Bod), Decls);
1650 -- Analyze the newly inserted declarations. Note that we
1651 -- do not need to establish the whole scope stack, since
1652 -- we have already set all entity fields (so there will
1653 -- be no searching of upper scopes to resolve names). But
1654 -- we do set the scope of the current subprogram, so that
1655 -- newly created entities go in the right entity chain.
1657 -- We analyze with all checks suppressed (since we do
1658 -- not expect any exceptions).
1660 Push_Scope (STJ.Ent);
1661 Analyze (Decl_ARECnT, Suppress => All_Checks);
1663 -- Note that we need to call Set_Suppress_Initialization
1664 -- after Decl_ARECnT has been analyzed, but before
1665 -- analyzing Decl_ARECnP so that the flag is properly
1666 -- taking into account.
1668 Set_Suppress_Initialization (STJ.ARECnT);
1670 Analyze (Decl_ARECnPT, Suppress => All_Checks);
1671 Analyze (Decl_ARECn, Suppress => All_Checks);
1672 Analyze (Decl_ARECnP, Suppress => All_Checks);
1674 if Present (Decl_Assign) then
1675 Analyze (Decl_Assign, Suppress => All_Checks);
1680 -- Next step, for each uplevel referenced entity, add
1681 -- assignment operations to set the component in the
1682 -- activation record.
1684 if Present (STJ.Uents) then
1689 Elmt := First_Elmt (STJ.Uents);
1690 while Present (Elmt) loop
1692 Ent : constant Entity_Id := Node (Elmt);
1693 Loc : constant Source_Ptr := Sloc (Ent);
1694 Dec : constant Node_Id :=
1695 Declaration_Node (Ent);
1700 -- For parameters, we insert the assignment
1701 -- right after the declaration of ARECnP.
1702 -- For all other entities, we insert
1703 -- the assignment immediately after
1704 -- the declaration of the entity.
1706 -- Note: we don't need to mark the entity
1707 -- as being aliased, because the address
1708 -- attribute will mark it as Address_Taken,
1709 -- and that is good enough.
1711 if Is_Formal (Ent) then
1717 -- Build and insert the assignment:
1718 -- ARECn.nam := nam'Address
1721 Make_Assignment_Statement (Loc,
1723 Make_Selected_Component (Loc,
1725 New_Occurrence_Of (STJ.ARECn, Loc),
1728 (Activation_Record_Component
1733 Make_Attribute_Reference (Loc,
1735 New_Occurrence_Of (Ent, Loc),
1736 Attribute_Name => Name_Address));
1738 -- or else 'Access for unconstrained
1739 Insert_After (Ins, Asn);
1741 -- Analyze the assignment statement. We do
1742 -- not need to establish the relevant scope
1743 -- stack entries here, because we have
1744 -- already set the correct entity references,
1745 -- so no name resolution is required, and no
1746 -- new entities are created, so we don't even
1747 -- need to set the current scope.
1749 -- We analyze with all checks suppressed
1750 -- (since we do not expect any exceptions).
1752 Analyze (Asn, Suppress => All_Checks);
1765 -- Next step, process uplevel references. This has to be done in a
1766 -- separate pass, after completing the processing in Sub_Loop because we
1767 -- need all the AREC declarations generated, inserted, and analyzed so
1768 -- that the uplevel references can be successfully analyzed.
1770 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
1772 UPJ : Uref_Entry renames Urefs.Table (J);
1775 -- Ignore type references, these are implicit references that do
1776 -- not need rewriting (e.g. the appearence in a conversion).
1777 -- Also ignore if no reference was specified.
1779 if Is_Type (UPJ.Ent) or else No (UPJ.Ref) then
1783 -- Also ignore uplevel references to bounds of types that come
1784 -- from the original type reference.
1786 if Is_Entity_Name (UPJ.Ref)
1787 and then Present (Entity (UPJ.Ref))
1788 and then Is_Type (Entity (UPJ.Ref))
1793 -- Rewrite one reference
1795 Rewrite_One_Ref : declare
1796 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
1797 -- Source location for the reference
1799 Typ : constant Entity_Id := Etype (UPJ.Ent);
1800 -- The type of the referenced entity
1802 Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref);
1803 -- The actual subtype of the reference
1805 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
1806 -- Subp_Index for caller containing reference
1808 STJR : Subp_Entry renames Subps.Table (RS_Caller);
1809 -- Subp_Entry for subprogram containing reference
1811 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
1812 -- Subp_Index for subprogram containing referenced entity
1814 STJE : Subp_Entry renames Subps.Table (RS_Callee);
1815 -- Subp_Entry for subprogram containing referenced entity
1822 -- Ignore if no ARECnF entity for enclosing subprogram which
1823 -- probably happens as a result of not properly treating
1824 -- instance bodies. To be examined ???
1826 -- If this test is omitted, then the compilation of freeze.adb
1827 -- and inline.adb fail in unnesting mode.
1829 if No (STJR.ARECnF) then
1833 -- Push the current scope, so that the pointer type Tnn, and
1834 -- any subsidiary entities resulting from the analysis of the
1835 -- rewritten reference, go in the right entity chain.
1837 Push_Scope (STJR.Ent);
1839 -- Now we need to rewrite the reference. We have a reference
1840 -- from level STJR.Lev to level STJE.Lev. The general form of
1841 -- the rewritten reference for entity X is:
1843 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
1845 -- where a,b,c,d .. m =
1846 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
1848 pragma Assert (STJR.Lev > STJE.Lev);
1850 -- Compute the prefix of X. Here are examples to make things
1851 -- clear (with parens to show groupings, the prefix is
1852 -- everything except the .X at the end).
1854 -- level 2 to level 1
1858 -- level 3 to level 1
1860 -- (AREC2F.AREC1U).X
1862 -- level 4 to level 1
1864 -- ((AREC3F.AREC2U).AREC1U).X
1866 -- level 6 to level 2
1868 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1870 -- In the above, ARECnF and ARECnU are pointers, so there are
1871 -- explicit dereferences required for these occurrences.
1874 Make_Explicit_Dereference (Loc,
1875 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
1877 for L in STJE.Lev .. STJR.Lev - 2 loop
1878 SI := Enclosing_Subp (SI);
1880 Make_Explicit_Dereference (Loc,
1882 Make_Selected_Component (Loc,
1885 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
1888 -- Get activation record component (must exist)
1890 Comp := Activation_Record_Component (UPJ.Ent);
1891 pragma Assert (Present (Comp));
1893 -- Do the replacement
1896 Make_Attribute_Reference (Loc,
1897 Prefix => New_Occurrence_Of (Atyp, Loc),
1898 Attribute_Name => Name_Deref,
1899 Expressions => New_List (
1900 Make_Selected_Component (Loc,
1903 New_Occurrence_Of (Comp, Loc)))));
1905 -- Analyze and resolve the new expression. We do not need to
1906 -- establish the relevant scope stack entries here, because we
1907 -- have already set all the correct entity references, so no
1908 -- name resolution is needed. We have already set the current
1909 -- scope, so that any new entities created will be in the right
1912 -- We analyze with all checks suppressed (since we do not
1913 -- expect any exceptions)
1915 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
1917 end Rewrite_One_Ref;
1922 end loop Uplev_Refs;
1924 -- Finally, loop through all calls adding extra actual for the
1925 -- activation record where it is required.
1927 Adjust_Calls : for J in Calls.First .. Calls.Last loop
1929 -- Process a single call, we are only interested in a call to a
1930 -- subprogram that actually needs a pointer to an activation record,
1931 -- as indicated by the ARECnF entity being set. This excludes the
1932 -- top level subprogram, and any subprogram not having uplevel refs.
1934 Adjust_One_Call : declare
1935 CTJ : Call_Entry renames Calls.Table (J);
1936 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
1937 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
1939 Loc : constant Source_Ptr := Sloc (CTJ.N);
1947 if Present (STT.ARECnF)
1948 and then Nkind (CTJ.N) in N_Subprogram_Call
1950 -- CTJ.N is a call to a subprogram which may require a pointer
1951 -- to an activation record. The subprogram containing the call
1952 -- is CTJ.From and the subprogram being called is CTJ.To, so we
1953 -- have a call from level STF.Lev to level STT.Lev.
1955 -- There are three possibilities:
1957 -- For a call to the same level, we just pass the activation
1958 -- record passed to the calling subprogram.
1960 if STF.Lev = STT.Lev then
1961 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1963 -- For a call that goes down a level, we pass a pointer to the
1964 -- activation record constructed within the caller (which may
1965 -- be the outer-level subprogram, but also may be a more deeply
1968 elsif STT.Lev = STF.Lev + 1 then
1969 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
1971 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1972 -- since it is not possible to do a downcall of more than
1975 -- For a call from level STF.Lev to level STT.Lev, we
1976 -- have to find the activation record needed by the
1977 -- callee. This is as follows:
1979 -- ARECaF.ARECbU.ARECcU....ARECmU
1981 -- where a,b,c .. m =
1982 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1985 pragma Assert (STT.Lev < STF.Lev);
1987 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1988 SubX := Subp_Index (CTJ.Caller);
1989 for K in reverse STT.Lev .. STF.Lev - 1 loop
1990 SubX := Enclosing_Subp (SubX);
1992 Make_Selected_Component (Loc,
1996 (Subps.Table (SubX).ARECnU, Loc));
2000 -- Extra is the additional parameter to be added. Build a
2001 -- parameter association that we can append to the actuals.
2004 Make_Parameter_Association (Loc,
2006 New_Occurrence_Of (STT.ARECnF, Loc),
2007 Explicit_Actual_Parameter => Extra);
2009 if No (Parameter_Associations (CTJ.N)) then
2010 Set_Parameter_Associations (CTJ.N, Empty_List);
2013 Append (ExtraP, Parameter_Associations (CTJ.N));
2015 -- We need to deal with the actual parameter chain as well. The
2016 -- newly added parameter is always the last actual.
2018 Act := First_Named_Actual (CTJ.N);
2021 Set_First_Named_Actual (CTJ.N, Extra);
2023 -- If call has been relocated (as with an expression in
2024 -- an aggregate), set First_Named pointer in original node
2025 -- as well, because that's the parent of the parameter list.
2027 Set_First_Named_Actual
2028 (Parent (List_Containing (ExtraP)), Extra);
2030 -- Here we must follow the chain and append the new entry
2039 PAN := Parent (Act);
2040 pragma Assert (Nkind (PAN) = N_Parameter_Association);
2041 NNA := Next_Named_Actual (PAN);
2044 Set_Next_Named_Actual (PAN, Extra);
2053 -- Analyze and resolve the new actual. We do not need to
2054 -- establish the relevant scope stack entries here, because
2055 -- we have already set all the correct entity references, so
2056 -- no name resolution is needed.
2058 -- We analyze with all checks suppressed (since we do not
2059 -- expect any exceptions, and also we temporarily turn off
2060 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2061 -- references (not needed at this stage, and in fact causes
2062 -- a bit of recursive chaos).
2064 Opt.Unnest_Subprogram_Mode := False;
2066 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
2067 Opt.Unnest_Subprogram_Mode := True;
2069 end Adjust_One_Call;
2070 end loop Adjust_Calls;
2073 end Unnest_Subprogram;
2075 ------------------------
2076 -- Unnest_Subprograms --
2077 ------------------------
2079 procedure Unnest_Subprograms (N : Node_Id) is
2080 function Search_Subprograms (N : Node_Id) return Traverse_Result;
2081 -- Tree visitor that search for outer level procedures with nested
2082 -- subprograms and invokes Unnest_Subprogram()
2088 procedure Do_Search is new Traverse_Proc (Search_Subprograms);
2089 -- Subtree visitor instantiation
2091 ------------------------
2092 -- Search_Subprograms --
2093 ------------------------
2095 function Search_Subprograms (N : Node_Id) return Traverse_Result is
2097 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
2099 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
2102 -- We are only interested in subprograms (not generic
2103 -- subprograms), that have nested subprograms.
2105 if Is_Subprogram (Spec_Id)
2106 and then Has_Nested_Subprogram (Spec_Id)
2107 and then Is_Library_Level_Entity (Spec_Id)
2109 Unnest_Subprogram (Spec_Id, N);
2114 -- The proper body of a stub may contain nested subprograms,
2115 -- and therefore must be visited explicitly. Nested stubs are
2116 -- examined recursively in Visit_Node.
2118 if Nkind (N) in N_Body_Stub then
2119 Do_Search (Library_Unit (N));
2123 end Search_Subprograms;
2125 -- Start of processing for Unnest_Subprograms
2128 if not Opt.Unnest_Subprogram_Mode then
2132 -- A specification will contain bodies if it contains instantiations so
2133 -- examine package or subprogram declaration of the main unit, when it
2136 if Nkind (Unit (N)) = N_Package_Body
2137 or else (Nkind (Unit (N)) = N_Subprogram_Body
2138 and then not Acts_As_Spec (N))
2140 Do_Search (Library_Unit (N));
2144 end Unnest_Subprograms;