From: Robert Dewar Date: Mon, 2 Mar 2015 11:24:33 +0000 (+0000) Subject: back_end.adb (Call_Back_End): Remove previous patch... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=89f0276a49a2ae68f3dd086b237037cdce6ed6b4;p=gcc.git back_end.adb (Call_Back_End): Remove previous patch... 2015-03-02 Robert Dewar * back_end.adb (Call_Back_End): Remove previous patch, the back end now gets to see the result of -gnatd.1 (Unnest_Subprogram_Mode) processing. * elists.ads, elists.adb (List_Length): New function. * exp_unst.ads, exp_unst.adb: Major changes, first complete version. * sem_util.adb (Check_Nested_Access): Handle formals in Unnest_Subprogram_Mode. (Adjust_Named_Associations): Minor reformatting. * sprint.adb (Sprint_Node_Actual): Fix failure to print aliased for parameters. From-SVN: r221115 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d96dd9b83b9..d5da4d8a67c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2015-03-02 Robert Dewar + + * back_end.adb (Call_Back_End): Remove previous patch, + the back end now gets to see the result of -gnatd.1 + (Unnest_Subprogram_Mode) processing. + * elists.ads, elists.adb (List_Length): New function. + * exp_unst.ads, exp_unst.adb: Major changes, first complete version. + * sem_util.adb (Check_Nested_Access): Handle formals in + Unnest_Subprogram_Mode. + (Adjust_Named_Associations): Minor reformatting. + * sprint.adb (Sprint_Node_Actual): Fix failure to print aliased + for parameters. + 2015-03-02 Robert Dewar * atree.ads, atree.adb (Uint24): New function diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index e7176d25d55..7768687b269 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -118,12 +118,6 @@ package body Back_End is return; end if; - -- Skip call if unnesting subprograms (temp for now ???) - - if Opt.Unnest_Subprogram_Mode then - return; - end if; - -- The back end needs to know the maximum line number that can appear -- in a Sloc, in other words the maximum logical line number. diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 5b1f88cdd74..0367bebd727 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -295,17 +295,23 @@ package body Elists is function List_Length (List : Elist_Id) return Nat is Elmt : Elmt_Id; N : Nat; + begin - N := 0; - Elmt := First_Elmt (List); - loop - if No (Elmt) then - return N; - else - N := N + 1; - Next_Elmt (Elmt); - end if; - end loop; + if List = No_Elist then + return 0; + + else + N := 0; + Elmt := First_Elmt (List); + loop + if No (Elmt) then + return N; + else + N := N + 1; + Next_Elmt (Elmt); + end if; + end loop; + end if; end List_Length; ---------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 3daefc07862..c20bf2213d5 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -108,7 +108,7 @@ package Elists is -- no items, then No_Elmt is returned. function List_Length (List : Elist_Id) return Nat; - -- Returns number of elements in given List + -- Returns number of elements in given List (zero if List = No_Elist) function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; pragma Inline (Next_Elmt); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index f5022b95929..29746dcac96 100755 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- 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- -- @@ -27,11 +27,16 @@ 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 Sem; use Sem; with Sem_Aux; use Sem_Aux; +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; @@ -90,11 +95,11 @@ package body Exp_Unst is Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 200, - Table_Name => "Subps"); + Table_Name => "Unnest_Subps"); -- Records the subprograms in the nest whose outer subprogram is Subp type Call_Entry is record - N : Node_Id; + N : Node_Id; -- The actual call From : Entity_Id; @@ -110,7 +115,7 @@ package body Exp_Unst is Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 200, - Table_Name => "Calls"); + 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. @@ -285,6 +290,7 @@ package body Exp_Unst is end if; Set_Has_Uplevel_Reference (Entity (N)); + Set_Has_Uplevel_Reference (Subp); end Note_Uplevel_Reference; ----------------------- @@ -292,10 +298,10 @@ package body Exp_Unst is ----------------------- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is - function Get_AREC_String (Lev : Pos) return String; + function AREC_String (Lev : Pos) return String; -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... - function Get_Enclosing_Subp (Subp : SI_Type) return SI_Type; + 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. @@ -308,34 +314,33 @@ package body Exp_Unst is function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index - --------------------- - -- Get_AREC_String -- - --------------------- + ----------------- + -- AREC_String -- + ----------------- - function Get_AREC_String (Lev : Pos) return String is + function AREC_String (Lev : Pos) return String is begin if Lev > 9 then return - Get_AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); + AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); else return "AREC" & Character'Val (Lev + 48); end if; - end Get_AREC_String; + end AREC_String; - ------------------------ - -- Get_Enclosing_Subp -- - ------------------------ + -------------------- + -- Enclosing_Subp -- + -------------------- - function Get_Enclosing_Subp (Subp : SI_Type) return SI_Type is + function Enclosing_Subp (Subp : SI_Type) return SI_Type is STJ : Subp_Entry renames Subps.Table (Subp); - Ret : constant SI_Type := - UI_To_Int (Subps_Index (Enclosing_Subprogram (STJ.Ent))); + 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 Get_Enclosing_Subp; + end Enclosing_Subp; --------------- -- Get_Level -- @@ -370,6 +375,12 @@ package body Exp_Unst is -- Start of processing for Unnest_Subprogram begin + -- 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 @@ -430,10 +441,7 @@ package body Exp_Unst is if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then Ent := Entity (Name (N)); - - if not Is_Library_Level_Entity (Ent) then - Calls.Append ((N, Find_Current_Subprogram, Ent)); - end if; + Calls.Append ((N, Find_Current_Subprogram, Ent)); -- Record a subprogram @@ -454,7 +462,8 @@ package body Exp_Unst is if Nkind (N) = N_Subprogram_Body then STJ.Bod := N; else - STJ.Bod := Corresponding_Body (N); + STJ.Bod := Parent (Parent (Corresponding_Body (N))); + pragma Assert (Nkind (STJ.Bod) = N_Subprogram_Body); end if; -- Capture Uplevel_References, and then set (uses the same @@ -475,7 +484,26 @@ package body Exp_Unst is 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! + + declare + Dummy : Traverse_Result; + Decl : constant Node_Id := + Parent (Declaration_Node (Corresponding_Spec (Subp_Body))); + pragma Assert (Nkind (Decl) = N_Subprogram_Declaration); + begin + if not Acts_As_Spec (Subp_Body) then + Dummy := Visit_Node (Decl); + end if; + end; + + -- Traverse the body to get the rest of the subprograms and calls + Visit (Subp_Body); end Build_Tables; @@ -521,7 +549,7 @@ package body Exp_Unst is declare STJ : Subp_Entry renames Subps.Table (J); Loc : constant Source_Ptr := Sloc (STJ.Bod); - ARS : constant String := Get_AREC_String (STJ.Lev); + ARS : constant String := AREC_String (STJ.Lev); begin if STJ.Ent = Subp then @@ -529,8 +557,7 @@ package body Exp_Unst is else STJ.ARECnF := Make_Defining_Identifier (Loc, - Chars => - Name_Find_Str (Get_AREC_String (STJ.Lev - 1) & "F")); + Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); end if; if Has_Nested_Subprogram (STJ.Ent) @@ -558,7 +585,7 @@ package body Exp_Unst is if Has_Uplevel_Reference (STJ.Ent) and then STJ.Lev > 1 then declare - ARS1 : constant String := Get_AREC_String (STJ.Lev - 1); + ARS1 : constant String := AREC_String (STJ.Lev - 1); begin STJ.ARECnU := Make_Defining_Identifier (Loc, @@ -590,7 +617,91 @@ package body Exp_Unst is -- nested subprograms that have uplevel references. if STJ.Lev > 1 and then Has_Uplevel_Reference (STJ.Ent) then - null; -- TBD??? + + -- 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. + + 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). + + Formb : Entity_Id; + -- If needed, this is the formal added to the body + + 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. + + ---------------------- + -- Add_Form_To_Spec -- + ---------------------- + + procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is + Sub : constant Entity_Id := Defining_Unit_Name (S); + + begin + if No (First_Entity (Sub)) then + Set_First_Entity (Sub, F); + + else + declare + LastF : constant Entity_Id := Last_Formal (Sub); + begin + if No (LastF) then + Set_Next_Entity (F, First_Entity (Sub)); + Set_First_Entity (Sub, F); + else + Set_Next_Entity (F, Next_Entity (LastF)); + Set_Next_Entity (LastF, F); + end if; + end; + end if; + + if No (Parameter_Specifications (S)) then + Set_Parameter_Specifications (S, Empty_List); + end if; + + Append_To (Parameter_Specifications (S), + Make_Parameter_Specification (Sloc (F), + Defining_Identifier => F, + Parameter_Type => + New_Occurrence_Of (STJE.ARECnPT, Sloc (F)))); + end Add_Form_To_Spec; + + -- Start of processing for 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 + Formb := New_Entity (Nkind (Form), Sloc (Form)); + Copy_Node (Form, Formb); + Add_Form_To_Spec (Form, Parent (STJ.Ent)); + Add_Form_To_Spec (Formb, Specification (STJ.Bod)); + end if; + end Extra_Formal; end if; -- Processing for subprograms that have at least one nested @@ -608,6 +719,12 @@ package body Exp_Unst is 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; @@ -622,19 +739,22 @@ package body Exp_Unst is -- Uplevel_Reference_Noted to avoid duplicates. Num_Uplevel_Entities := 0; - Elmt := First_Elmt (STJ.Urefs); - while Present (Elmt) loop - Ent := Entity (Node (Elmt)); - - 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; + if Present (STJ.Urefs) then + Elmt := First_Elmt (STJ.Urefs); + while Present (Elmt) loop + Ent := Entity (Node (Elmt)); + + 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 @@ -647,7 +767,7 @@ package body Exp_Unst is if STJ.Lev > 1 then declare STJE : Subp_Entry - renames Subps.Table (Get_Enclosing_Subp (J)); + renames Subps.Table (Enclosing_Subp (J)); begin Append_To (Clist, @@ -670,7 +790,7 @@ package body Exp_Unst is Chars => Chars (Uplevel_Entities (J))); Set_Activation_Record_Component - (Uplevel_Entities (J), Comp); + (Uplevel_Entities (J), Comp); Append_To (Clist, Make_Component_Declaration (Loc, @@ -683,49 +803,72 @@ package body Exp_Unst is -- 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 ( - - -- type ARECnT is record .. end record; - - 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; - - 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; - - 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; - - 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)))); + New_List + (Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP)); + + -- Analyze the newly inserted declarations. Note that + -- 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. + + -- 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 (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; -- Next step, for each uplevel referenced entity, add -- assignment operations to set the comoponent in the @@ -736,11 +879,28 @@ package body Exp_Unst is 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 Set_Aliased_Present (Dec); + Set_Is_Aliased (Ent); - Insert_After (Dec, + -- 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. + + 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, @@ -753,143 +913,332 @@ package body Exp_Unst is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Address))); + Attribute_Name => Name_Address)); + + Insert_After (Ins, Asn); + + -- Analyze the assignment statement. Again, 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. + + -- 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 + -- 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 : declare - Elmt : Elmt_Id; + Uplev_Refs : for J in Subps.First .. Subps.Last loop + declare + STJ : Subp_Entry renames Subps.Table (J); - begin - -- Loop through uplevel references + begin + -- We are only interested in entries which have uplevel references + -- to deal with, as indicated by the Urefs list being present - Elmt := First_Elmt (STJ.Urefs); - while Present (Elmt) loop - declare - Ref : constant Node_Id := Node (Elmt); - -- The uplevel reference itself + if Present (STJ.Urefs) then + + -- Process uplevel references for one subprogram - Loc : constant Source_Ptr := Sloc (Ref); - -- Source location for the reference + declare + Elmt : Elmt_Id; - Ent : constant Entity_Id := Entity (Ref); - -- The referenced entity + begin + -- Loop through uplevel references - Typ : constant Entity_Id := Etype (Ent); - -- The type of the referenced entity + Elmt := First_Elmt (STJ.Urefs); + while Present (Elmt) loop - Rsub : constant Entity_Id := - Node (Next_Elmt (Elmt)); - -- The enclosing subprogram for the reference + -- Skip if we have an explicit dereference. This means + -- that we already did the expansion. There can be + -- duplicates in ths STJ.Urefs list. - RSX : constant SI_Type := Subp_Index (Rsub); - -- Subp_Index for enclosing subprogram for ref + if Nkind (Node (Elmt)) = N_Explicit_Dereference then + goto Continue; + end if; - STJR : Subp_Entry renames Subps.Table (RSX); - -- Subp_Entry for enclosing subprogram for ref + -- Otherwise, rewrite this reference - Tnn : constant Entity_Id := - Make_Temporary - (Loc, 'T', Related_Node => Ref); - -- Local pointer type for reference + declare + Ref : constant Node_Id := Node (Elmt); + -- The uplevel reference itself - Pfx : Node_Id; - Comp : Entity_Id; - SI : SI_Type; + Loc : constant Source_Ptr := Sloc (Ref); + -- Source location for the reference - begin - -- First insert declaration for pointer type + Ent : constant Entity_Id := Entity (Ref); + -- The referenced entity - -- type Tnn is access all typ; + Typ : constant Entity_Id := Etype (Ent); + -- The type of the referenced entity - Insert_Action (Ref, - 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)))); + Rsub : constant Entity_Id := + Node (Next_Elmt (Elmt)); + -- The enclosing subprogram for the reference - -- Now we need to rewrite the reference. The - -- reference is from level STJE.Lev to level - -- STJ.Lev. The general form of the rewritten - -- reference for entity X is: + RSX : constant SI_Type := Subp_Index (Rsub); + -- Subp_Index for enclosing subprogram for ref - -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU - -- ....ARECm.X).all + STJR : Subp_Entry renames Subps.Table (RSX); + -- Subp_Entry for enclosing subprogram for ref - -- where a,b,c,d .. m = - -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev + Tnn : constant Entity_Id := + Make_Temporary + (Loc, 'T', Related_Node => Ref); + -- Local pointer type for reference - pragma Assert (STJR.Lev > STJ.Lev); + Pfx : Node_Id; + Comp : Entity_Id; + SI : SI_Type; - -- 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). + begin + -- First insert declaration for pointer type + + -- type Tnn is access all typ; - -- level 2 to level 1 + Insert_Action (Ref, + 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)))); - -- AREC1F.X + -- 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: - -- level 3 to level 1 + -- Tnn!(ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X).all - -- (AREC2F.AREC1U).X + -- where a,b,c,d .. m = + -- STJR.Lev - 1, STJ.Lev - 2, .. STJ.Lev - -- level 4 to level 1 + pragma Assert (STJR.Lev > STJ.Lev); - -- ((AREC3F.AREC2U).AREC1U).X + -- 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 6 to level 2 + -- level 2 to level 1 - -- (((AREC5F.AREC4U).AREC3U).AREC2U).X + -- AREC1F.X - Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); - SI := RSX; - for L in STJ.Lev .. STJR.Lev - 2 loop - SI := Get_Enclosing_Subp (SI); - Pfx := - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of - (Subps.Table (SI).ARECnU, Loc)); - end loop; + -- level 3 to level 1 - -- Get activation record component (must exist) + -- (AREC2F.AREC1U).X - Comp := Activation_Record_Component (Ent); - pragma Assert (Present (Comp)); + -- level 4 to level 1 - -- Do the replacement + -- ((AREC3F.AREC2U).AREC1U).X - Rewrite (Ref, - Make_Explicit_Dereference (Loc, - Prefix => - Unchecked_Convert_To (Tnn, - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of (Comp, Loc))))); + -- level 6 to level 2 - Next_Elmt (Elmt); - Next_Elmt (Elmt); - end; + -- (((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; - end Uplev_Refs; - end; - end if; - end; - end loop; - end Subp_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 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; + 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. - -- TBD ??? + 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 need 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. + + declare + CTJ : Call_Entry renames Calls.Table (J); + + begin + if Has_Uplevel_Reference (CTJ.To) and then CTJ.To /= Subp then + 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 + -- 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 + while Present (Next_Named_Actual (Act)) loop + Act := Next_Named_Actual (Act); + end loop; + + Set_Next_Named_Actual (Act, Extra); + 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; + end if; + end; + end loop Adjust_Calls; return; end Unnest_Subprogram; diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 32b2eb82824..2c554dd979f 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- 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- -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ee5db001761..e048e216be9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2883,13 +2883,22 @@ package body Sem_Util is and then not Is_Imported (Ent) then - -- For VM case, we are only interested in variables, constants, - -- and loop parameters. For general nested procedure usage, we - -- allow types as well. + -- In both the VM case and in Unnest_Subprogram_Mode, we mark + -- variables, constants, and loop parameters. if Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) then null; - elsif not (Unnest_Subprogram_Mode and then Is_Type (Ent)) then + + -- In Unnest_Subprogram_Mode, we also mark types and formals + + elsif Unnest_Subprogram_Mode + and then (Is_Type (Ent) or else Is_Formal (Ent)) + then + null; + + -- All other cases, do not mark + + else return; end if; @@ -14081,8 +14090,8 @@ package body Sem_Util is New_Next := First (Parameter_Associations (New_Node)); while Nkind (Old_Next) /= N_Parameter_Association - or else Explicit_Actual_Parameter (Old_Next) - /= Next_Named_Actual (Old_E) + or else Explicit_Actual_Parameter (Old_Next) /= + Next_Named_Actual (Old_E) loop Next (Old_Next); Next (New_Next); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 8f47053a299..670e5341664 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -2703,12 +2703,15 @@ package body Sprint is -- it is emitted when the access definition is displayed. if Null_Exclusion_Present (Node) - and then Nkind (Parameter_Type (Node)) - /= N_Access_Definition + and then Nkind (Parameter_Type (Node)) /= N_Access_Definition then Write_Str ("not null "); end if; + if Aliased_Present (Node) then + Write_Str ("aliased "); + end if; + Sprint_Node (Parameter_Type (Node)); if Present (Expression (Node)) then