1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
35 with Output; use Output;
36 with Rtsfind; use Rtsfind;
38 with Sem_Ch8; use Sem_Ch8;
39 with Sem_Mech; use Sem_Mech;
40 with Sem_Res; use Sem_Res;
41 with Sem_Util; use Sem_Util;
42 with Sinfo; use Sinfo;
43 with Sinput; use Sinput;
44 with Snames; use Snames;
45 with Tbuild; use Tbuild;
46 with Uintp; use Uintp;
48 package body Exp_Unst is
54 -- Table to record calls within the nest being analyzed. These are the
55 -- calls which may need to have an AREC actual added. This table is built
56 -- new for each subprogram nest and cleared at the end of processing each
59 type Call_Entry is record
64 -- Entity of the subprogram containing the call (can be at any level)
67 -- Entity of the subprogram called (always at level 2 or higher). Note
68 -- that in accordance with the basic rules of nesting, the level of To
69 -- is either less than or equal to the level of From, or one greater.
72 package Calls is new Table.Table (
73 Table_Component_Type => Call_Entry,
74 Table_Index_Type => Nat,
77 Table_Increment => 200,
78 Table_Name => "Unnest_Calls");
79 -- Records each call within the outer subprogram and all nested subprograms
80 -- that are to other subprograms nested within the outer subprogram. These
81 -- are the calls that may need an additional parameter.
87 -- Table to record explicit uplevel references to objects (variables,
88 -- constants, formal parameters). These are the references that will
89 -- need rewriting to use the activation table (AREC) pointers. Also
90 -- included are implicit and explicit uplevel references to types, but
91 -- these do not get rewritten by the front end. This table is built new
92 -- for each subprogram nest and cleared at the end of processing each
95 type Uref_Entry is record
97 -- The reference itself. For objects this is always an entity reference
98 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
99 -- flag set and will appear in the Uplevel_Referenced_Entities list of
100 -- the subprogram declaring this entity.
103 -- The Entity_Id of the uplevel referenced object or type
106 -- The entity for the subprogram immediately containing this entity
109 -- The entity for the subprogram containing the referenced entity. Note
110 -- that the level of Callee must be less than the level of Caller, since
111 -- this is an uplevel reference.
114 package Urefs is new Table.Table (
115 Table_Component_Type => Uref_Entry,
116 Table_Index_Type => Nat,
117 Table_Low_Bound => 1,
118 Table_Initial => 100,
119 Table_Increment => 200,
120 Table_Name => "Unnest_Urefs");
122 -----------------------
123 -- Unnest_Subprogram --
124 -----------------------
126 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
127 function AREC_Name (J : Pos; S : String) return Name_Id;
128 -- Returns name for string ARECjS, where j is the decimal value of j
130 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
131 -- Subp is the index of a subprogram which has a Lev greater than 1.
132 -- This function returns the index of the enclosing subprogram which
133 -- will have a Lev value one less than this.
135 function Get_Level (Sub : Entity_Id) return Nat;
136 -- Sub is either Subp itself, or a subprogram nested within Subp. This
137 -- function returns the level of nesting (Subp = 1, subprograms that
138 -- are immediately nested within Subp = 2, etc).
140 function Img_Pos (N : Pos) return String;
141 -- Return image of N without leading blank
143 function Subp_Index (Sub : Entity_Id) return SI_Type;
144 -- Given the entity for a subprogram, return corresponding Subps index
149 Clist : List_Id) return Name_Id;
150 -- This function returns the name to be used in the activation record to
151 -- reference the variable uplevel. Clist is the list of components that
152 -- have been created in the activation record so far. Normally the name
153 -- is just a copy of the Chars field of the entity. The exception is
154 -- when the name has already been used, in which case we suffix the name
155 -- with the index value Index to avoid duplication. This happens with
156 -- declare blocks and generic parameters at least.
162 function AREC_Name (J : Pos; S : String) return Name_Id is
164 return Name_Find_Str ("AREC" & Img_Pos (J) & S);
171 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
172 STJ : Subp_Entry renames Subps.Table (Subp);
173 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
175 pragma Assert (STJ.Lev > 1);
176 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
184 function Get_Level (Sub : Entity_Id) return Nat is
194 S := Enclosing_Subprogram (S);
204 function Img_Pos (N : Pos) return String is
205 Buf : String (1 .. 20);
213 Buf (Ptr) := Character'Val (48 + NV mod 10);
218 return Buf (Ptr + 1 .. Buf'Last);
225 function Subp_Index (Sub : Entity_Id) return SI_Type is
227 pragma Assert (Is_Subprogram (Sub));
228 return SI_Type (UI_To_Int (Subps_Index (Sub)));
238 Clist : List_Id) return Name_Id
246 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
248 (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
255 -- Start of processing for Unnest_Subprogram
258 -- Nothing to do inside a generic (all processing is for instance)
260 if Inside_A_Generic then
264 -- At least for now, do not unnest anything but main source unit
266 if not In_Extended_Main_Source_Unit (Subp_Body) then
270 -- This routine is called late, after the scope stack is gone. The
271 -- following creates a suitable dummy scope stack to be used for the
272 -- analyze/expand calls made from this routine.
276 -- First step, we must mark all nested subprograms that require a static
277 -- link (activation record) because either they contain explicit uplevel
278 -- references (as indicated by ??? being set at this
279 -- point), or they make calls to other subprograms in the same nest that
280 -- require a static link (in which case we set this flag).
282 -- This is a recursive definition, and to implement this, we have to
283 -- build a call graph for the set of nested subprograms, and then go
284 -- over this graph to implement recursively the invariant that if a
285 -- subprogram has a call to a subprogram requiring a static link, then
286 -- the calling subprogram requires a static link.
288 -- First populate the above tables
290 Subps_First := Subps.Last + 1;
294 Build_Tables : declare
295 Current_Subprogram : Entity_Id;
296 -- When we scan a subprogram body, we set Current_Subprogram to the
297 -- corresponding entity. This gets recursively saved and restored.
299 function Visit_Node (N : Node_Id) return Traverse_Result;
300 -- Visit a single node in Subp
306 procedure Visit is new Traverse_Proc (Visit_Node);
307 -- Used to traverse the body of Subp, populating the tables
313 function Visit_Node (N : Node_Id) return Traverse_Result is
318 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean);
319 -- Given a type T, checks if it is a static type defined as a
320 -- type with no dynamic bounds in sight. If so, the only action
321 -- is to set Is_Static_Type True for T. If T is not a static
322 -- type, then all types with dynamic bounds associated with
323 -- T are detected, and their bounds are marked as uplevel
324 -- referenced if not at the library level, and DT is set True.
326 procedure Note_Uplevel_Ref
330 -- Called when we detect an explicit or implicit uplevel reference
331 -- from within Caller to entity E declared in Callee. E can be a
332 -- an object or a type.
334 -----------------------
335 -- Check_Static_Type --
336 -----------------------
338 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is
339 procedure Note_Uplevel_Bound (N : Node_Id);
340 -- N is the bound of a dynamic type. This procedure notes that
341 -- this bound is uplevel referenced, it can handle references
342 -- to entities (typically _FIRST and _LAST entities), and also
343 -- attribute references of the form T'name (name is typically
344 -- FIRST or LAST) where T is the uplevel referenced bound.
346 ------------------------
347 -- Note_Uplevel_Bound --
348 ------------------------
350 procedure Note_Uplevel_Bound (N : Node_Id) is
354 if Is_Entity_Name (N) then
355 if Present (Entity (N)) then
358 Caller => Current_Subprogram,
359 Callee => Enclosing_Subprogram (Entity (N)));
364 elsif Nkind (N) = N_Attribute_Reference then
365 Note_Uplevel_Bound (Prefix (N));
367 end Note_Uplevel_Bound;
369 -- Start of processing for Check_Static_Type
372 -- If already marked static, immediate return
374 if Is_Static_Type (T) then
378 -- If the type is at library level, always consider it static,
379 -- since such uplevel references are irrelevant.
381 if Is_Library_Level_Entity (T) then
382 Set_Is_Static_Type (T);
386 -- Otherwise figure out what the story is with this type
388 -- For a scalar type, check bounds
390 if Is_Scalar_Type (T) then
392 -- If both bounds static, then this is a static type
395 LB : constant Node_Id := Type_Low_Bound (T);
396 UB : constant Node_Id := Type_High_Bound (T);
399 if not Is_Static_Expression (LB) then
400 Note_Uplevel_Bound (LB);
404 if not Is_Static_Expression (UB) then
405 Note_Uplevel_Bound (UB);
410 -- For record type, check all components
412 elsif Is_Record_Type (T) then
416 C := First_Component_Or_Discriminant (T);
417 while Present (C) loop
418 Check_Static_Type (Etype (C), DT);
419 Next_Component_Or_Discriminant (C);
423 -- For array type, check index types and component type
425 elsif Is_Array_Type (T) then
429 Check_Static_Type (Component_Type (T), DT);
431 IX := First_Index (T);
432 while Present (IX) loop
433 Check_Static_Type (Etype (IX), DT);
438 -- For now, ignore other types
445 Set_Is_Static_Type (T);
447 end Check_Static_Type;
449 ----------------------
450 -- Note_Uplevel_Ref --
451 ----------------------
453 procedure Note_Uplevel_Ref
459 -- Nothing to do for static type
461 if Is_Static_Type (E) then
465 -- Nothing to do if Caller and Callee are the same
467 if Caller = Callee then
470 -- Callee may be a function that returns an array, and
471 -- that has been rewritten as a procedure. If caller is
472 -- that procedure, nothing to do either.
474 elsif Ekind (Callee) = E_Function
475 and then Rewritten_For_C (Callee)
476 and then Next_Entity (Callee) = Caller
481 -- We have a new uplevel referenced entity
483 -- All we do at this stage is to add the uplevel reference to
484 -- the table. It's too earch to do anything else, since this
485 -- uplevel reference may come from an unreachable subprogram
486 -- in which case the entry will be deleted.
488 Urefs.Append ((N, E, Caller, Callee));
489 end Note_Uplevel_Ref;
491 -- Start of processing for Visit_Node
496 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
498 -- We are only interested in direct calls, not indirect calls
499 -- (where Name (N) is an explicit dereference) at least for now!
501 and then Nkind (Name (N)) in N_Has_Entity
503 Ent := Entity (Name (N));
505 -- We are only interested in calls to subprograms nested
506 -- within Subp. Calls to Subp itself or to subprograms that
507 -- are outside the nested structure do not affect us.
509 if Scope_Within (Ent, Subp) then
511 -- Ignore calls to imported routines
513 if Is_Imported (Ent) then
516 -- Here we have a call to keep and analyze
519 -- Both caller and callee must be subprograms
521 if Is_Subprogram (Ent) then
522 Calls.Append ((N, Current_Subprogram, Ent));
527 -- Record a subprogram. We record a subprogram body that acts as
528 -- a spec. Otherwise we record a subprogram declaration, providing
529 -- that it has a corresponding body we can get hold of. The case
530 -- of no corresponding body being available is ignored for now.
532 elsif Nkind (N) = N_Subprogram_Body then
533 Ent := Unique_Defining_Entity (N);
535 -- Ignore generic subprogram
537 if Is_Generic_Subprogram (Ent) then
541 -- Make new entry in subprogram table if not already made
544 L : constant Nat := Get_Level (Ent);
552 Declares_AREC => False,
561 Set_Subps_Index (Ent, UI_From_Int (Subps.Last));
564 -- We make a recursive call to scan the subprogram body, so
565 -- that we can save and restore Current_Subprogram.
568 Save_CS : constant Entity_Id := Current_Subprogram;
572 Current_Subprogram := Ent;
576 Decl := First (Declarations (N));
577 while Present (Decl) loop
584 Visit (Handled_Statement_Sequence (N));
586 -- Restore current subprogram setting
588 Current_Subprogram := Save_CS;
591 -- Now at this level, return skipping the subprogram body
592 -- descendents, since we already took care of them!
596 -- Record an uplevel reference
598 elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then
601 -- Only interested in entities declared within our nest
603 if not Is_Library_Level_Entity (Ent)
604 and then Scope_Within_Or_Same (Scope (Ent), Subp)
607 -- Constants and variables are interesting
609 (Ekind_In (Ent, E_Constant, E_Variable)
611 -- Formals are interesting, but not if being used as mere
612 -- names of parameters for name notation calls.
617 (Nkind (Parent (N)) = N_Parameter_Association
618 and then Selector_Name (Parent (N)) = N))
620 -- Types other than known Is_Static types are interesting
622 or else (Is_Type (Ent)
623 and then not Is_Static_Type (Ent)))
625 -- Here we have a possible interesting uplevel reference
627 if Is_Type (Ent) then
629 DT : Boolean := False;
632 Check_Static_Type (Ent, DT);
634 if Is_Static_Type (Ent) then
640 Caller := Current_Subprogram;
641 Callee := Enclosing_Subprogram (Ent);
643 if Callee /= Caller and then not Is_Static_Type (Ent) then
644 Note_Uplevel_Ref (Ent, Caller, Callee);
648 -- If we have a body stub, visit the associated subunit
650 elsif Nkind (N) in N_Body_Stub then
651 Visit (Library_Unit (N));
653 -- Skip generic declarations
655 elsif Nkind (N) in N_Generic_Declaration then
658 -- Skip generic package body
660 elsif Nkind (N) = N_Package_Body
661 and then Present (Corresponding_Spec (N))
662 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
667 -- Fall through to continue scanning children of this node
672 -- Start of processing for Build_Tables
675 -- Traverse the body to get subprograms, calls and uplevel references
680 -- Now do the first transitive closure which determines which
681 -- subprograms in the nest are actually reachable.
683 Reachable_Closure : declare
687 Subps.Table (1).Reachable := True;
689 -- We use a simple minded algorithm as follows (obviously this can
690 -- be done more efficiently, using one of the standard algorithms
691 -- for efficient transitive closure computation, but this is simple
692 -- and most likely fast enough that its speed does not matter).
694 -- Repeatedly scan the list of calls. Any time we find a call from
695 -- A to B, where A is reachable, but B is not, then B is reachable,
696 -- and note that we have made a change by setting Modified True. We
697 -- repeat this until we make a pass with no modifications.
701 Inner : for J in Calls.First .. Calls.Last loop
703 CTJ : Call_Entry renames Calls.Table (J);
705 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
706 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
708 SUBF : Subp_Entry renames Subps.Table (SINF);
709 SUBT : Subp_Entry renames Subps.Table (SINT);
712 if SUBF.Reachable and then not SUBT.Reachable then
713 SUBT.Reachable := True;
719 exit Outer when not Modified;
721 end Reachable_Closure;
723 -- Remove calls from unreachable subprograms
730 for J in Calls.First .. Calls.Last loop
732 CTJ : Call_Entry renames Calls.Table (J);
734 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
735 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
737 SUBF : Subp_Entry renames Subps.Table (SINF);
738 SUBT : Subp_Entry renames Subps.Table (SINT);
741 if SUBF.Reachable then
742 pragma Assert (SUBT.Reachable);
743 New_Index := New_Index + 1;
744 Calls.Table (New_Index) := Calls.Table (J);
749 Calls.Set_Last (New_Index);
752 -- Remove uplevel references from unreachable subprograms
759 for J in Urefs.First .. Urefs.Last loop
761 URJ : Uref_Entry renames Urefs.Table (J);
763 SINF : constant SI_Type := Subp_Index (URJ.Caller);
764 SINT : constant SI_Type := Subp_Index (URJ.Callee);
766 SUBF : Subp_Entry renames Subps.Table (SINF);
767 SUBT : Subp_Entry renames Subps.Table (SINT);
772 -- Keep reachable reference
774 if SUBF.Reachable then
775 New_Index := New_Index + 1;
776 Urefs.Table (New_Index) := Urefs.Table (J);
778 -- And since we know we are keeping this one, this is a good
779 -- place to fill in information for a good reference.
781 -- Mark all enclosing subprograms need to declare AREC
785 S := Enclosing_Subprogram (S);
786 Subps.Table (Subp_Index (S)).Declares_AREC := True;
787 exit when S = URJ.Callee;
790 -- Add to list of uplevel referenced entities for Callee.
791 -- We do not add types to this list, only actual references
792 -- to objects that will be referenced uplevel, and we use
793 -- the flag Is_Uplevel_Referenced_Entity to avoid making
794 -- duplicate entries in the list.
796 if not Is_Uplevel_Referenced_Entity (URJ.Ent) then
797 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
799 if not Is_Type (URJ.Ent) then
800 Append_New_Elmt (URJ.Ent, SUBT.Uents);
804 -- And set uplevel indication for caller
806 if SUBT.Lev < SUBF.Uplevel_Ref then
807 SUBF.Uplevel_Ref := SUBT.Lev;
813 Urefs.Set_Last (New_Index);
816 -- Remove unreachable subprograms from Subps table. Note that we do
817 -- this after eliminating entries from the other two tables, since
818 -- thos elimination steps depend on referencing the Subps table.
825 for J in Subps_First .. Subps.Last loop
827 STJ : Subp_Entry renames Subps.Table (J);
832 -- Subprogram is reachable, copy and reset index
834 if STJ.Reachable then
835 New_SI := New_SI + 1;
836 Subps.Table (New_SI) := STJ;
837 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
839 -- Subprogram is not reachable
842 -- Clear index, since no longer active
844 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
846 -- Output debug information if -gnatd.3 set
848 if Debug_Flag_Dot_3 then
849 Write_Str ("Eliminate ");
850 Write_Name (Chars (Subps.Table (J).Ent));
852 Write_Location (Sloc (Subps.Table (J).Ent));
853 Write_Str (" (not referenced)");
857 -- Rewrite declaration and body to null statements
859 Spec := Corresponding_Spec (STJ.Bod);
861 if Present (Spec) then
862 Decl := Parent (Declaration_Node (Spec));
863 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
866 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
871 Subps.Set_Last (New_SI);
874 -- Now it is time for the second transitive closure, which follows calls
875 -- and makes sure that A calls B, and B has uplevel references, then A
876 -- is also marked as having uplevel references.
878 Closure_Uplevel : declare
882 -- We use a simple minded algorithm as follows (obviously this can
883 -- be done more efficiently, using one of the standard algorithms
884 -- for efficient transitive closure computation, but this is simple
885 -- and most likely fast enough that its speed does not matter).
887 -- Repeatedly scan the list of calls. Any time we find a call from
888 -- A to B, where B has uplevel references, make sure that A is marked
889 -- as having at least the same level of uplevel referencing.
893 Inner2 : for J in Calls.First .. Calls.Last loop
895 CTJ : Call_Entry renames Calls.Table (J);
896 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
897 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
898 SUBF : Subp_Entry renames Subps.Table (SINF);
899 SUBT : Subp_Entry renames Subps.Table (SINT);
901 if SUBT.Lev > SUBT.Uplevel_Ref
902 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
904 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
910 exit Outer2 when not Modified;
914 -- We have one more step before the tables are complete. An uplevel
915 -- call from subprogram A to subprogram B where subprogram B has uplevel
916 -- references is in effect an uplevel reference, and must arrange for
917 -- the proper activation link to be passed.
919 for J in Calls.First .. Calls.Last loop
921 CTJ : Call_Entry renames Calls.Table (J);
923 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
924 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
926 SUBF : Subp_Entry renames Subps.Table (SINF);
927 SUBT : Subp_Entry renames Subps.Table (SINT);
932 -- If callee has uplevel references
934 if SUBT.Uplevel_Ref < SUBT.Lev
936 -- And this is an uplevel call
938 and then SUBT.Lev < SUBF.Lev
940 -- We need to arrange for finding the uplink
944 A := Enclosing_Subprogram (A);
945 Subps.Table (Subp_Index (A)).Declares_AREC := True;
946 exit when A = CTJ.Callee;
948 -- In any case exit when we get to the outer level. This
949 -- happens in some odd cases with generics (in particular
950 -- sem_ch3.adb does not compile without this kludge ???).
958 -- The tables are now complete, so we can record the last index in the
959 -- Subps table for later reference in Cprint.
961 Subps.Table (Subps_First).Last := Subps.Last;
963 -- Next step, create the entities for code we will insert. We do this
964 -- at the start so that all the entities are defined, regardless of the
965 -- order in which we do the code insertions.
967 Create_Entities : for J in Subps_First .. Subps.Last loop
969 STJ : Subp_Entry renames Subps.Table (J);
970 Loc : constant Source_Ptr := Sloc (STJ.Bod);
973 -- First we create the ARECnF entity for the additional formal for
974 -- all subprograms which need an activation record passed.
976 if STJ.Uplevel_Ref < STJ.Lev then
978 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
981 -- Define the AREC entities for the activation record if needed
983 if STJ.Declares_AREC then
985 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
987 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
989 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
991 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
993 -- Define uplink component entity if inner nesting case
995 if Present (STJ.ARECnF) then
997 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1001 end loop Create_Entities;
1003 -- Loop through subprograms
1006 Addr : constant Entity_Id := RTE (RE_Address);
1009 for J in Subps_First .. Subps.Last loop
1011 STJ : Subp_Entry renames Subps.Table (J);
1014 -- First add the extra formal if needed. This applies to all
1015 -- nested subprograms that require an activation record to be
1016 -- passed, as indicated by ARECnF being defined.
1018 if Present (STJ.ARECnF) then
1020 -- Here we need the extra formal. We do the expansion and
1021 -- analysis of this manually, since it is fairly simple,
1022 -- and it is not obvious how we can get what we want if we
1023 -- try to use the normal Analyze circuit.
1025 Add_Extra_Formal : declare
1026 Encl : constant SI_Type := Enclosing_Subp (J);
1027 STJE : Subp_Entry renames Subps.Table (Encl);
1028 -- Index and Subp_Entry for enclosing routine
1030 Form : constant Entity_Id := STJ.ARECnF;
1031 -- The formal to be added. Note that n here is one less
1032 -- than the level of the subprogram itself (STJ.Ent).
1034 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1035 -- S is an N_Function/Procedure_Specification node, and F
1036 -- is the new entity to add to this subprogramn spec as
1037 -- the last Extra_Formal.
1039 ----------------------
1040 -- Add_Form_To_Spec --
1041 ----------------------
1043 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1044 Sub : constant Entity_Id := Defining_Entity (S);
1048 -- Case of at least one Extra_Formal is present, set
1049 -- ARECnF as the new last entry in the list.
1051 if Present (Extra_Formals (Sub)) then
1052 Ent := Extra_Formals (Sub);
1053 while Present (Extra_Formal (Ent)) loop
1054 Ent := Extra_Formal (Ent);
1057 Set_Extra_Formal (Ent, F);
1059 -- No Extra formals present
1062 Set_Extra_Formals (Sub, F);
1063 Ent := Last_Formal (Sub);
1065 if Present (Ent) then
1066 Set_Extra_Formal (Ent, F);
1069 end Add_Form_To_Spec;
1071 -- Start of processing for Add_Extra_Formal
1074 -- Decorate the new formal entity
1076 Set_Scope (Form, STJ.Ent);
1077 Set_Ekind (Form, E_In_Parameter);
1078 Set_Etype (Form, STJE.ARECnPT);
1079 Set_Mechanism (Form, By_Copy);
1080 Set_Never_Set_In_Source (Form, True);
1081 Set_Analyzed (Form, True);
1082 Set_Comes_From_Source (Form, False);
1084 -- Case of only body present
1086 if Acts_As_Spec (STJ.Bod) then
1087 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1089 -- Case of separate spec
1092 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1094 end Add_Extra_Formal;
1097 -- Processing for subprograms that declare an activation record
1099 if Present (STJ.ARECn) then
1101 -- Local declarations for one such subprogram
1104 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1108 Decl_ARECnT : Node_Id;
1109 Decl_ARECnPT : Node_Id;
1110 Decl_ARECn : Node_Id;
1111 Decl_ARECnP : Node_Id;
1112 -- Declaration nodes for the AREC entities we build
1114 Decl_Assign : Node_Id;
1115 -- Assigment to set uplink, Empty if none
1118 -- List of new declarations we create
1121 -- Build list of component declarations for ARECnT
1123 Clist := Empty_List;
1125 -- If we are in a subprogram that has a static link that
1126 -- is passed in (as indicated by ARECnF being defined),
1127 -- then include ARECnU : ARECmPT where ARECmPT comes from
1128 -- the level one higher than the current level, and the
1129 -- entity ARECnPT comes from the enclosing subprogram.
1131 if Present (STJ.ARECnF) then
1134 renames Subps.Table (Enclosing_Subp (J));
1137 Make_Component_Declaration (Loc,
1138 Defining_Identifier => STJ.ARECnU,
1139 Component_Definition =>
1140 Make_Component_Definition (Loc,
1141 Subtype_Indication =>
1142 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1146 -- Add components for uplevel referenced entities
1148 if Present (STJ.Uents) then
1154 -- 1's origin of index in list of elements. This is
1155 -- used to uniquify names if needed in Upref_Name.
1158 Elmt := First_Elmt (STJ.Uents);
1160 while Present (Elmt) loop
1161 Uent := Node (Elmt);
1165 Make_Defining_Identifier (Loc,
1166 Chars => Upref_Name (Uent, Indx, Clist));
1168 Set_Activation_Record_Component
1172 Make_Component_Declaration (Loc,
1173 Defining_Identifier => Comp,
1174 Component_Definition =>
1175 Make_Component_Definition (Loc,
1176 Subtype_Indication =>
1177 New_Occurrence_Of (Addr, Loc))));
1184 -- Now we can insert the AREC declarations into the body
1186 -- type ARECnT is record .. end record;
1187 -- pragma Suppress_Initialization (ARECnT);
1188 -- Note that we need to set the Suppress_Initialization
1189 -- flag after Decl_ARECnT has been analyzed.
1192 Make_Full_Type_Declaration (Loc,
1193 Defining_Identifier => STJ.ARECnT,
1195 Make_Record_Definition (Loc,
1197 Make_Component_List (Loc,
1198 Component_Items => Clist)));
1199 Decls := New_List (Decl_ARECnT);
1201 -- type ARECnPT is access all ARECnT;
1204 Make_Full_Type_Declaration (Loc,
1205 Defining_Identifier => STJ.ARECnPT,
1207 Make_Access_To_Object_Definition (Loc,
1208 All_Present => True,
1209 Subtype_Indication =>
1210 New_Occurrence_Of (STJ.ARECnT, Loc)));
1211 Append_To (Decls, Decl_ARECnPT);
1213 -- ARECn : aliased ARECnT;
1216 Make_Object_Declaration (Loc,
1217 Defining_Identifier => STJ.ARECn,
1218 Aliased_Present => True,
1219 Object_Definition =>
1220 New_Occurrence_Of (STJ.ARECnT, Loc));
1221 Append_To (Decls, Decl_ARECn);
1223 -- ARECnP : constant ARECnPT := ARECn'Access;
1226 Make_Object_Declaration (Loc,
1227 Defining_Identifier => STJ.ARECnP,
1228 Constant_Present => True,
1229 Object_Definition =>
1230 New_Occurrence_Of (STJ.ARECnPT, Loc),
1232 Make_Attribute_Reference (Loc,
1234 New_Occurrence_Of (STJ.ARECn, Loc),
1235 Attribute_Name => Name_Access));
1236 Append_To (Decls, Decl_ARECnP);
1238 -- If we are in a subprogram that has a static link that
1239 -- is passed in (as indicated by ARECnF being defined),
1240 -- then generate ARECn.ARECmU := ARECmF where m is
1241 -- one less than the current level to set the uplink.
1243 if Present (STJ.ARECnF) then
1245 Make_Assignment_Statement (Loc,
1247 Make_Selected_Component (Loc,
1249 New_Occurrence_Of (STJ.ARECn, Loc),
1251 New_Occurrence_Of (STJ.ARECnU, Loc)),
1253 New_Occurrence_Of (STJ.ARECnF, Loc));
1254 Append_To (Decls, Decl_Assign);
1257 Decl_Assign := Empty;
1260 Prepend_List_To (Declarations (STJ.Bod), Decls);
1262 -- Analyze the newly inserted declarations. Note that we
1263 -- do not need to establish the whole scope stack, since
1264 -- we have already set all entity fields (so there will
1265 -- be no searching of upper scopes to resolve names). But
1266 -- we do set the scope of the current subprogram, so that
1267 -- newly created entities go in the right entity chain.
1269 -- We analyze with all checks suppressed (since we do
1270 -- not expect any exceptions).
1272 Push_Scope (STJ.Ent);
1273 Analyze (Decl_ARECnT, Suppress => All_Checks);
1275 -- Note that we need to call Set_Suppress_Initialization
1276 -- after Decl_ARECnT has been analyzed, but before
1277 -- analyzing Decl_ARECnP so that the flag is properly
1278 -- taking into account.
1280 Set_Suppress_Initialization (STJ.ARECnT);
1282 Analyze (Decl_ARECnPT, Suppress => All_Checks);
1283 Analyze (Decl_ARECn, Suppress => All_Checks);
1284 Analyze (Decl_ARECnP, Suppress => All_Checks);
1286 if Present (Decl_Assign) then
1287 Analyze (Decl_Assign, Suppress => All_Checks);
1292 -- Mark the types as needing typedefs
1294 Set_Needs_Typedef (STJ.ARECnT);
1295 Set_Needs_Typedef (STJ.ARECnPT);
1297 -- Next step, for each uplevel referenced entity, add
1298 -- assignment operations to set the component in the
1299 -- activation record.
1301 if Present (STJ.Uents) then
1306 Elmt := First_Elmt (STJ.Uents);
1307 while Present (Elmt) loop
1309 Ent : constant Entity_Id := Node (Elmt);
1310 Loc : constant Source_Ptr := Sloc (Ent);
1311 Dec : constant Node_Id :=
1312 Declaration_Node (Ent);
1317 -- For parameters, we insert the assignment
1318 -- right after the declaration of ARECnP.
1319 -- For all other entities, we insert
1320 -- the assignment immediately after
1321 -- the declaration of the entity.
1323 -- Note: we don't need to mark the entity
1324 -- as being aliased, because the address
1325 -- attribute will mark it as Address_Taken,
1326 -- and that is good enough.
1328 if Is_Formal (Ent) then
1334 -- Build and insert the assignment:
1335 -- ARECn.nam := nam'Address
1338 Make_Assignment_Statement (Loc,
1340 Make_Selected_Component (Loc,
1342 New_Occurrence_Of (STJ.ARECn, Loc),
1345 (Activation_Record_Component
1350 Make_Attribute_Reference (Loc,
1352 New_Occurrence_Of (Ent, Loc),
1353 Attribute_Name => Name_Address));
1355 Insert_After (Ins, Asn);
1357 -- Analyze the assignment statement. We do
1358 -- not need to establish the relevant scope
1359 -- stack entries here, because we have
1360 -- already set the correct entity references,
1361 -- so no name resolution is required, and no
1362 -- new entities are created, so we don't even
1363 -- need to set the current scope.
1365 -- We analyze with all checks suppressed
1366 -- (since we do not expect any exceptions).
1368 Analyze (Asn, Suppress => All_Checks);
1381 -- Next step, process uplevel references. This has to be done in a
1382 -- separate pass, after completing the processing in Sub_Loop because we
1383 -- need all the AREC declarations generated, inserted, and analyzed so
1384 -- that the uplevel references can be successfully analyzed.
1386 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
1388 UPJ : Uref_Entry renames Urefs.Table (J);
1391 -- Ignore type references, these are implicit references that do
1392 -- not need rewriting (e.g. the appearence in a conversion).
1394 if Is_Type (UPJ.Ent) then
1398 -- Also ignore uplevel references to bounds of types that come
1399 -- from the original type reference.
1401 if Is_Entity_Name (UPJ.Ref)
1402 and then Present (Entity (UPJ.Ref))
1403 and then Is_Type (Entity (UPJ.Ref))
1408 -- Rewrite one reference
1410 Rewrite_One_Ref : declare
1411 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
1412 -- Source location for the reference
1414 Typ : constant Entity_Id := Etype (UPJ.Ent);
1415 -- The type of the referenced entity
1417 Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref);
1418 -- The actual subtype of the reference
1420 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
1421 -- Subp_Index for caller containing reference
1423 STJR : Subp_Entry renames Subps.Table (RS_Caller);
1424 -- Subp_Entry for subprogram containing reference
1426 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
1427 -- Subp_Index for subprogram containing referenced entity
1429 STJE : Subp_Entry renames Subps.Table (RS_Callee);
1430 -- Subp_Entry for subprogram containing referenced entity
1437 -- Ignore if no ARECnF entity for enclosing subprogram which
1438 -- probably happens as a result of not properly treating
1439 -- instance bodies. To be examined ???
1441 -- If this test is omitted, then the compilation of
1442 -- freeze.adb and inline.adb fail in unnesting mode.
1444 if No (STJR.ARECnF) then
1448 -- Push the current scope, so that the pointer type Tnn, and
1449 -- any subsidiary entities resulting from the analysis of the
1450 -- rewritten reference, go in the right entity chain.
1452 Push_Scope (STJR.Ent);
1454 -- Now we need to rewrite the reference. We have a
1455 -- reference is from level STJR.Lev to level STJE.Lev.
1456 -- The general form of the rewritten reference for
1459 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
1461 -- where a,b,c,d .. m =
1462 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
1464 pragma Assert (STJR.Lev > STJE.Lev);
1466 -- Compute the prefix of X. Here are examples to make things
1467 -- clear (with parens to show groupings, the prefix is
1468 -- everything except the .X at the end).
1470 -- level 2 to level 1
1474 -- level 3 to level 1
1476 -- (AREC2F.AREC1U).X
1478 -- level 4 to level 1
1480 -- ((AREC3F.AREC2U).AREC1U).X
1482 -- level 6 to level 2
1484 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1486 -- In the above, ARECnF and ARECnU are pointers, so there are
1487 -- explicit dereferences required for these occurrences.
1490 Make_Explicit_Dereference (Loc,
1491 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
1493 for L in STJE.Lev .. STJR.Lev - 2 loop
1494 SI := Enclosing_Subp (SI);
1496 Make_Explicit_Dereference (Loc,
1498 Make_Selected_Component (Loc,
1501 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
1504 -- Get activation record component (must exist)
1506 Comp := Activation_Record_Component (UPJ.Ent);
1507 pragma Assert (Present (Comp));
1509 -- Do the replacement
1512 Make_Attribute_Reference (Loc,
1513 Prefix => New_Occurrence_Of (Atyp, Loc),
1514 Attribute_Name => Name_Deref,
1515 Expressions => New_List (
1516 Make_Selected_Component (Loc,
1519 New_Occurrence_Of (Comp, Loc)))));
1521 -- Analyze and resolve the new expression. We do not need to
1522 -- establish the relevant scope stack entries here, because we
1523 -- have already set all the correct entity references, so no
1524 -- name resolution is needed. We have already set the current
1525 -- scope, so that any new entities created will be in the right
1528 -- We analyze with all checks suppressed (since we do not
1529 -- expect any exceptions)
1531 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
1533 end Rewrite_One_Ref;
1538 end loop Uplev_Refs;
1540 -- Finally, loop through all calls adding extra actual for the
1541 -- activation record where it is required.
1543 Adjust_Calls : for J in Calls.First .. Calls.Last loop
1545 -- Process a single call, we are only interested in a call to a
1546 -- subprogram that actually needs a pointer to an activation record,
1547 -- as indicated by the ARECnF entity being set. This excludes the
1548 -- top level subprogram, and any subprogram not having uplevel refs.
1550 Adjust_One_Call : declare
1551 CTJ : Call_Entry renames Calls.Table (J);
1552 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
1553 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
1555 Loc : constant Source_Ptr := Sloc (CTJ.N);
1563 if Present (STT.ARECnF) then
1565 -- CTJ.N is a call to a subprogram which may require
1566 -- a pointer to an activation record. The subprogram
1567 -- containing the call is CTJ.From and the subprogram being
1568 -- called is CTJ.To, so we have a call from level STF.Lev to
1571 -- There are three possibilities:
1573 -- For a call to the same level, we just pass the activation
1574 -- record passed to the calling subprogram.
1576 if STF.Lev = STT.Lev then
1577 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1579 -- For a call that goes down a level, we pass a pointer
1580 -- to the activation record constructed within the caller
1581 -- (which may be the outer level subprogram, but also may
1582 -- be a more deeply nested caller).
1584 elsif STT.Lev = STF.Lev + 1 then
1585 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
1587 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1588 -- since it is not possible to do a downcall of more than
1591 -- For a call from level STF.Lev to level STT.Lev, we
1592 -- have to find the activation record needed by the
1593 -- callee. This is as follows:
1595 -- ARECaF.ARECbU.ARECcU....ARECm
1597 -- where a,b,c .. m =
1598 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1601 pragma Assert (STT.Lev < STF.Lev);
1603 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1604 SubX := Subp_Index (CTJ.Caller);
1605 for K in reverse STT.Lev .. STF.Lev - 1 loop
1606 SubX := Enclosing_Subp (SubX);
1608 Make_Selected_Component (Loc,
1612 (Subps.Table (SubX).ARECnU, Loc));
1616 -- Extra is the additional parameter to be added. Build a
1617 -- parameter association that we can append to the actuals.
1620 Make_Parameter_Association (Loc,
1622 New_Occurrence_Of (STT.ARECnF, Loc),
1623 Explicit_Actual_Parameter => Extra);
1625 if No (Parameter_Associations (CTJ.N)) then
1626 Set_Parameter_Associations (CTJ.N, Empty_List);
1629 Append (ExtraP, Parameter_Associations (CTJ.N));
1631 -- We need to deal with the actual parameter chain as well.
1632 -- The newly added parameter is always the last actual.
1634 Act := First_Named_Actual (CTJ.N);
1637 Set_First_Named_Actual (CTJ.N, Extra);
1639 -- Here we must follow the chain and append the new entry
1648 PAN := Parent (Act);
1649 pragma Assert (Nkind (PAN) = N_Parameter_Association);
1650 NNA := Next_Named_Actual (PAN);
1653 Set_Next_Named_Actual (PAN, Extra);
1662 -- Analyze and resolve the new actual. We do not need to
1663 -- establish the relevant scope stack entries here, because
1664 -- we have already set all the correct entity references, so
1665 -- no name resolution is needed.
1667 -- We analyze with all checks suppressed (since we do not
1668 -- expect any exceptions, and also we temporarily turn off
1669 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1670 -- references (not needed at this stage, and in fact causes
1671 -- a bit of recursive chaos).
1673 Opt.Unnest_Subprogram_Mode := False;
1675 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
1676 Opt.Unnest_Subprogram_Mode := True;
1678 end Adjust_One_Call;
1679 end loop Adjust_Calls;
1682 end Unnest_Subprogram;