From d9b056ead95099bad4dea18d45f348190ea5c4ce Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 14:02:01 +0200 Subject: [PATCH] [multiple changes] 2011-08-04 Eric Botcazou * bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate the header of the finalization routine. If the unit has no finalizer but is a body whose spec has one, then generate the decrement of the elaboration entity only. If the unit has a finalizer and is a spec, then do not generate the decrement of the elaboration entity. (Gen_Finalize_Library_C): Likewise. 2011-08-04 Hristian Kirtchev * exp_ch7.adb (Alignment_Of): New subsidiary routine. (Bounds_Size_Expression): Removed. (Double_Alignment_Of): New subsidiary routine. (Make_Finalize_Address_Stmts): New local variable Index_Typ. Account for a hole in the dope vector of unconstrained arrays due to different index and element alignments. 2011-08-04 Ed Schonberg * sem_res.adb (Resolve_Allocator): diagnose task allocator that will raise program_error because body has not been seen yet. 2011-08-04 Ed Schonberg * sem_ch10.adb (Analyze_With_Clause): Protect against child unit with an unresolved name. 2011-08-04 Vincent Celier * makeutl.adb (Do_Complete): Check absolute paths in canonical forms 2011-08-04 Yannick Moy * alfa.adb, alfa.ads (Unique_Defining_Entity): move function from here * sem_util.adb, sem_util.ads (Unique_Defining_Entity): ...to here 2011-08-04 Thomas Quinot * sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for instantiation in RCI. 2011-08-04 Emmanuel Briot * make.adb: Share more code with gprbuild From-SVN: r177361 --- gcc/ada/ChangeLog | 47 ++++++++ gcc/ada/alfa.adb | 25 ---- gcc/ada/alfa.ads | 4 - gcc/ada/bindgen.adb | 197 ++++++++++++++++++++---------- gcc/ada/exp_ch7.adb | 103 ++++++++++------ gcc/ada/make.adb | 277 ++++++++++++++++++++++--------------------- gcc/ada/makeutl.adb | 4 +- gcc/ada/sem_ch10.adb | 12 +- gcc/ada/sem_ch12.adb | 24 ++-- gcc/ada/sem_res.adb | 15 +++ gcc/ada/sem_util.adb | 22 ++++ gcc/ada/sem_util.ads | 4 + 12 files changed, 462 insertions(+), 272 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9d287ca86fe..f24846bd44d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2011-08-04 Eric Botcazou + + * bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate + the header of the finalization routine. + If the unit has no finalizer but is a body whose spec has one, then + generate the decrement of the elaboration entity only. + If the unit has a finalizer and is a spec, then do not generate the + decrement of the elaboration entity. + (Gen_Finalize_Library_C): Likewise. + +2011-08-04 Hristian Kirtchev + + * exp_ch7.adb (Alignment_Of): New subsidiary routine. + (Bounds_Size_Expression): Removed. + (Double_Alignment_Of): New subsidiary routine. + (Make_Finalize_Address_Stmts): New local variable Index_Typ. Account + for a hole in the dope vector of unconstrained arrays due to different + index and element alignments. + +2011-08-04 Ed Schonberg + + * sem_res.adb (Resolve_Allocator): diagnose task allocator that will + raise program_error because body has not been seen yet. + +2011-08-04 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): Protect against child unit with + an unresolved name. + +2011-08-04 Vincent Celier + + * makeutl.adb (Do_Complete): Check absolute paths in canonical forms + +2011-08-04 Yannick Moy + + * alfa.adb, alfa.ads (Unique_Defining_Entity): move function from here + * sem_util.adb, sem_util.ads (Unique_Defining_Entity): ...to here + +2011-08-04 Thomas Quinot + + * sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for + instantiation in RCI. + +2011-08-04 Emmanuel Briot + + * make.adb: Share more code with gprbuild + 2011-08-04 Emmanuel Briot * projects.texi: Added documentation for the IDE'Gnat project file diff --git a/gcc/ada/alfa.adb b/gcc/ada/alfa.adb index d61ad17c9b2..6fd1d8f8aae 100644 --- a/gcc/ada/alfa.adb +++ b/gcc/ada/alfa.adb @@ -23,11 +23,8 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; with Output; use Output; with Put_ALFA; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; package body ALFA is @@ -203,26 +200,4 @@ package body ALFA is Debug_Put_ALFA; end palfa; - ---------------------------- - -- Unique_Defining_Entity -- - ---------------------------- - - function Unique_Defining_Entity (N : Node_Id) return Entity_Id is - begin - case Nkind (N) is - when N_Package_Body => - return Corresponding_Spec (N); - - when N_Subprogram_Body => - if Acts_As_Spec (N) then - return Defining_Entity (N); - else - return Corresponding_Spec (N); - end if; - - when others => - return Defining_Entity (N); - end case; - end Unique_Defining_Entity; - end ALFA; diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 3e630a0ad96..71220e46bda 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -319,10 +319,6 @@ package ALFA is procedure Initialize_ALFA_Tables; -- Reset tables for a new compilation - function Unique_Defining_Entity (N : Node_Id) return Entity_Id; - -- Return the entity which represents declaration N, so that matching - -- declaration and body have the same entity. - procedure dalfa; -- Debug routine to dump internal ALFA tables. This is a raw format dump -- showing exactly what the tables contain. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 58636541215..41256aebc66 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1662,38 +1662,84 @@ package body Bindgen is Uspec : Unit_Record; Unum : Unit_Id; + procedure Gen_Header; + -- Generate the header of the finalization routine + + procedure Gen_Header is + begin + WBI (" procedure finalize_library is"); + + -- The following flag is used to check for library-level + -- exceptions raised during finalization. The symbol comes + -- from System.Soft_Links. VM targets use regular Ada to + -- reference the entity. + + if VM_Target = No_VM then + WBI (" LE_Set : Boolean;"); + + Set_String (" pragma Import (Ada, LE_Set, "); + Set_String ("""__gnat_library_exception_set"");"); + Write_Statement_Buffer; + end if; + + WBI (" begin"); + end Gen_Header; + begin for E in reverse Elab_Order.First .. Elab_Order.Last loop Unum := Elab_Order.Table (E); U := Units.Table (Unum); + -- Dealing with package bodies is a little complicated. In such + -- cases we must retrieve the package spec since it contains the + -- spec of the body finalizer. + + if U.Utype = Is_Body then + Unum := Unum + 1; + Uspec := Units.Table (Unum); + else + Uspec := U; + end if; + + Get_Name_String (Uspec.Uname); + -- We are only interested in non-generic packages - if U.Unit_Kind = 'p' - and then U.Has_Finalizer - and then not U.Is_Generic - and then not U.SAL_Interface - and then not U.No_Elab - then - if not Lib_Final_Built then - Lib_Final_Built := True; + if U.Unit_Kind /= 'p' or else U.Is_Generic then + null; - WBI (" procedure finalize_library is"); + -- That aren't an interface to a stand alone library - -- The following flag is used to check for library-level - -- exceptions raised during finalization. The symbol comes - -- from System.Soft_Links. VM targets use regular Ada to - -- reference the entity. + elsif U.SAL_Interface then + null; - if VM_Target = No_VM then - WBI (" LE_Set : Boolean;"); + -- Case of no finalization - Set_String (" pragma Import (Ada, LE_Set, "); - Set_String ("""__gnat_library_exception_set"");"); - Write_Statement_Buffer; + elsif not U.Has_Finalizer then + + -- The only case in which we have to do something is if this + -- is a body, with a separate spec, where the separate spec + -- has a finalizer. In that case, this is where we decrement + -- the elaboration entity. + + if U.Utype = Is_Body and then Uspec.Has_Finalizer then + if not Lib_Final_Built then + Gen_Header; + Lib_Final_Built := True; end if; - WBI (" begin"); + Set_String (" E"); + Set_Unit_Number (Unum); + Set_String (" := E"); + Set_Unit_Number (Unum); + Set_String (" - 1;"); + Write_Statement_Buffer; + end if; + + else + if not Lib_Final_Built then + Gen_Header; + Lib_Final_Built := True; end if; -- Generate: @@ -1732,19 +1778,6 @@ package body Bindgen is Set_Int (Count); Set_String (", """); - -- Dealing with package bodies is a little complicated. In such - -- cases we must retrieve the package spec since it contains the - -- spec of the body finalizer. - - if U.Utype = Is_Body then - Unum := Unum + 1; - Uspec := Units.Table (Unum); - else - Uspec := U; - end if; - - Get_Name_String (Uspec.Uname); - -- Perform name construction -- .NET xx.yy_pkg.xx__yy__finalize @@ -1798,13 +1831,19 @@ package body Bindgen is -- F; -- end; + -- The uname_E decrement is skipped if this is a separate spec, + -- since it will be done when we process the body. + WBI (" begin"); - Set_String (" E"); - Set_Unit_Number (Unum); - Set_String (" := E"); - Set_Unit_Number (Unum); - Set_String (" - 1;"); - Write_Statement_Buffer; + + if U.Utype /= Is_Spec then + Set_String (" E"); + Set_Unit_Number (Unum); + Set_String (" := E"); + Set_Unit_Number (Unum); + Set_String (" - 1;"); + Write_Statement_Buffer; + end if; if Interface_Library_Unit or not Bind_Main_Program then Set_String (" if E"); @@ -1884,37 +1923,68 @@ package body Bindgen is Uspec : Unit_Record; Unum : Unit_Id; + procedure Gen_Header; + -- Generate the header of the finalization routine + + procedure Gen_Header is + begin + WBI ("static void finalize_library(void) {"); + end Gen_Header; + begin for E in reverse Elab_Order.First .. Elab_Order.Last loop Unum := Elab_Order.Table (E); U := Units.Table (Unum); + -- Dealing with package bodies is a little complicated. In such + -- cases we must retrieve the package spec since it contains the + -- spec of the body finalizer. + + if U.Utype = Is_Body then + Unum := Unum + 1; + Uspec := Units.Table (Unum); + else + Uspec := U; + end if; + + Get_Name_String (Uspec.Uname); + -- We are only interested in non-generic packages - if U.Unit_Kind = 'p' - and then U.Has_Finalizer - and then not U.Is_Generic - and then not U.SAL_Interface - and then not U.No_Elab - then - if not Lib_Final_Built then - Lib_Final_Built := True; + if U.Unit_Kind /= 'p' or else U.Is_Generic then + null; - WBI ("static void finalize_library(void) {"); - end if; + -- That aren't an interface to a stand alone library - -- Dealing with package bodies is a little complicated. In such - -- cases we must retrieve the package spec since it contains the - -- spec of the body finalizer. + elsif U.SAL_Interface then + null; - if U.Utype = Is_Body then - Unum := Unum + 1; - Uspec := Units.Table (Unum); - else - Uspec := U; + -- Case of no finalization + + elsif not U.Has_Finalizer then + + -- The only case in which we have to do something is if this + -- is a body, with a separate spec, where the separate spec + -- has a finalizer. In that case, this is where we decrement + -- the elaboration entity. + + if U.Utype = Is_Body and then Uspec.Has_Finalizer then + if not Lib_Final_Built then + Gen_Header; + Lib_Final_Built := True; + end if; + + Set_String (" "); + Set_Unit_Name; + Set_String ("_E--;"); + Write_Statement_Buffer; end if; - Get_Name_String (Uspec.Uname); + else + if not Lib_Final_Built then + Gen_Header; + Lib_Final_Built := True; + end if; -- If binding a library or if there is a non-Ada main subprogram -- then we generate: @@ -1928,10 +1998,15 @@ package body Bindgen is -- uname_E--; -- uname__finalize_[spec|body] (); - Set_String (" "); - Set_Unit_Name; - Set_String ("_E--;"); - Write_Statement_Buffer; + -- The uname_E decrement is skipped if this is a separate spec, + -- since it will be done when we process the body. + + if U.Utype /= Is_Spec then + Set_String (" "); + Set_Unit_Name; + Set_String ("_E--;"); + Write_Statement_Buffer; + end if; if Interface_Library_Unit or not Bind_Main_Program then Set_String (" if ("); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 54436913fb4..3891b030d4e 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6865,6 +6865,42 @@ package body Exp_Ch7 is Desg_Typ : Entity_Id; Obj_Expr : Node_Id; + function Alignment_Of (Some_Typ : Entity_Id) return Node_Id; + -- Subsidiary routine, generate the following attribute reference: + -- + -- Some_Typ'Alignment + + function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id; + -- Subsidiary routine, generate the following expression: + -- + -- 2 * Some_Typ'Alignment + + ------------------ + -- Alignment_Of -- + ------------------ + + function Alignment_Of (Some_Typ : Entity_Id) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Some_Typ, Loc), + Attribute_Name => Name_Alignment); + end Alignment_Of; + + ------------------------- + -- Double_Alignment_Of -- + ------------------------- + + function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id is + begin + return + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 2), + Right_Opnd => Alignment_Of (Some_Typ)); + end Double_Alignment_Of; + + -- Start of processing for Make_Finalize_Address_Stmts + begin if Is_Array_Type (Typ) then if Is_Constrained (First_Subtype (Typ)) then @@ -6931,7 +6967,7 @@ package body Exp_Ch7 is -- Unconstrained arrays require special processing in order to retrieve -- the elements. To achieve this, we have to skip the dope vector which - -- lays infront of the elements and then use a thin pointer to perform + -- lays in front of the elements and then use a thin pointer to perform -- the address-to-access conversion. if Is_Array_Type (Typ) @@ -6942,30 +6978,7 @@ package body Exp_Ch7 is Dope_Id : Entity_Id; For_First : Boolean := True; Index : Node_Id; - - function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id; - -- Given the type of an array index, create the following - -- expression: - -- - -- 2 * Esize (Typ) / Storage_Unit - - ---------------------------- - -- Bounds_Size_Expression -- - ---------------------------- - - function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id is - begin - return - Make_Op_Multiply (Loc, - Left_Opnd => Make_Integer_Literal (Loc, 2), - Right_Opnd => - Make_Op_Divide (Loc, - Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit))); - end Bounds_Size_Expression; - - -- Start of processing for arrays + Index_Typ : Entity_Id; begin -- Ensure that Ptr_Typ a thin pointer, generate: @@ -6980,32 +6993,56 @@ package body Exp_Ch7 is Make_Integer_Literal (Loc, System_Address_Size))); -- For unconstrained arrays, create the expression which computes - -- the size of the dope vector. Note that in the end, all values - -- will be constant folded. + -- the size of the dope vector. Index := First_Index (Typ); while Present (Index) loop + Index_Typ := Etype (Index); - -- Generate: - -- 2 * Esize (Index_Typ) / Storage_Unit + -- Each bound has two values and a potential hole added to + -- compensate for alignment differences. if For_First then For_First := False; - Dope_Expr := Bounds_Size_Expression (Etype (Index)); - -- Generate: - -- Dope_Expr + 2 * Esize (Index_Typ) / Storage_Unit + -- Generate: + -- 2 * Index_Typ'Alignment + + Dope_Expr := Double_Alignment_Of (Index_Typ); else + -- Generate: + -- Dope_Expr + 2 * Index_Typ'Alignment + Dope_Expr := Make_Op_Add (Loc, Left_Opnd => Dope_Expr, - Right_Opnd => Bounds_Size_Expression (Etype (Index))); + Right_Opnd => Double_Alignment_Of (Index_Typ)); end if; Next_Index (Index); end loop; + -- Round the cumulative alignment to the next higher multiple of + -- the array alignment. Generate: + + -- ((Dope_Expr + Typ'Alignment - 1) / Typ'Alignment) + -- * Typ'Alignment + + Dope_Expr := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Dope_Expr, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Alignment_Of (Typ), + Right_Opnd => Make_Integer_Literal (Loc, 1))), + Right_Opnd => Alignment_Of (Typ)), + Right_Opnd => Alignment_Of (Typ)); + -- Generate: -- Dnn : Storage_Offset := Dope_Expr; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 289979f6200..c0129c332c7 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -4142,141 +4142,152 @@ package body Make is ----------------- procedure Check_Mains is - Real_Main_Project : Project_Id := No_Project; - -- The project of the first main - - Proj : Project_Id := No_Project; - -- The project of the current main - - Real_Path : String_Access; - begin - Mains.Reset; - - -- Check each main - - loop - declare - Main : constant String := Mains.Next_Main; - -- The name specified on the command line may include directory - -- information. - - File_Name : constant String := Base_Name (Main); - -- The simple file name of the current main - - Lang : Language_Ptr; - - begin - exit when Main = ""; - - -- Get the project of the current main - - Proj := Prj.Env.Project_Of - (File_Name, Main_Project, Project_Tree); - - -- Fail if the current main is not a source of a project - - if Proj = No_Project then - Make_Failed - ("""" & Main & """ is not a source of any project"); - - else - -- If there is directory information, check that the source - -- exists and, if it does, that the path is the actual path - -- of a source of a project. - - if Main /= File_Name then - Lang := Get_Language_From_Name (Main_Project, "ada"); - - Real_Path := - Locate_Regular_File - (Main & Get_Name_String - (Lang.Config.Naming_Data.Body_Suffix), - ""); - if Real_Path = null then - Real_Path := - Locate_Regular_File - (Main & Get_Name_String - (Lang.Config.Naming_Data.Spec_Suffix), - ""); - end if; - - if Real_Path = null then - Real_Path := Locate_Regular_File (Main, ""); - end if; - - -- Fail if the file cannot be found - - if Real_Path = null then - Make_Failed ("file """ & Main & """ does not exist"); - end if; - - declare - Project_Path : constant String := - Prj.Env.File_Name_Of_Library_Unit_Body - (Name => File_Name, - Project => Main_Project, - In_Tree => Project_Tree, - Main_Project_Only => False, - Full_Path => True); - Normed_Path : constant String := - Normalize_Pathname - (Real_Path.all, - Case_Sensitive => False); - Proj_Path : constant String := - Normalize_Pathname - (Project_Path, - Case_Sensitive => False); - - begin - Free (Real_Path); - - -- Fail if it is not the correct path - - if Normed_Path /= Proj_Path then - if Verbose_Mode then - Set_Standard_Error; - Write_Str (Normed_Path); - Write_Str (" /= "); - Write_Line (Proj_Path); - end if; - - Make_Failed - ("""" & Main & - """ is not a source of any project"); - end if; - end; - end if; - - if not Unique_Compile then - - -- Record the project, if it is the first main - - if Real_Main_Project = No_Project then - Real_Main_Project := Proj; - - elsif Proj /= Real_Main_Project then - - -- Fail, as the current main is not a source of the - -- same project as the first main. - - Make_Failed - ("""" & Main & - """ is not a source of project " & - Get_Name_String (Real_Main_Project.Name)); - end if; - end if; - end if; - - -- If -u and -U are not used, we may have mains that are - -- sources of a project that is not the one specified with - -- switch -P. + if Mains.Number_Of_Mains (Project_Tree) = 0 + and then not Unique_Compile + then + Mains.Fill_From_Project (Main_Project, Project_Tree); + end if; - if not Unique_Compile then - Main_Project := Real_Main_Project; - end if; - end; - end loop; + Mains.Complete_Mains + (Root_Environment.Flags, Main_Project, Project_Tree); +-- +-- +-- Real_Main_Project : Project_Id := No_Project; +-- -- The project of the first main +-- +-- Proj : Project_Id := No_Project; +-- -- The project of the current main +-- +-- Real_Path : String_Access; +-- +-- begin +-- Mains.Reset; +-- +-- -- Check each main +-- +-- loop +-- declare +-- Main : constant String := Mains.Next_Main; +-- -- The name specified on the command line may include directory +-- -- information. +-- +-- File_Name : constant String := Base_Name (Main); +-- -- The simple file name of the current main +-- +-- Lang : Language_Ptr; +-- +-- begin +-- exit when Main = ""; +-- +-- -- Get the project of the current main +-- +-- Proj := Prj.Env.Project_Of +-- (File_Name, Main_Project, Project_Tree); +-- +-- -- Fail if the current main is not a source of a project +-- +-- if Proj = No_Project then +-- Make_Failed +-- ("""" & Main & """ is not a source of any project"); +-- +-- else +-- -- If there is directory information, check that the source +-- -- exists and, if it does, that the path is the actual path +-- -- of a source of a project. +-- +-- if Main /= File_Name then +-- Lang := Get_Language_From_Name (Main_Project, "ada"); +-- +-- Real_Path := +-- Locate_Regular_File +-- (Main & Get_Name_String +-- (Lang.Config.Naming_Data.Body_Suffix), +-- ""); +-- if Real_Path = null then +-- Real_Path := +-- Locate_Regular_File +-- (Main & Get_Name_String +-- (Lang.Config.Naming_Data.Spec_Suffix), +-- ""); +-- end if; +-- +-- if Real_Path = null then +-- Real_Path := Locate_Regular_File (Main, ""); +-- end if; +-- +-- -- Fail if the file cannot be found +-- +-- if Real_Path = null then +-- Make_Failed ("file """ & Main & """ does not exist"); +-- end if; +-- +-- declare +-- Project_Path : constant String := +-- Prj.Env.File_Name_Of_Library_Unit_Body +-- (Name => File_Name, +-- Project => Main_Project, +-- In_Tree => Project_Tree, +-- Main_Project_Only => False, +-- Full_Path => True); +-- Normed_Path : constant String := +-- Normalize_Pathname +-- (Real_Path.all, +-- Case_Sensitive => False); +-- Proj_Path : constant String := +-- Normalize_Pathname +-- (Project_Path, +-- Case_Sensitive => False); +-- +-- begin +-- Free (Real_Path); +-- +-- -- Fail if it is not the correct path +-- +-- if Normed_Path /= Proj_Path then +-- if Verbose_Mode then +-- Set_Standard_Error; +-- Write_Str (Normed_Path); +-- Write_Str (" /= "); +-- Write_Line (Proj_Path); +-- end if; +-- +-- Make_Failed +-- ("""" & Main & +-- """ is not a source of any project"); +-- end if; +-- end; +-- end if; +-- +-- if not Unique_Compile then +-- +-- -- Record the project, if it is the first main +-- +-- if Real_Main_Project = No_Project then +-- Real_Main_Project := Proj; +-- +-- elsif Proj /= Real_Main_Project then +-- +-- -- Fail, as the current main is not a source of the +-- -- same project as the first main. +-- +-- Make_Failed +-- ("""" & Main & +-- """ is not a source of project " & +-- Get_Name_String (Real_Main_Project.Name)); +-- end if; +-- end if; +-- end if; +-- +-- -- If -u and -U are not used, we may have mains that are +-- -- sources of a project that is not the one specified with +-- -- switch -P. +-- +-- if not Unique_Compile then +-- Main_Project := Real_Main_Project; +-- end if; +-- end; +-- end loop; end Check_Mains; -- Start of processing for Gnatmake diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 3d14990da20..17aba047221 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -1347,7 +1347,7 @@ package body Makeutl is then -- Traverse in reverse order, since in the case of multi-unit -- files we will be adding extra files at the end, and there's - -- no need to process them in tun. + -- no need to process them in turn. for J in reverse Names.First .. Names.Last loop declare @@ -1457,7 +1457,7 @@ package body Makeutl is else if Is_Absolute then - if File_Name_Type (Source.Path.Display_Name) /= + if File_Name_Type (Source.Path.Name) /= File.File then Debug_Output diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 2288ac0a9f0..0fcf6695c7b 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2602,8 +2602,16 @@ package body Sem_Ch10 is Par_Name := Entity (Pref); end if; - Set_Entity_With_Style_Check (Pref, Par_Name); - Generate_Reference (Par_Name, Pref); + -- Guard against missing or misspelled child units. + + if Present (Par_Name) then + Set_Entity_With_Style_Check (Pref, Par_Name); + Generate_Reference (Par_Name, Pref); + + else + Set_Name (N, Make_Null (Sloc (N))); + return; + end if; end if; -- If the withed unit is System, and a system extension pragma is diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 7de09670fb6..de9f5781fc9 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3379,18 +3379,18 @@ package body Sem_Ch12 is end if; end; - -- If we are generating calling stubs, we never need a body for an - -- instantiation from source in the visible part, because in that - -- case we'll be generating stubs for any subprogram in the instance. - -- However normal processing occurs for instantiations in generated - -- code or in the private part, since in those cases we do not - -- generate stubs. - - if Distribution_Stub_Mode = Generate_Caller_Stub_Body - and then Comes_From_Source (N) - then - Needs_Body := False; - end if; + -- Note that we generate the instance body even when generating + -- calling stubs for an RCI unit: it may be required e.g. if it + -- provides stream attributes for some type used in the profile of a + -- remote subprogram. If the instantiation is within the visible part + -- of the RCI, then calling stubs for any relevant subprogram will + -- be inserted immediately after the subprogram declaration, and + -- will take precedence over the subsequent (original) body. (The + -- stub and original body will be complete homographs, but this is + -- permitted in an instance). + + -- Could we do better and remove the original subprogram body in that + -- case??? if Needs_Body then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bd7eaa22ccc..e512ff0fb36 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4342,6 +4342,21 @@ package body Sem_Res is Set_Is_Static_Coextension (N, False); end if; end if; + + -- Report a simple error: if the designated object is a local task, + -- its body has not been seen yet, and its activation will fail + -- an elaboration check. + + if Is_Task_Type (Designated_Type (Typ)) + and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope + and then Is_Compilation_Unit (Current_Scope) + and then Ekind (Current_Scope) = E_Package + and then not In_Package_Body (Current_Scope) + then + Error_Msg_N + ("cannot activate task before body seen?", N); + Error_Msg_N ("\Program_Error will be raised at run time", N); + end if; end Resolve_Allocator; --------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a3e464270df..4bfb83a3b05 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12179,6 +12179,28 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; + ---------------------------- + -- Unique_Defining_Entity -- + ---------------------------- + + function Unique_Defining_Entity (N : Node_Id) return Entity_Id is + begin + case Nkind (N) is + when N_Package_Body => + return Corresponding_Spec (N); + + when N_Subprogram_Body => + if Acts_As_Spec (N) then + return Defining_Entity (N); + else + return Corresponding_Spec (N); + end if; + + when others => + return Defining_Entity (N); + end case; + end Unique_Defining_Entity; + -------------------------- -- Unit_Declaration_Node -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bf57d97143e..a16544d9274 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1368,6 +1368,10 @@ package Sem_Util is function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ + function Unique_Defining_Entity (N : Node_Id) return Entity_Id; + -- Return the entity which represents declaration N, so that matching + -- declaration and body have the same entity. + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the -- 2.30.2