From: Arnaud Charlet Date: Fri, 22 May 2015 12:42:05 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=167b47d9da9a82c0c8f426f1853a961f10322be0;p=gcc.git [multiple changes] 2015-05-22 Ed Schonberg * einfo.ads, einfo.adb (Incomplete_Actuals): New attribute of package instantiations. Holds the list of actuals in the instance that are incomplete types, to determine where the corresponding instance body must be placed. * sem_ch6.adb (Conforming_Types): An incomplete type used as an actual in an instance matches an incomplete formal. * sem_disp.adb (Check_Dispatching_Call): Handle missing case of explicit dereference. (Inherited_Subprograms): In the presence of a limited view there are no subprograms to inherit. * sem_ch12.adb (Preanalyze_Actuals): Build list of incomplete actuals of instance, for later placement of instance body and freeze nodes for actuals. (Install_Body): In the presence of actuals that incomplete types from a limited view, the instance body cannot be placed after the declaration because full views have not been seen yet. Any use of the non-limited views in the instance body requires the presence of a regular with_clause in the enclosing unit, and will fail if this with_clause is missing. We place the instance body at the beginning of the enclosing body, which is the unit being compiled, and ensure that freeze nodes for the full views of the incomplete types appear before the instance. 2015-05-22 Pascal Obry * makeutl.ads, prj-conf.adb, prj-nmsc.adb, prj.ads (In_Place_Option): Removed. (Relocate_Build_Tree_Option): New constant. (Root_Dir_Option): New constant. (Obj_Root_Dir): Removed. (Build_Tree_Dir): New variable. (Root_Src_Tree): Removed. (Root_Dir): New variable. * prj-conf.adb (Get_Or_Create_Configuration_File): Add check for improper relocation. * prj-nmsc.adb (Locate_Directory): Add check for improper relocation. From-SVN: r223553 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 87519d850c2..3777b63b0f0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2015-05-22 Ed Schonberg + + * einfo.ads, einfo.adb (Incomplete_Actuals): New attribute of + package instantiations. Holds the list of actuals in the instance + that are incomplete types, to determine where the corresponding + instance body must be placed. + * sem_ch6.adb (Conforming_Types): An incomplete type used as an + actual in an instance matches an incomplete formal. + * sem_disp.adb (Check_Dispatching_Call): Handle missing case of + explicit dereference. + (Inherited_Subprograms): In the presence of a limited view there + are no subprograms to inherit. + * sem_ch12.adb (Preanalyze_Actuals): Build list of incomplete + actuals of instance, for later placement of instance body and + freeze nodes for actuals. + (Install_Body): In the presence of actuals that incomplete types + from a limited view, the instance body cannot be placed after + the declaration because full views have not been seen yet. Any + use of the non-limited views in the instance body requires + the presence of a regular with_clause in the enclosing unit, + and will fail if this with_clause is missing. We place the + instance body at the beginning of the enclosing body, which is + the unit being compiled, and ensure that freeze nodes for the + full views of the incomplete types appear before the instance. + +2015-05-22 Pascal Obry + + * makeutl.ads, prj-conf.adb, prj-nmsc.adb, prj.ads + (In_Place_Option): Removed. + (Relocate_Build_Tree_Option): New constant. + (Root_Dir_Option): New constant. + (Obj_Root_Dir): Removed. + (Build_Tree_Dir): New variable. + (Root_Src_Tree): Removed. + (Root_Dir): New variable. + * prj-conf.adb (Get_Or_Create_Configuration_File): Add check + for improper relocation. + * prj-nmsc.adb (Locate_Directory): Add check for improper + relocation. + 2015-05-22 Hristian Kirtchev * einfo.adb (Default_Init_Cond_Procedure): Code cleanup. The diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ce0eb4a63be..bcbf20f5409 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -212,6 +212,7 @@ package body Einfo is -- Protection_Object Node23 -- Stored_Constraint Elist23 + -- Incomplete_Actuals Elist24 -- Related_Expression Node24 -- Subps_Index Uint24 @@ -1878,6 +1879,12 @@ package body Einfo is return Node35 (Id); end Import_Pragma; + function Incomplete_Actuals (Id : E) return L is + begin + pragma Assert (Ekind (Id) = E_Package); + return Elist24 (Id); + end Incomplete_Actuals; + function Interface_Alias (Id : E) return E is begin pragma Assert (Is_Subprogram (Id)); @@ -4765,6 +4772,12 @@ package body Einfo is Set_Node4 (Id, V); end Set_Homonym; + procedure Set_Incomplete_Actuals (Id : E; V : L) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Elist24 (Id, V); + end Set_Incomplete_Actuals; + procedure Set_Import_Pragma (Id : E; V : E) is begin pragma Assert (Is_Subprogram (Id)); @@ -9801,6 +9814,9 @@ package body Einfo is E_Procedure => Write_Str ("Subps_Index"); + when E_Package => + Write_Str ("Incomplete_Actuals"); + when others => Write_Str ("Field24???"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 1fe9d7d8b5e..550294f1c15 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2090,6 +2090,13 @@ package Einfo is -- Rep_Item chain mechanism, because a single pragma Import can apply -- to multiple subprogram entities). +-- Incomplete_Actuals (Elist24) +-- Defined on package entities that are instances. Indicates the actusl +-- types in the instantiation that are limited views. IF this list is +-- not empty, the instantiation, which appears in a package declaration, +-- is relocated to the corresponding package body, which must have a +-- corresponding non-limited with_clause. + -- In_Package_Body (Flag48) -- Defined in package entities. Set on the entity that denotes the -- package (the defining occurrence of the package declaration) while @@ -4028,7 +4035,9 @@ package Einfo is -- length objects). It is set conservatively (i.e. if it is True, the -- size is certainly known at compile time, if it is False, then the -- size may or may not be known at compile time, but the code will --- assume that it is not known). +-- assume that it is not known). Note that the value may be known only +-- to the back end, so the fact that this flag is set does not mean that +-- the front end can access the value. -- Small_Value (Ureal21) -- Defined in fixed point types. Points to the universal real for the @@ -6042,6 +6051,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) + -- Incomplete_Actuals (Elist24) (for an instance) -- Abstract_States (Elist25) -- Package_Instantiation (Node26) -- Current_Use_Clause (Node27) @@ -6840,6 +6850,7 @@ package Einfo is function Hiding_Loop_Variable (Id : E) return E; function Homonym (Id : E) return E; function Import_Pragma (Id : E) return E; + function Incomplete_Actuals (Id : E) return L; function In_Package_Body (Id : E) return B; function In_Private_Part (Id : E) return B; function In_Use (Id : E) return B; @@ -7492,6 +7503,7 @@ package Einfo is procedure Set_Hiding_Loop_Variable (Id : E; V : E); procedure Set_Homonym (Id : E; V : E); procedure Set_Import_Pragma (Id : E; V : E); + procedure Set_Incomplete_Actuals (Id : E; V : L); procedure Set_In_Package_Body (Id : E; V : B := True); procedure Set_In_Private_Part (Id : E; V : B := True); procedure Set_In_Use (Id : E; V : B := True); @@ -8265,6 +8277,7 @@ package Einfo is pragma Inline (Hiding_Loop_Variable); pragma Inline (Homonym); pragma Inline (Import_Pragma); + pragma Inline (Incomplete_Actuals); pragma Inline (In_Package_Body); pragma Inline (In_Private_Part); pragma Inline (In_Use); @@ -8763,6 +8776,7 @@ package Einfo is pragma Inline (Set_Hiding_Loop_Variable); pragma Inline (Set_Homonym); pragma Inline (Set_Import_Pragma); + pragma Inline (Set_Incomplete_Actuals); pragma Inline (Set_In_Package_Body); pragma Inline (Set_In_Private_Part); pragma Inline (Set_In_Use); diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 5a318aacf17..45442c85c26 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -66,9 +66,17 @@ package Makeutl is -- Switch used to indicate that the real directories (object, exec, -- library, ...) are subdirectories of those in the project file. - In_Place_Option : constant String := "--in-place"; + Relocate_Build_Tree_Option : constant String := "--relocate-build-tree"; -- Switch to build out-of-tree. In this context the object, exec and - -- library directories are relocated to the current working directory. + -- library directories are relocated to the current working directory + -- or the directory specified as parameter to this option. + + Root_Dir_Option : constant String := "--root-dir"; + -- The root directory under which all artifacts (objects, library, ali) + -- directory are to be found for the current compilation. This directory + -- will be use to relocate artifacts based on this directory. If this + -- option is not specificed the default value is the directory of the + -- main project. Unchecked_Shared_Lib_Imports : constant String := "--unchecked-shared-lib-imports"; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 29217a7ef4e..8c55f2a515b 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -962,19 +962,27 @@ package body Prj.Conf is -- First, find the object directory of the Conf_Project - -- If the object directory is a relative one and Obj_Root_Dir is set, - -- first add it. + -- If the object directory is a relative one and Build_Tree_Dir is + -- set, first add it. Name_Len := 0; if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then - if Obj_Root_Dir /= null then - Add_Str_To_Name_Buffer (Obj_Root_Dir.all); + if Build_Tree_Dir /= null then + Add_Str_To_Name_Buffer (Build_Tree_Dir.all); + + if Get_Name_String (Conf_Project.Directory.Display_Name)'Length + < Root_Dir'Length + then + Raise_Invalid_Config + ("cannot relocate deeper than object directory"); + end if; + Add_Str_To_Name_Buffer (Relative_Path (Get_Name_String (Conf_Project.Directory.Display_Name), - Root_Src_Tree.all)); + Root_Dir.all)); else Get_Name_String (Conf_Project.Directory.Display_Name); end if; @@ -984,12 +992,20 @@ package body Prj.Conf is Get_Name_String (Obj_Dir.Value); else - if Obj_Root_Dir /= null then - Add_Str_To_Name_Buffer (Obj_Root_Dir.all); + if Build_Tree_Dir /= null then + if Get_Name_String + (Conf_Project.Directory.Display_Name)'Length + < Root_Dir'Length + then + Raise_Invalid_Config + ("cannot relocate deeper than object directory"); + end if; + + Add_Str_To_Name_Buffer (Build_Tree_Dir.all); Add_Str_To_Name_Buffer (Relative_Path (Get_Name_String (Conf_Project.Directory.Display_Name), - Root_Src_Tree.all)); + Root_Dir.all)); else Add_Str_To_Name_Buffer (Get_Name_String (Conf_Project.Directory.Display_Name)); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5d209ec71d8..a34b5a1b4b9 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -5589,8 +5589,8 @@ package body Prj.Nmsc is end if; end if; - elsif not No_Sources - and then (Subdirs /= null or else Obj_Root_Dir /= null) + elsif not No_Sources and then + (Subdirs /= null or else Build_Tree_Dir /= null) then Name_Len := 1; Name_Buffer (1) := '.'; @@ -6209,21 +6209,29 @@ package body Prj.Nmsc is -- Check if we have a root-object dir specified, if so relocate all -- artefact directories to it. - if Obj_Root_Dir /= null + if Build_Tree_Dir /= null and then Create /= "" and then not Is_Absolute_Path (Get_Name_String (Name)) then Name_Len := 0; - Add_Str_To_Name_Buffer (Obj_Root_Dir.all); + Add_Str_To_Name_Buffer (Build_Tree_Dir.all); + + if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then + Err_Vars.Error_Msg_File_1 := Name; + Error_Or_Warning + (Data.Flags, Error, + "{ cannot relocate deeper than " & Create & " directory", + No_Location, Project); + end if; + Add_Str_To_Name_Buffer (Relative_Path (The_Parent (The_Parent'First .. The_Parent_Last), - Root_Src_Tree.all)); + Root_Dir.all)); Add_Str_To_Name_Buffer (Get_Name_String (Name)); else - if Obj_Root_Dir /= null and then Create /= "" then - + if Build_Tree_Dir /= null and then Create /= "" then -- Issue a warning that we cannot relocate absolute obj dir Err_Vars.Error_Msg_File_1 := Name; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 4910331c484..29a718eb04b 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -61,16 +61,14 @@ package Prj is -- The value after the equal sign in switch --subdirs=... -- Contains the relative subdirectory. - Obj_Root_Dir : String_Ptr := null; + Build_Tree_Dir : String_Ptr := null; -- A root directory for building out-of-tree projects. All relative object - -- directories will be rooted at this location. If Subdirs is also set it - -- will be added at the end too. + -- directories will be rooted at this location. - Root_Src_Tree : String_Ptr := null; + Root_Dir : String_Ptr := null; -- When using out-of-tree build we need to keep information about the root - -- directory source tree to properly relocate all projects to this root - -- directory. Note that the root source directory is not necessary the - -- directory of the main project. + -- directory of artifacts to properly relocate them. Note that the root + -- directory is not necessary the directory of the main project. type Library_Support is (None, Static_Only, Full); -- Support for Library Project File. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index fca3856fca6..12f76b3af46 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -825,11 +825,14 @@ package body Sem_Ch12 is -- at the end of the enclosing generic package, which is semantically -- neutral. - procedure Preanalyze_Actuals (N : Node_Id); + procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty); -- Analyze actuals to perform name resolution. Full resolution is done -- later, when the expected types are known, but names have to be captured -- before installing parents of generics, that are not visible for the -- actuals themselves. + -- If Inst is present, it is the entity of the package instance. This + -- entity is marked as having a limited_view actual when some actual is + -- a limited view. This is used to place the instance body properly.. procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete @@ -3596,7 +3599,12 @@ package body Sem_Ch12 is end if; Generate_Definition (Act_Decl_Id); - Preanalyze_Actuals (N); + Set_Ekind (Act_Decl_Id, E_Package); + + -- Initialize list of incomplete actuals before analysis. + Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List); + + Preanalyze_Actuals (N, Act_Decl_Id); Init_Env; Env_Installed := True; @@ -8845,6 +8853,66 @@ package body Sem_Ch12 is -- Start of processing for Install_Body begin + -- Handle first the case of an instance with incomplete actual types. + -- The instance body cannot be placed after the declaration because + -- full views have not been seen yet. Any use of the non-limited views + -- in the instance body requires the presence of a regular with_clause + -- in the enclosing unit, and will fail if this with_clause is missing. + -- We place the instance body at the beginning of the enclosing body, + -- which is the unit being compiled, and ensure that freeze nodes for + -- the full views of the incomplete types appear before the instance. + + if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) + and then Expander_Active + and then Ekind (Scope (Act_Id)) = E_Package + then + declare + Scop : constant Entity_Id := Scope (Act_Id); + Body_Id : constant Node_Id := + Corresponding_Body (Unit_Declaration_Node (Scop)); + + begin + Ensure_Freeze_Node (Act_Id); + F_Node := Freeze_Node (Act_Id); + if Present (Body_Id) then + Set_Is_Frozen (Act_Id); + Prepend (Act_Body, Declarations (Parent (Body_Id))); + end if; + + -- Add freeze nodes of formerly incomplete types ahead of + -- the instance body. + + declare + Elmt : Elmt_Id; + F_T : Node_Id; + Typ : Entity_Id; + + begin + Elmt := First_Elmt (Incomplete_Actuals (Act_Id)); + while Present (Elmt) loop + Typ := Node (Elmt); + if From_Limited_With (Typ) then + Typ := Non_Limited_View (Typ); + end if; + Ensure_Freeze_Node (Typ); + F_T := Freeze_Node (Typ); + + -- If freeze node is already in the tree, remove it + -- and place ahead of instance body. + + if Is_List_Member (F_T) then + Remove (F_T); + end if; + + Prepend (F_T, Declarations (Parent (Body_Id))); + Next_Elmt (Elmt); + end loop; + end; + end; + + return; + end if; + -- If the body is a subunit, the freeze point is the corresponding stub -- in the current compilation, not the subunit itself. @@ -13195,7 +13263,7 @@ package body Sem_Ch12 is -- Preanalyze_Actuals -- ------------------------ - procedure Preanalyze_Actuals (N : Node_Id) is + procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is Assoc : Node_Id; Act : Node_Id; Errs : constant Int := Serious_Errors_Detected; @@ -13286,6 +13354,13 @@ package body Sem_Ch12 is elsif Nkind (Act) /= N_Operator_Symbol then Analyze (Act); + + if Is_Entity_Name (Act) + and then Is_Type (Entity (Act)) + and then From_Limited_With (Entity (Act)) + then + Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); + end if; end if; if Errs /= Serious_Errors_Detected then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e366af2ac02..e851346a508 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2822,7 +2822,7 @@ package body Sem_Ch6 is procedure Detect_And_Exchange (Id : Entity_Id); -- Determine whether Id's type denotes an incomplete type associated -- with a limited with clause and exchange the limited view with the - -- non-limited one. + -- non-limited one when available. ------------------------- -- Detect_And_Exchange -- @@ -2831,7 +2831,9 @@ package body Sem_Ch6 is procedure Detect_And_Exchange (Id : Entity_Id) is Typ : constant Entity_Id := Etype (Id); begin - if From_Limited_With (Typ) and then Has_Non_Limited_View (Typ) then + if From_Limited_With (Typ) + and then Has_Non_Limited_View (Typ) + then Set_Etype (Id, Non_Limited_View (Typ)); end if; end Detect_And_Exchange; @@ -6520,6 +6522,16 @@ package body Sem_Ch6 is then return Ctype <= Mode_Conformant or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + + -- In Ada2012, incomplete types (including limited views) can appear + -- as actuals in instantiations. + + elsif Is_Incomplete_Type (Type_1) + and then Is_Incomplete_Type (Type_2) + and then (Used_As_Generic_Actual (Type_1) + or else Used_As_Generic_Actual (Type_2)) + then + return True; end if; -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be @@ -6610,6 +6622,15 @@ package body Sem_Ch6 is end; end if; + -- A limited view of an actual matches the corresponding + -- incomplete formal. + + elsif Ekind (Desig_2) = E_Incomplete_Subtype + and then From_Limited_With (Desig_2) + and then Used_As_Generic_Actual (Etype (Desig_2)) + then + return True; + else return Base_Type (Desig_1) = Base_Type (Desig_2) and then (Ctype = Type_Conformant diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 4bc21f778d5..273b0cd93d0 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -823,6 +823,13 @@ package body Sem_Disp is then Func := Empty; + -- Ditto if it is an explicit dereference. + + elsif + Nkind (Original_Node (Actual)) = N_Explicit_Dereference + then + Func := Empty; + -- Only other possibility is a qualified expression whose -- constituent expression is itself a call. @@ -2125,6 +2132,14 @@ package body Sem_Disp is begin Tag_Typ := Find_Dispatching_Type (S); + -- In the presence of limited views there may be no visible + -- dispatching type. Primitives will be inherited when non- + -- limited view is frozen. + + if No (Tag_Typ) then + return Result (1 .. 0); + end if; + if Is_Concurrent_Type (Tag_Typ) then Tag_Typ := Corresponding_Record_Type (Tag_Typ); end if;