------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ U N S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2014-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sinput; use Sinput; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Unst is -- Tables used by Unnest_Subprogram type Subp_Entry is record Ent : Entity_Id; -- Entity of the subprogram Bod : Node_Id; -- Subprogram_Body node for this subprogram Lev : Nat; -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested -- immediately within this outer subprogram etc.) Urefs : Elist_Id; -- This is a copy of the Uplevel_References field from the entity for -- the subprogram. Copy this to reuse the field for Subps_Index. ARECnF : Entity_Id; -- This entity is defined for all subprograms with uplevel references -- except for the top-level subprogram (Subp itself). It is the entity -- for the formal which is added to the parameter list to pass the -- pointer to the activation record. Note that for this entity, n is -- one less than the current level. ARECn : Entity_Id; ARECnT : Entity_Id; ARECnPT : Entity_Id; ARECnP : Entity_Id; -- These AREC entities are defined only for subprograms for which we -- generate an activation record declaration, i.e. for subprograms -- with at least one nested subprogram that have uplevel referennces. -- They are set to Empty for all other cases. ARECnU : Entity_Id; -- This AREC entity is the uplink component. It is other than Empty only -- for nested subprograms that themselves have nested subprograms and -- have uplevel references. Note that the n here is one less than the -- level of the subprogram defining the activation record. end record; subtype SI_Type is Nat; package Subps is new Table.Table ( Table_Component_Type => Subp_Entry, Table_Index_Type => SI_Type, Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 200, Table_Name => "Unnest_Subps"); -- Records the subprograms in the nest whose outer subprogram is Subp type Call_Entry is record N : Node_Id; -- The actual call From : Entity_Id; -- Entity of the subprogram containing the call To : Entity_Id; -- Entity of the subprogram called end record; package Calls is new Table.Table ( Table_Component_Type => Call_Entry, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 200, Table_Name => "Unnest_Calls"); -- Records each call within the outer subprogram and all nested subprograms -- that are to other subprograms nested within the outer subprogram. These -- are the calls that may need an additional parameter. ------------------------------------- -- Check_Uplevel_Reference_To_Type -- ------------------------------------- procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id) is function Check_Dynamic_Type (T : Entity_Id) return Boolean; -- This is an internal recursive routine that checks if T or any of -- its subsdidiary types are dynamic. If so, then the original Typ is -- marked as having an uplevel reference, as is the subsidiary type in -- question, and any referenced dynamic bounds are also marked as having -- an uplevel reference, and True is returned. If the type is a static -- type, then False is returned; ------------------------ -- Check_Dynamic_Type -- ------------------------ function Check_Dynamic_Type (T : Entity_Id) return Boolean is DT : Boolean := False; begin -- If it's a static type, nothing to do if Is_Static_Type (T) then return False; -- If the type is uplevel referenced, then it must be dynamic elsif Has_Uplevel_Reference (T) then Set_Has_Uplevel_Reference (Typ); return True; -- If the type is at library level, always consider it static, since -- uplevel references do not matter in this case. elsif Is_Library_Level_Entity (T) then Set_Is_Static_Type (T); return False; -- Otherwise we need to figure out what the story is with this type else DT := False; -- For a scalar type, check bounds if Is_Scalar_Type (T) then -- If both bounds static, then this is a static type declare LB : constant Node_Id := Type_Low_Bound (T); UB : constant Node_Id := Type_High_Bound (T); begin if not Is_Static_Expression (LB) then Set_Has_Uplevel_Reference (Entity (LB)); DT := True; end if; if not Is_Static_Expression (UB) then Set_Has_Uplevel_Reference (Entity (UB)); DT := True; end if; end; -- For record type, check all components elsif Is_Record_Type (T) then declare C : Entity_Id; begin C := First_Component_Or_Discriminant (T); while Present (C) loop if Check_Dynamic_Type (Etype (C)) then DT := True; end if; Next_Component_Or_Discriminant (C); end loop; end; -- For array type, check index types and component type elsif Is_Array_Type (T) then declare IX : Node_Id; begin if Check_Dynamic_Type (Component_Type (T)) then DT := True; end if; IX := First_Index (T); while Present (IX) loop if Check_Dynamic_Type (Etype (IX)) then DT := True; end if; Next_Index (IX); end loop; end; -- For now, ignore other types else return False; end if; -- See if we marked that type as dynamic if DT then Set_Has_Uplevel_Reference (T); Set_Has_Uplevel_Reference (Typ); return True; -- If not mark it as static else Set_Is_Static_Type (T); return False; end if; end if; end Check_Dynamic_Type; -- Start of processing for Check_Uplevel_Reference_To_Type begin -- Nothing to do inside a generic (all processing is for instance) if Inside_A_Generic then return; -- Nothing to do if we know this is a static type elsif Is_Static_Type (Typ) then return; -- Nothing to do if already marked as uplevel referenced elsif Has_Uplevel_Reference (Typ) then return; -- Otherwise check if we have a dynamic type else if Check_Dynamic_Type (Typ) then Set_Has_Uplevel_Reference (Typ); end if; end if; null; end Check_Uplevel_Reference_To_Type; ---------------------------- -- Note_Uplevel_Reference -- ---------------------------- procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is Elmt : Elmt_Id; begin -- Nothing to do inside a generic (all processing is for instance) if Inside_A_Generic then return; end if; -- Nothing to do if reference has no entity field if Nkind (N) not in N_Has_Entity then return; end if; -- Establish list if first call for Uplevel_References if No (Uplevel_References (Subp)) then Set_Uplevel_References (Subp, New_Elmt_List); end if; -- Ignore if node is already in the list. This is a bit inefficient, -- but we can definitely get duplicates that cause trouble! Elmt := First_Elmt (Uplevel_References (Subp)); while Present (Elmt) loop if N = Node (Elmt) then return; else Next_Elmt (Elmt); end if; end loop; -- Add new entry to Uplevel_References. Each entry is two elements of -- the list. The first is the actual reference, the second is the -- enclosing subprogram at the point of reference Append_Elmt (N, Uplevel_References (Subp)); if Is_Subprogram (Current_Scope) then Append_Elmt (Current_Scope, Uplevel_References (Subp)); else Append_Elmt (Enclosing_Subprogram (Current_Scope), Uplevel_References (Subp)); end if; Set_Has_Uplevel_Reference (Entity (N)); Set_Has_Uplevel_Reference (Subp); end Note_Uplevel_Reference; ----------------------- -- Unnest_Subprogram -- ----------------------- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is function Actual_Ref (N : Node_Id) return Node_Id; -- This function is applied to an element in the Uplevel_References -- list, and it finds the actual reference. Often this is just N itself, -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and -- this function digs out the actual reference function AREC_String (Lev : Pos) return String; -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... function Enclosing_Subp (Subp : SI_Type) return SI_Type; -- Subp is the index of a subprogram which has a Lev greater than 1. -- This function returns the index of the enclosing subprogram which -- will have a Lev value one less than this. function Get_Level (Sub : Entity_Id) return Nat; -- Sub is either Subp itself, or a subprogram nested within Subp. This -- function returns the level of nesting (Subp = 1, subprograms that -- are immediately nested within Subp = 2, etc). function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index ---------------- -- Actual_Ref -- ---------------- function Actual_Ref (N : Node_Id) return Node_Id is begin case Nkind (N) is -- If we have an entity reference, then this is the actual ref when N_Has_Entity => return N; -- For a type conversion, go get the expression when N_Type_Conversion => return Expression (N); -- For an explicit dereference, get the prefix when N_Explicit_Dereference => return Prefix (N); -- No other possibilities should exist when others => raise Program_Error; end case; end Actual_Ref; ----------------- -- AREC_String -- ----------------- function AREC_String (Lev : Pos) return String is begin if Lev > 9 then return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); else return "AREC" & Character'Val (Lev + 48); end if; end AREC_String; -------------------- -- Enclosing_Subp -- -------------------- function Enclosing_Subp (Subp : SI_Type) return SI_Type is STJ : Subp_Entry renames Subps.Table (Subp); Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent)); begin pragma Assert (STJ.Lev > 1); pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1); return Ret; end Enclosing_Subp; --------------- -- Get_Level -- --------------- function Get_Level (Sub : Entity_Id) return Nat is Lev : Nat; S : Entity_Id; begin Lev := 1; S := Sub; loop if S = Subp then return Lev; else S := Enclosing_Subprogram (S); Lev := Lev + 1; end if; end loop; end Get_Level; ---------------- -- Subp_Index -- ---------------- function Subp_Index (Sub : Entity_Id) return SI_Type is begin pragma Assert (Is_Subprogram (Sub)); return SI_Type (UI_To_Int (Subps_Index (Sub))); end Subp_Index; -- Start of processing for Unnest_Subprogram begin -- Nothing to do inside a generic (all processing is for instance) if Inside_A_Generic then return; end if; -- At least for now, do not unnest anything but main source unit if not In_Extended_Main_Source_Unit (Subp_Body) then return; end if; -- First step, we must mark all nested subprograms that require a static -- link (activation record) because either they contain explicit uplevel -- references (as indicated by Has_Uplevel_Reference being set at this -- point), or they make calls to other subprograms in the same nest that -- require a static link (in which case we set this flag). -- This is a recursive definition, and to implement this, we have to -- build a call graph for the set of nested subprograms, and then go -- over this graph to implement recursively the invariant that if a -- subprogram has a call to a subprogram requiring a static link, then -- the calling subprogram requires a static link. -- First populate the above tables Subps.Init; Calls.Init; Build_Tables : declare function Visit_Node (N : Node_Id) return Traverse_Result; -- Visit a single node in Subp ---------------- -- Visit_Node -- ---------------- function Visit_Node (N : Node_Id) return Traverse_Result is Ent : Entity_Id; Csub : Entity_Id; function Find_Current_Subprogram return Entity_Id; -- Finds the current subprogram containing the call N ----------------------------- -- Find_Current_Subprogram -- ----------------------------- function Find_Current_Subprogram return Entity_Id is Nod : Node_Id; begin Nod := N; loop Nod := Parent (Nod); if Nkind (Nod) = N_Subprogram_Body then if Acts_As_Spec (Nod) then return Defining_Entity (Specification (Nod)); else return Corresponding_Spec (Nod); end if; end if; end loop; end Find_Current_Subprogram; -- Start of processing for Visit_Node begin -- Record a call if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) -- We are only interested in direct calls, not indirect calls -- (where Name (N) is an explicit dereference) at least for now! and then Nkind (Name (N)) in N_Has_Entity then Ent := Entity (Name (N)); -- We are only interested in calls to subprograms nested -- within Subp. Calls to Subp itself or to subprograms that -- are outside the nested structure do not affect us. if Scope_Within (Ent, Subp) then -- For now, ignore calls to generic instances. Seems to be -- some problem there which we will investigate later ??? if Original_Location (Sloc (Ent)) /= Sloc (Ent) or else Is_Generic_Instance (Ent) then null; -- Ignore calls to imported routines elsif Is_Imported (Ent) then null; -- Here we have a call to keep and analyze else Csub := Find_Current_Subprogram; -- Both caller and callee must be subprograms (we ignore -- generic subprograms). if Is_Subprogram (Csub) and then Is_Subprogram (Ent) then Calls.Append ((N, Find_Current_Subprogram, Ent)); end if; end if; end if; -- Record a subprogram. We record a subprogram body that acts as -- a spec. Otherwise we record a subprogram declaration, providing -- that it has a corresponding body we can get hold of. The case -- of no corresponding body being available is ignored for now. elsif (Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N)) or else (Nkind (N) = N_Subprogram_Declaration and then Present (Corresponding_Body (N))) then Subps.Increment_Last; declare STJ : Subp_Entry renames Subps.Table (Subps.Last); begin -- Set fields of Subp_Entry for new subprogram STJ.Ent := Defining_Entity (Specification (N)); STJ.Lev := Get_Level (STJ.Ent); if Nkind (N) = N_Subprogram_Body then STJ.Bod := N; else STJ.Bod := Parent (Declaration_Node (Corresponding_Body (N))); pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body); end if; -- Capture Uplevel_References, and then set (uses the same -- field), the Subps_Index value for this subprogram. STJ.Urefs := Uplevel_References (STJ.Ent); Set_Subps_Index (STJ.Ent, UI_From_Int (Int (Subps.Last))); end; end if; return OK; end Visit_Node; ----------- -- Visit -- ----------- procedure Visit is new Traverse_Proc (Visit_Node); -- Used to traverse the body of Subp, populating the tables -- Start of processing for Build_Tables begin -- A special case, if the outer level subprogram has a separate spec -- then we won't catch it in the traversal of the body. But we do -- want to visit the declaration in this case! if not Acts_As_Spec (Subp_Body) then declare Dummy : Traverse_Result; Decl : constant Node_Id := Parent (Declaration_Node (Corresponding_Spec (Subp_Body))); pragma Assert (Nkind (Decl) = N_Subprogram_Declaration); begin Dummy := Visit_Node (Decl); end; end if; -- Traverse the body to get the rest of the subprograms and calls Visit (Subp_Body); end Build_Tables; -- Second step is to do the transitive closure, if any subprogram has -- a call to a subprogram for which Has_Uplevel_Reference is set, then -- we set Has_Uplevel_Reference for the calling routine. Closure : declare Modified : Boolean; begin -- We use a simple minded algorithm as follows (obviously this can -- be done more efficiently, using one of the standard algorithms -- for efficient transitive closure computation, but this is simple -- and most likely fast enough that its speed does not matter). -- Repeatedly scan the list of calls. Any time we find a call from -- A to B, where A does not have Has_Uplevel_Reference, and B does -- have this flag set, then set the flag for A, and note that we -- have made a change by setting Modified True. We repeat this until -- we make a pass with no modifications. Outer : loop Modified := False; Inner : for J in Calls.First .. Calls.Last loop if not Has_Uplevel_Reference (Calls.Table (J).From) and then Has_Uplevel_Reference (Calls.Table (J).To) then Set_Has_Uplevel_Reference (Calls.Table (J).From); Modified := True; end if; end loop Inner; exit Outer when not Modified; end loop Outer; end Closure; -- Next step, create the entities for code we will insert. We do this -- at the start so that all the entities are defined, regardless of the -- order in which we do the code insertions. Create_Entities : for J in Subps.First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); Loc : constant Source_Ptr := Sloc (STJ.Bod); ARS : constant String := AREC_String (STJ.Lev); begin -- First we create the ARECnF entity for the additional formal -- for all subprograms requiring that an activation record pointer -- be passed. This is true of all subprograms that have uplevel -- references, and whose enclosing subprogram also has uplevel -- references. if Has_Uplevel_Reference (STJ.Ent) and then STJ.Ent /= Subp and then Has_Uplevel_Reference (Enclosing_Subprogram (STJ.Ent)) then STJ.ARECnF := Make_Defining_Identifier (Loc, Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); else STJ.ARECnF := Empty; end if; -- Now define the AREC entities for the activation record. This -- is needed for any subprogram that has nested subprograms and -- has uplevel references. if Has_Nested_Subprogram (STJ.Ent) and then Has_Uplevel_Reference (STJ.Ent) then STJ.ARECn := Make_Defining_Identifier (Loc, Name_Find_Str (ARS)); STJ.ARECnT := Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T")); STJ.ARECnPT := Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT")); STJ.ARECnP := Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P")); else STJ.ARECn := Empty; STJ.ARECnT := Empty; STJ.ARECnPT := Empty; STJ.ARECnP := Empty; STJ.ARECnU := Empty; end if; -- Define uplink component entity if inner nesting case if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then declare ARS1 : constant String := AREC_String (STJ.Lev - 1); begin STJ.ARECnU := Make_Defining_Identifier (Loc, Chars => Name_Find_Str (ARS1 & "U")); end; else STJ.ARECnU := Empty; end if; end; end loop Create_Entities; -- Loop through subprograms Subp_Loop : declare Addr : constant Entity_Id := RTE (RE_Address); begin for J in Subps.First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); begin -- First add the extra formal if needed. This applies to all -- nested subprograms that require an activation record to be -- passed, as indicated by ARECnF being defined. if Present (STJ.ARECnF) then -- Here we need the extra formal. We do the expansion and -- analysis of this manually, since it is fairly simple, -- and it is not obvious how we can get what we want if we -- try to use the normal Analyze circuit. Add_Extra_Formal : declare Encl : constant SI_Type := Enclosing_Subp (J); STJE : Subp_Entry renames Subps.Table (Encl); -- Index and Subp_Entry for enclosing routine Form : constant Entity_Id := STJ.ARECnF; -- The formal to be added. Note that n here is one less -- than the level of the subprogram itself (STJ.Ent). procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); -- S is an N_Function/Procedure_Specification node, and F -- is the new entity to add to this subprogramn spec as -- the last Extra_Formal. ---------------------- -- Add_Form_To_Spec -- ---------------------- procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is Sub : constant Entity_Id := Defining_Entity (S); Ent : Entity_Id; begin -- Case of at least one Extra_Formal is present, set -- ARECnF as the new last entry in the list. if Present (Extra_Formals (Sub)) then Ent := Extra_Formals (Sub); while Present (Extra_Formal (Ent)) loop Ent := Extra_Formal (Ent); end loop; Set_Extra_Formal (Ent, F); -- No Extra formals present else Set_Extra_Formals (Sub, F); Ent := Last_Formal (Sub); if Present (Ent) then Set_Extra_Formal (Ent, F); end if; end if; end Add_Form_To_Spec; -- Start of processing for Add_Extra_Formal begin -- Decorate the new formal entity Set_Scope (Form, STJ.Ent); Set_Ekind (Form, E_In_Parameter); Set_Etype (Form, STJE.ARECnPT); Set_Mechanism (Form, By_Copy); Set_Never_Set_In_Source (Form, True); Set_Analyzed (Form, True); Set_Comes_From_Source (Form, False); -- Case of only body present if Acts_As_Spec (STJ.Bod) then Add_Form_To_Spec (Form, Specification (STJ.Bod)); -- Case of separate spec else Add_Form_To_Spec (Form, Parent (STJ.Ent)); end if; end Add_Extra_Formal; end if; -- Processing for subprograms that have at least one nested -- subprogram, and have uplevel references. if Has_Nested_Subprogram (STJ.Ent) and then Has_Uplevel_Reference (STJ.Ent) then -- Local declarations for one such subprogram declare Loc : constant Source_Ptr := Sloc (STJ.Bod); Elmt : Elmt_Id; Nod : Node_Id; Ent : Entity_Id; Clist : List_Id; Comp : Entity_Id; Decl_ARECnT : Node_Id; Decl_ARECn : Node_Id; Decl_ARECnPT : Node_Id; Decl_ARECnP : Node_Id; -- Declaration nodes for the AREC entities we build Uplevel_Entities : array (1 .. List_Length (STJ.Urefs)) of Entity_Id; Num_Uplevel_Entities : Nat; -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains -- a list (with no duplicates) of the entities for this -- subprogram that are referenced uplevel. The maximum -- number of entries cannot exceed the total number of -- uplevel references. begin -- Populate the Uplevel_Entities array, using the flag -- Uplevel_Reference_Noted to avoid duplicates. Num_Uplevel_Entities := 0; if Present (STJ.Urefs) then Elmt := First_Elmt (STJ.Urefs); while Present (Elmt) loop Nod := Actual_Ref (Node (Elmt)); Ent := Entity (Nod); if not Uplevel_Reference_Noted (Ent) then Set_Uplevel_Reference_Noted (Ent, True); Num_Uplevel_Entities := Num_Uplevel_Entities + 1; Uplevel_Entities (Num_Uplevel_Entities) := Ent; end if; Next_Elmt (Elmt); Next_Elmt (Elmt); end loop; end if; -- Build list of component declarations for ARECnT Clist := Empty_List; -- If we are in a subprogram that has a static link that -- ias passed in (as indicated by ARECnF being deinfed), -- then include ARECnU : ARECnPT := ARECnF where n is -- one less than the current level and the entity ARECnPT -- comes from the enclosing subprogram. if Present (STJ.ARECnF) then declare STJE : Subp_Entry renames Subps.Table (Enclosing_Subp (J)); begin Append_To (Clist, Make_Component_Declaration (Loc, Defining_Identifier => STJ.ARECnU, Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => New_Occurrence_Of (STJE.ARECnPT, Loc)), Expression => New_Occurrence_Of (STJ.ARECnF, Loc))); end; end if; -- Add components for uplevel referenced entities for J in 1 .. Num_Uplevel_Entities loop Comp := Make_Defining_Identifier (Loc, Chars => Chars (Uplevel_Entities (J))); Set_Activation_Record_Component (Uplevel_Entities (J), Comp); Append_To (Clist, Make_Component_Declaration (Loc, Defining_Identifier => Comp, Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => New_Occurrence_Of (Addr, Loc)))); end loop; -- Now we can insert the AREC declarations into the body -- type ARECnT is record .. end record; Decl_ARECnT := Make_Full_Type_Declaration (Loc, Defining_Identifier => STJ.ARECnT, Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Items => Clist))); -- ARECn : aliased ARECnT; Decl_ARECn := Make_Object_Declaration (Loc, Defining_Identifier => STJ.ARECn, Aliased_Present => True, Object_Definition => New_Occurrence_Of (STJ.ARECnT, Loc)); -- type ARECnPT is access all ARECnT; Decl_ARECnPT := Make_Full_Type_Declaration (Loc, Defining_Identifier => STJ.ARECnPT, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => New_Occurrence_Of (STJ.ARECnT, Loc))); -- ARECnP : constant ARECnPT := ARECn'Access; Decl_ARECnP := Make_Object_Declaration (Loc, Defining_Identifier => STJ.ARECnP, Constant_Present => True, Object_Definition => New_Occurrence_Of (STJ.ARECnPT, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (STJ.ARECn, Loc), Attribute_Name => Name_Access)); Prepend_List_To (Declarations (STJ.Bod), New_List (Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP)); -- Analyze the newly inserted declarations. Note that we -- do not need to establish the whole scope stack, since -- we have already set all entity fields (so there will -- be no searching of upper scopes to resolve names). But -- we do set the scope of the current subprogram, so that -- newly created entities go in the right entity chain. -- We analyze with all checks suppressed (since we do -- not expect any exceptions, and also we temporarily -- turn off Unested_Subprogram_Mode to avoid trying to -- mark uplevel references (not needed at this stage, -- and in fact causes a bit of recursive chaos). Push_Scope (STJ.Ent); Opt.Unnest_Subprogram_Mode := False; Analyze (Decl_ARECnT, Suppress => All_Checks); Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnPT, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks); Opt.Unnest_Subprogram_Mode := True; Pop_Scope; -- Next step, for each uplevel referenced entity, add -- assignment operations to set the comoponent in the -- activation record. for J in 1 .. Num_Uplevel_Entities loop declare Ent : constant Entity_Id := Uplevel_Entities (J); Loc : constant Source_Ptr := Sloc (Ent); Dec : constant Node_Id := Declaration_Node (Ent); Ins : Node_Id; Asn : Node_Id; begin -- For parameters, we insert the assignment right -- after the declaration of ARECnP. For all other -- entities, we insert the assignment immediately -- after the declaration of the entity. -- Note: we don't need to mark the entity as being -- aliased, because the address attribute will mark -- it as Address_Taken, and that is good enough. if Is_Formal (Ent) then Ins := Decl_ARECnP; else Ins := Dec; end if; -- Build and insert the assignment: -- ARECn.nam := nam Asn := Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (STJ.ARECn, Loc), Selector_Name => Make_Identifier (Loc, Chars (Ent))), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ent, Loc), Attribute_Name => Name_Address)); Insert_After (Ins, Asn); -- Analyze the assignment statement. We do not need -- to establish the relevant scope stack entries -- here, because we have already set the correct -- entity references, so no name resolution is -- required, and no new entities are created, so -- we don't even need to set the current scope. -- We analyze with all checks suppressed (since -- we do not expect any exceptions, and also we -- temporarily turn off Unested_Subprogram_Mode -- to avoid trying to mark uplevel references (not -- needed at this stage, and in fact causes a bit -- of recursive chaos). Opt.Unnest_Subprogram_Mode := False; Analyze (Asn, Suppress => All_Checks); Opt.Unnest_Subprogram_Mode := True; end; end loop; end; end if; end; end loop; end Subp_Loop; -- Next step, process uplevel references. This has to be done in a -- separate pass, after completing the processing in Sub_Loop because we -- need all the AREC declarations generated, inserted, and analyzed so -- that the uplevel references can be successfully analyzed. Uplev_Refs : for J in Subps.First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); begin -- We are only interested in entries which have uplevel references -- to deal with, as indicated by the Urefs list being present if Present (STJ.Urefs) then -- Process uplevel references for one subprogram declare Elmt : Elmt_Id; begin -- Loop through uplevel references Elmt := First_Elmt (STJ.Urefs); while Present (Elmt) loop -- Rewrite one reference declare Ref : constant Node_Id := Actual_Ref (Node (Elmt)); -- The reference to be rewritten Loc : constant Source_Ptr := Sloc (Ref); -- Source location for the reference Ent : constant Entity_Id := Entity (Ref); -- The referenced entity Typ : constant Entity_Id := Etype (Ent); -- The type of the referenced entity Rsub : constant Entity_Id := Node (Next_Elmt (Elmt)); -- The enclosing subprogram for the reference RSX : constant SI_Type := Subp_Index (Rsub); -- Subp_Index for enclosing subprogram for ref STJR : Subp_Entry renames Subps.Table (RSX); -- Subp_Entry for enclosing subprogram for ref Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Related_Node => Ref); -- Local pointer type for reference Pfx : Node_Id; Comp : Entity_Id; SI : SI_Type; begin -- Push the current scope, so that the pointer type -- Tnn, and any subsidiary entities resulting from -- the analysis of the rewritten reference, go in the -- right entity chain. Push_Scope (STJR.Ent); -- First insert declaration for pointer type -- type Tnn is access all typ; Insert_Action (Node (Elmt), Make_Full_Type_Declaration (Loc, Defining_Identifier => Tnn, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); -- Now we need to rewrite the reference. We have a -- reference is from level STJE.Lev to level STJ.Lev. -- The general form of the rewritten reference for -- entity X is: -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X).all -- where a,b,c,d .. m = -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev pragma Assert (STJR.Lev > STJ.Lev); -- Compute the prefix of X. Here are examples to make -- things clear (with parens to show groupings, the -- prefix is everything except the .X at the end). -- level 2 to level 1 -- AREC1F.X -- level 3 to level 1 -- (AREC2F.AREC1U).X -- level 4 to level 1 -- ((AREC3F.AREC2U).AREC1U).X -- level 6 to level 2 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); SI := RSX; for L in STJ.Lev .. STJR.Lev - 2 loop SI := Enclosing_Subp (SI); Pfx := Make_Selected_Component (Loc, Prefix => Pfx, Selector_Name => New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)); end loop; -- Get activation record component (must exist) Comp := Activation_Record_Component (Ent); pragma Assert (Present (Comp)); -- Do the replacement Rewrite (Ref, Make_Explicit_Dereference (Loc, Prefix => Unchecked_Convert_To (Tnn, Make_Selected_Component (Loc, Prefix => Pfx, Selector_Name => New_Occurrence_Of (Comp, Loc))))); -- Analyze and resolve the new expression. We do not -- need to establish the relevant scope stack entries -- here, because we have already set all the correct -- entity references, so no name resolution is needed. -- We have already set the current scope, so that any -- new entities created will be in the right scope. -- We analyze with all checks suppressed (since we do -- not expect any exceptions, and also we temporarily -- turn off Unested_Subprogram_Mode to avoid trying to -- mark uplevel references (not needed at this stage, -- and in fact causes a bit of recursive chaos). Opt.Unnest_Subprogram_Mode := False; Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks); Opt.Unnest_Subprogram_Mode := True; Pop_Scope; end; Next_Elmt (Elmt); Next_Elmt (Elmt); end loop; end; end if; end; end loop Uplev_Refs; -- Finally, loop through all calls adding extra actual for the -- activation record where it is required. Adjust_Calls : for J in Calls.First .. Calls.Last loop -- Process a single call, we are only interested in a call to a -- subprogram that actually needs a pointer to an activation record, -- as indicated by the ARECnF entity being set. This excludes the -- top level subprogram, and any subprogram not having uplevel refs. Adjust_One_Call : declare CTJ : Call_Entry renames Calls.Table (J); STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.From)); STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.To)); Loc : constant Source_Ptr := Sloc (CTJ.N); Extra : Node_Id; ExtraP : Node_Id; SubX : SI_Type; Act : Node_Id; begin if Present (STT.ARECnF) then -- CTJ.N is a call to a subprogram which may require -- a pointer to an activation record. The subprogram -- containing the call is CTJ.From and the subprogram being -- called is CTJ.To, so we have a call from level STF.Lev to -- level STT.Lev. -- There are three possibilities: -- For a call to the same level, we just pass the activation -- record passed to the calling subprogram. if STF.Lev = STT.Lev then Extra := New_Occurrence_Of (STF.ARECnF, Loc); -- For a call that goes down a level, we pass a pointer -- to the activation record constructed wtihin the caller -- (which may be the outer level subprogram, but also may -- be a more deeply nested caller). elsif STT.Lev = STF.Lev + 1 then Extra := New_Occurrence_Of (STF.ARECnP, Loc); -- Otherwise we must have an upcall (STT.Lev < STF.LEV), -- since it is not possible to do a downcall of more than -- one level. -- For a call from level STF.Lev to level STT.Lev, we -- have to find the activation record needed by the -- callee. This is as follows: -- ARECaF.ARECbU.ARECcU....ARECm -- where a,b,c .. m = -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev else pragma Assert (STT.Lev < STF.Lev); Extra := New_Occurrence_Of (STF.ARECnF, Loc); SubX := Subp_Index (CTJ.From); for K in reverse STT.Lev .. STF.Lev - 1 loop SubX := Enclosing_Subp (SubX); Extra := Make_Selected_Component (Loc, Prefix => Extra, Selector_Name => New_Occurrence_Of (Subps.Table (SubX).ARECnU, Loc)); end loop; end if; -- Extra is the additional parameter to be added. Build a -- parameter association that we can append to the actuals. ExtraP := Make_Parameter_Association (Loc, Selector_Name => New_Occurrence_Of (STT.ARECnF, Loc), Explicit_Actual_Parameter => Extra); if No (Parameter_Associations (CTJ.N)) then Set_Parameter_Associations (CTJ.N, Empty_List); end if; Append (ExtraP, Parameter_Associations (CTJ.N)); -- We need to deal with the actual parameter chain as well. -- The newly added parameter is always the last actual. Act := First_Named_Actual (CTJ.N); if No (Act) then Set_First_Named_Actual (CTJ.N, Extra); -- Here we must follow the chain and append the new entry else loop declare PAN : Node_Id; NNA : Node_Id; begin PAN := Parent (Act); pragma Assert (Nkind (PAN) = N_Parameter_Association); NNA := Next_Named_Actual (PAN); if No (NNA) then Set_Next_Named_Actual (PAN, Extra); exit; end if; Act := NNA; end; end loop; end if; -- Analyze and resolve the new actual. We do not need to -- establish the relevant scope stack entries here, because -- we have already set all the correct entity references, so -- no name resolution is needed. -- We analyze with all checks suppressed (since we do not -- expect any exceptions, and also we temporarily turn off -- Unested_Subprogram_Mode to avoid trying to mark uplevel -- references (not needed at this stage, and in fact causes -- a bit of recursive chaos). Opt.Unnest_Subprogram_Mode := False; Analyze_And_Resolve (Extra, Etype (STT.ARECnF), Suppress => All_Checks); Opt.Unnest_Subprogram_Mode := True; end if; end Adjust_One_Call; end loop Adjust_Calls; return; end Unnest_Subprogram; end Exp_Unst;