------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Fixed; use Ada, Ada.Strings.Fixed; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT, GNAT.Directory_Operations; with GNAT.Dynamic_HTables; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with GPR.Compilation; use GPR.Compilation; with GPR.Compilation.Process; use GPR.Compilation.Process; with GPR.Compilation.Slave; with GPR.Debug; with GPR.Env; with GPR.Jobserver; use GPR.Jobserver; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; with GPR.Util; use GPR.Util; package body Gprbuild.Compile is procedure Add_Compilation_Switches (Source : Source_Id); -- Add to the compilation option, the switches declared in -- Compiler'Switches(), if it is defined, otherwise in -- Compiler'Default_Switches (), if it is defined. procedure Await_Compile (Source : out Queue.Source_Info; OK : out Boolean; Slave : out Unbounded_String); -- Wait for the end of a compilation and indicate that the object directory -- is free. procedure Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref); procedure Recursive_Import (Project : Project_Id); -- Add to table Imports the projects imported by Project, recursively function Project_Extends (Extending : Project_Id; Extended : Project_Id) return Boolean; -- Returns True if Extending is Extended or is extending Extended directly -- or indirectly. function Directly_Imports (Project : Project_Id; Imported : Project_Id) return Boolean; -- Returns True if Project directly withs Imported or a project extending -- Imported. procedure Create_Config_File (For_Project : Project_Id; Config : Language_Config; Language : Name_Id); -- Create a new config file function Config_File_For (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) return Path_Information; -- Returns the name of a config file. Returns No_Name if there is no -- config file. procedure Create_Object_Path_File (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access); -- Create a temporary file that contains the list of object directories -- in the correct order. procedure Print_Compilation_Outputs (For_Source : Source_Id; Always : Boolean := False); -- In complete output mode, or when Always is True, put the outputs from -- last compilation to standard output and/or standard error. function "<" (Left, Right : Source_Id) return Boolean is (Left.File < Right.File); package Bad_Compilations_Set is new Containers.Indefinite_Ordered_Maps (Source_Id, String); Bad_Compilations : Bad_Compilations_Set.Map; -- Records bad compilation with the given slave name if any Outstanding_Compiles : Natural := 0; -- The number of compilation jobs currently spawned Slave_Initialized : Boolean := False; -- Record wether the remote compilation slaves have been initialized when -- running in distributed mode. type Process_Purpose is (Compilation, Dependency); -- A type to distinguish between compilation jobs and dependency file -- building jobs. type Process_Data is record Process : GPR.Compilation.Id := GPR.Compilation.Invalid_Process; Source : Queue.Source_Info := Queue.No_Source_Info; Source_Project : Project_Id := null; Mapping_File : Path_Name_Type := No_Path; Purpose : Process_Purpose := Compilation; Options : String_Vectors.Vector; end record; -- Data recorded for each spawned jobs, compilation of dependency file -- building. No_Process_Data : constant Process_Data := (Process => GPR.Compilation.Invalid_Process, Source => Queue.No_Source_Info, Source_Project => null, Mapping_File => No_Path, Purpose => Compilation, Options => String_Vectors.Empty_Vector); package Compilation_Htable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Compilation.Process.Header_Num, Element => Process_Data, No_Element => No_Process_Data, Key => GPR.Compilation.Id, Hash => Hash, Equal => GPR.Compilation."="); -- Hash table to keep data for all spawned jobs package Naming_Data_Vectors is new Ada.Containers.Vectors (Positive, Lang_Naming_Data); Naming_Datas : Naming_Data_Vectors.Vector; -- Naming data when creating config files package Imports is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Project_Id, Hash => Hash, Equal => "="); -- When --direct-import-only is used, contains the project ids a non Ada -- source is allowed to import source from. Included_Sources : Source_Vectors.Vector; Subunits : String_Vectors.Vector; -- A table to store the subunit names when switch --no-split-units is used ------------------------------ -- Add_Compilation_Switches -- ------------------------------ Inner_Cargs : constant String := "-inner-cargs"; -- When the --compiler-pkg-subst switch is given, this is used to pass -- switches from "package Compiler" to the ASIS tool and thence through to -- the actual compiler. procedure Add_Compilation_Switches (Source : Source_Id) is procedure Process_One_Package (Pkg_Name : Name_Id); -- Get the switches for the named package ------------------------- -- Process_One_Package -- ------------------------- procedure Process_One_Package (Pkg_Name : Name_Id) is Options : Variable_Value; Ignored : Boolean; begin Get_Switches (Source, Pkg_Name, Project_Tree, Options, Ignored); if Options /= Nil_Variable_Value then declare List : String_List_Id := Options.Values; Element : String_Element; begin while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); -- Ignore empty options if Element.Value /= Empty_String then Add_Option_Internal_Codepeer (Value => Get_Option (Element.Value), To => Compilation_Options, Display => True); end if; List := Element.Next; end loop; end; end if; end Process_One_Package; begin -- If the --compiler-pkg-subst switch was given, get switches from the -- relevant package (e.g. "package Pretty_Printer"). if Compiler_Pkg_Subst /= No_Name then Process_One_Package (Compiler_Pkg_Subst); Add_Option_Internal_Codepeer (Value => Inner_Cargs, To => Compilation_Options, Display => True); end if; -- Always get switches from "package Compiler". If the -- --compiler-pkg-subst switch was given, these are preceded by -- -inner-cargs (see above) to indicate that the ASIS tool should pass -- them along to gcc. Process_One_Package (Name_Compiler); end Add_Compilation_Switches; ------------------- -- Await_Compile -- ------------------- procedure Await_Compile (Source : out Queue.Source_Info; OK : out Boolean; Slave : out Unbounded_String) is Process : GPR.Compilation.Id; Comp_Data : Process_Data; Language : Language_Ptr; Config : Language_Config; begin loop Source := Queue.No_Source_Info; Wait_Result (Process, OK); if Process = GPR.Compilation.Invalid_Process then return; end if; Comp_Data := Compilation_Htable.Get (Process); if Comp_Data /= No_Process_Data then Source := Comp_Data.Source; Queue.Set_Obj_Dir_Free (Source.Id.Project.Object_Directory.Name); if Comp_Data.Purpose = Compilation then Print_Compilation_Outputs (Source.Id, Always => not No_Complete_Output); if OK then -- We created a new dependency file, so reset the attributes -- of the old one. Source.Id.Dep_TS := Unknown_Attributes; if not Comp_Data.Options.Is_Empty and then Source.Id.Switches_Path /= No_Path and then Opt.Check_Switches then -- First, update the time stamp of the object file that -- will be written in the switches file. Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path); GPR.Util.Update_File_Stamp (Source.Id.Object_Path, Source.Id.Object_TS); -- Write the switches file, now that we have the updated -- time stamp for the object file. declare File : Text_IO.File_Type; begin Create (File, Out_File, Get_Name_String (Source.Id.Switches_Path)); Put_Line (File, String (Source.Id.Object_TS)); for Arg of Comp_Data.Options loop Put_Line (File, Arg); end loop; Close (File); exception when others => Fail_Program (Source.Tree, "could not create switches file """ & Get_Name_String (Source.Id.Switches_Path) & '"'); end; -- For all languages other than Ada, update the time -- stamp of the object file as it is written in the -- global archive dependency file. For all languages, -- update the time stamp of the object file if it is in -- a library project. elsif Source.Id.Language.Config.Dependency_Kind not in ALI_Dependency or else Source.Id.Project.Library then Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path); GPR.Util.Update_File_Stamp (Source.Id.Object_Path, Source.Id.Object_TS); end if; else Set_Failed_Compilation_Status (Comp_Data.Source_Project); Slave := To_Unbounded_String (Get_Slave_For (Process)); end if; Language := Source.Id.Language; -- If there is a mapping file used, recycle it in the hash -- table of the language. if Comp_Data.Mapping_File /= No_Path and then Language /= No_Language_Index then Mapping_Files_Htable.Set (T => Language.Mapping_Files, K => Comp_Data.Mapping_File, E => Comp_Data.Mapping_File); end if; Config := Language.Config; if OK and then Config.Dependency_Kind = Makefile and then Config.Compute_Dependency /= No_Name_List then declare Current_Dir : constant Dir_Name_Str := Get_Current_Dir; List : Name_List_Index := Config.Compute_Dependency; Nam : Name_Node := Source.Tree.Shared.Name_Lists.Table (List); Exec_Name : constant String := Get_Name_String (Nam.Name); Exec_Path : OS_Lib.String_Access; begin Change_Dir (Get_Name_String (Source.Id.Project.Object_Directory.Display_Name)); Comp_Data.Mapping_File := No_Path; Comp_Data.Purpose := Dependency; -- ??? We search for it on the PATH for every file, -- this is very inefficient Exec_Path := Locate_Exec_On_Path (Exec_Name); if Exec_Path = null then Fail_Program (Source.Tree, "unable to find dependency builder " & Exec_Name); end if; List := Nam.Next; Compilation_Options.Clear; if List = No_Name_List then Name_Len := 0; else loop Nam := Source.Tree.Shared.Name_Lists.Table (List); List := Nam.Next; if List = No_Name_List then Get_Name_String (Nam.Name); exit; end if; Add_Option (Nam.Name, Compilation_Options, Opt.Verbose_Mode); end loop; end if; Get_Name_String_And_Append (Source.Id.Path.Display_Name); Add_Option (Name_Buffer (1 .. Name_Len), Compilation_Options, Opt.Verbose_Mode, Simple_Name => not Opt.Verbose_Mode); if not Opt.Quiet_Output then if Opt.Verbose_Mode then Put (Exec_Path.all); else Put (Exec_Name); end if; Put (" "); for Option of Compilation_Options loop if Option.Displayed then Put (Option.Name); Put (" "); end if; end loop; New_Line; end if; Comp_Data.Process := Run (Executable => Exec_Path.all, Options => Options_List (Compilation_Options), Project => Comp_Data.Source_Project, Obj_Name => Get_Name_String (Source.Id.Object), Output_File => Get_Name_String (Source.Id.Dep_Path), Err_To_Out => True, Force_Local => True); Compilation_Htable.Set (Comp_Data.Process, Comp_Data); Free (Exec_Path); Change_Dir (Current_Dir); end; else Outstanding_Compiles := Outstanding_Compiles - 1; if Opt.Use_GNU_Make_Jobserver then Jobserver.Unregister_Token_Id (Id => Process); end if; return; end if; elsif Comp_Data.Purpose = Dependency then Outstanding_Compiles := Outstanding_Compiles - 1; if Opt.Use_GNU_Make_Jobserver then Jobserver.Unregister_Token_Id (Id => Process); end if; return; end if; end if; end loop; end Await_Compile; --------------------- -- Config_File_For -- --------------------- function Config_File_For (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) return Path_Information is function Normalize_Path (Path : Path_Name_Type; Project : Project_Id) return String is (GNAT.OS_Lib.Normalize_Pathname (Name => Get_Name_String (Path), Directory => Get_Name_String (Project.Directory.Display_Name))); -- Returns an normalized path for a config file Config_Package : constant Package_Id := Value_Of (Name => Package_Name, In_Packages => Project.Decl.Packages, Shared => Project_Tree.Shared); Config_Variable : Variable_Value := Value_Of (Name => Language, Attribute_Or_Array_Name => Attribute_Name, In_Package => Config_Package, Shared => Project_Tree.Shared); begin -- Get the config pragma attribute when the language is Ada and the -- config file attribute is not declared. if Config_Variable = Nil_Variable_Value and then Config_Package /= No_Package and then Language = Name_Ada then Config_Variable := Value_Of (Variable_Name => (if Attribute_Name = Name_Global_Config_File then Name_Global_Configuration_Pragmas elsif Attribute_Name = Name_Local_Config_File then Name_Local_Configuration_Pragmas else raise Program_Error with "Unexpected " & Get_Name_String (Attribute_Name)), In_Variables => Project_Tree.Shared.Packages.Table (Config_Package).Decl.Attributes, Shared => Project_Tree.Shared); end if; if Config_Variable = Nil_Variable_Value or else Config_Variable.Value = Snames.The_Empty_String then return No_Path_Information; else declare Path : String := Normalize_Path (Path_Name_Type (Config_Variable.Value), Config_Variable.Project); Result : Path_Information; begin Result.Display_Name := Get_Path_Name_Id (Path); Canonical_Case_File_Name (Path); Result.Name := Get_Path_Name_Id (Path); return Result; end; end if; end Config_File_For; ------------------------ -- Create_Config_File -- ------------------------ procedure Create_Config_File (For_Project : Project_Id; Config : Language_Config; Language : Name_Id) is File_Name : Path_Name_Type := No_Path; File : File_Descriptor := Invalid_FD; Source : Source_Id; Iter : Source_Iterator; procedure Check (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Check the naming schemes of the different projects of the project -- tree. For each different naming scheme issue the pattern config -- declarations. procedure Check_Temp_File; -- Check if a temp file has been created. If not, create one procedure Copy_Config_File (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id); -- If a specified config file exists, copy it in the temporary config -- file. procedure Put_Line (File : File_Descriptor; S : String); -- Output procedure, analogous to normal Text_IO proc of same name ----------- -- Check -- ----------- procedure Check (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Dummy, Tree); Lang_Id : Language_Ptr := Project.Languages; Current_Naming : Natural := 0; procedure Replace; ------------- -- Replace -- ------------- procedure Replace is Cur : Positive := 1; procedure Substitute (N : File_Name_Type); procedure Substitute (Name : String); ---------------- -- Substitute -- ---------------- procedure Substitute (N : File_Name_Type) is begin if N = No_File then Cur := Cur + 1; else Substitute (Get_Name_String (N)); end if; end Substitute; procedure Substitute (Name : String) is begin Name_Buffer (Cur + Name'Length .. Name_Len - 2 + Name'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Name'Length - 1) := Name; Name_Len := Name_Len - 2 + Name'Length; Cur := Cur + Name'Length; end Substitute; begin while Cur < Name_Len loop if Name_Buffer (Cur) = '%' then case Name_Buffer (Cur + 1) is when 'b' => Substitute (Lang_Id.Config.Naming_Data.Body_Suffix); when 's' => Substitute (Lang_Id.Config.Naming_Data.Spec_Suffix); when 'd' => Substitute (Lang_Id.Config.Naming_Data.Dot_Replacement); when 'c' => Substitute (Image (Lang_Id.Config.Naming_Data.Casing)); when '%' => Name_Buffer (Cur .. Name_Len - 1) := Name_Buffer (Cur + 1 .. Name_Len); Name_Len := Name_Len - 1; Cur := Cur + 1; when others => Cur := Cur + 1; end case; else Cur := Cur + 1; end if; end loop; end Replace; begin if Current_Verbosity = High then Put ("Checking project file """); Put (Get_Name_String (Project.Name)); Put ("""."); New_Line; end if; while Lang_Id /= No_Language_Index loop exit when Lang_Id.Name = Language; Lang_Id := Lang_Id.Next; end loop; if Lang_Id /= No_Language_Index then Current_Naming := Natural (Naming_Datas.Find_Index (Lang_Id.Config.Naming_Data)); if Current_Naming = 0 then Naming_Datas.Append (Lang_Id.Config.Naming_Data); Check_Temp_File; if Lang_Id.Config.Config_Spec_Pattern /= No_Name then Get_Name_String (Lang_Id.Config.Config_Spec_Pattern); Replace; Put_Line (File, Name_Buffer (1 .. Name_Len)); end if; if Lang_Id.Config.Config_Body_Pattern /= No_Name then Get_Name_String (Lang_Id.Config.Config_Body_Pattern); Replace; Put_Line (File, Name_Buffer (1 .. Name_Len)); end if; end if; end if; end Check; --------------------- -- Check_Temp_File -- --------------------- procedure Check_Temp_File is begin if File = Invalid_FD then Tempdir.Create_Temp_File (File, Name => File_Name); if File = Invalid_FD then Fail_Program (Project_Tree, "unable to create temporary configuration pragmas file"); else Record_Temp_File (Project_Tree.Shared, File_Name); if Opt.Verbosity_Level > Opt.Low then Put ("Creating temp file """); Put (Get_Name_String (File_Name)); Put_Line (""""); end if; end if; end if; end Check_Temp_File; ---------------------- -- Copy_Config_File -- ---------------------- procedure Copy_Config_File (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) is Config_File_Path : constant Path_Name_Type := Config_File_For (Project, Package_Name, Attribute_Name, Language).Display_Name; Config_File : Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; begin if Config_File_Path /= No_Path then begin Open (Config_File, In_File, Get_Name_String (Config_File_Path)); exception when others => Fail_Program (Project_Tree, "unable to open config file " & Get_Name_String (Config_File_Path)); end; Check_Temp_File; while not End_Of_File (Config_File) loop Get_Line (Config_File, Line, Last); Put_Line (File, Line (1 .. Last)); end loop; Close (Config_File); end if; end Copy_Config_File; -------------- -- Put_Line -- -------------- procedure Put_Line (File : File_Descriptor; S : String) is S0 : String (1 .. S'Length + 1); Last : Natural; begin -- Add an ASCII.LF to the string. As this config file is supposed to -- be used only by the compiler, we don't care about the characters -- for the end of line. In fact we could have put a space, but -- it is more convenient to be able to read gnat.adc during -- development, for which the ASCII.LF is fine. S0 (1 .. S'Length) := S; S0 (S0'Last) := ASCII.LF; Last := Write (File, S0'Address, S0'Length); if Last /= S'Length + 1 then Fail_Program (Project_Tree, "Disk full"); end if; if Current_Verbosity = High then Put_Line (S); end if; end Put_Line; procedure Check_All_Projects is new For_Every_Project_Imported (Boolean, Check); Dummy : Boolean := False; -- Start of processing for Create_Config_File begin -- Nothing to do if config has already been checked if For_Project.Config_Checked then return; end if; if Config.Config_File_Unique then -- Copy an eventual global config file Copy_Config_File (Main_Project, Name_Builder, Name_Global_Config_File, Language); -- Copy an eventual local config file Copy_Config_File (For_Project, Name_Compiler, Name_Local_Config_File, Language); end if; For_Project.Config_Checked := True; Naming_Datas.Clear; Check_All_Projects (For_Project, Project_Tree, Dummy); -- Visit all the units and issue the config declarations for those that -- need one. Iter := For_Each_Source (Project_Tree); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Language.Name = Language and then Source.Naming_Exception /= No and then Source.Unit /= No_Unit_Index and then not Source.Locally_Removed and then Source.Replaced_By = No_Source then Name_Len := 0; if Source.Kind = Spec then if Source.Index = 0 and then Config.Config_Spec /= No_Name then Get_Name_String (Config.Config_Spec); elsif Source.Index /= 0 and then Config.Config_Spec_Index /= No_Name then Get_Name_String (Config.Config_Spec_Index); end if; else if Source.Index = 0 and then Config.Config_Body /= No_Name then Get_Name_String (Config.Config_Body); elsif Source.Index /= 0 and then Config.Config_Body_Index /= No_Name then Get_Name_String (Config.Config_Body_Index); end if; end if; if Name_Len /= 0 then declare Cur : Positive := 1; Unit : constant String := Get_Name_String (Source.Unit.Name); File_Name : constant String := Get_Name_String (Source.Display_File); begin while Cur < Name_Len loop if Name_Buffer (Cur) /= '%' then Cur := Cur + 1; else case Name_Buffer (Cur + 1) is when 'u' => Name_Buffer (Cur + Unit'Length .. Name_Len - 2 + Unit'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Unit'Length - 1) := Unit; Cur := Cur + Unit'Length; Name_Len := Name_Len - 2 + Unit'Length; when 'f' => Name_Buffer (Cur + File_Name'Length .. Name_Len - 2 + File_Name'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + File_Name'Length - 1) := File_Name; Cur := Cur + File_Name'Length; Name_Len := Name_Len - 2 + File_Name'Length; when 'i' => declare Index_String : constant String := Source.Index'Img; begin Name_Buffer (Cur + Index_String'Length .. Name_Len - 2 + Index_String'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Index_String'Length - 1) := Index_String; Cur := Cur + Index_String'Length; Name_Len := Name_Len - 2 + Index_String'Length; end; when '%' => Name_Buffer (Cur .. Name_Len - 1) := Name_Buffer (Cur + 1 .. Name_Len); Cur := Cur + 1; Name_Len := Name_Len - 1; when others => Cur := Cur + 1; end case; end if; end loop; Put_Line (File, Name_Buffer (1 .. Name_Len)); end; end if; end if; Next (Iter); end loop; if File /= Invalid_FD then Close (File); For_Project.Config_File_Name := File_Name; end if; end Create_Config_File; ----------------------------- -- Create_Object_Path_File -- ----------------------------- procedure Create_Object_Path_File (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access) is FD : File_Descriptor; Name : Path_Name_Type; LF : constant String := (1 => ASCII.LF); procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Add the object directory of a project to the file --------- -- Add -- --------- procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (In_Tree); Path : constant Path_Name_Type := Get_Object_Directory (Project, Including_Libraries => True, Only_If_Ada => False); Last : Natural; pragma Unreferenced (Last); begin if Path /= No_Path then Get_Name_String (Path); Last := Write (FD, Name_Buffer (1)'Address, Name_Len); Last := Write (FD, LF (1)'Address, 1); end if; Dummy := True; end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); Status : Boolean := False; pragma Warnings (Off, Status); begin GPR.Env.Create_Temp_File (Shared, FD, Name, "object path file"); Project.Object_Path_File := Name; For_All_Projects (Project, Project_Tree, Status, Include_Aggregated => True); Close (FD, Status); end Create_Object_Path_File; ---------------------- -- Recursive_Import -- ---------------------- procedure Recursive_Import (Project : Project_Id) is Ext : constant Project_Id := Project.Extends; L : Project_List := Project.Imported_Projects; begin if Ext /= No_Project and then not Imports.Get (Ext) then Imports.Set (Ext, True); Recursive_Import (Ext); end if; while L /= null loop if not Imports.Get (L.Project) then Imports.Set (L.Project, True); Recursive_Import (L.Project); end if; L := L.Next; end loop; end Recursive_Import; ---------------------- -- Directly_Imports -- ---------------------- function Directly_Imports (Project : Project_Id; Imported : Project_Id) return Boolean is L : Project_List := Project.Imported_Projects; P : Project_Id; begin while L /= null loop P := L.Project; while P /= No_Project loop if Imported = P then return True; end if; P := P.Extends; end loop; L := L.Next; end loop; return False; end Directly_Imports; ------------------------------- -- Print_Compilation_Outputs -- ------------------------------- procedure Print_Compilation_Outputs (For_Source : Source_Id; Always : Boolean := False) is procedure Display_Content (Stream : File_Type; File_Path : String); -- Display content of the given Filename --------------------- -- Display_Content -- --------------------- procedure Display_Content (Stream : File_Type; File_Path : String) is File : Ada.Text_IO.File_Type; Line : String (1 .. 1_024); Last : Natural; Print_New_Line : Boolean := False; begin if OS_Lib.Is_Regular_File (File_Path) then Open (File, In_File, File_Path); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last = Line'Last then Put (Stream, Line (1 .. Last)); Print_New_Line := True; else Put_Line (Stream, Line (1 .. Last)); end if; end loop; if Print_New_Line then Put_Line (Stream, ""); end if; Close (File); end if; end Display_Content; begin if Complete_Output or else Always then declare Proj : constant Project_Id := Ultimate_Extending_Project_Of (For_Source.Project); File_Path : constant String := Get_Name_String (Proj.Object_Directory.Name) & Directory_Separator & Get_Name_String (For_Source.File); begin Display_Content (Standard_Output, File_Path & ".stdout"); Display_Content (Standard_Error, File_Path & ".stderr"); end; end if; end Print_Compilation_Outputs; --------- -- Run -- --------- procedure Run is procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref); ---------------- -- Do_Compile -- ---------------- procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref) is begin if Builder_Data (Tree).Need_Compilation then Compilation_Phase (Project, Tree); if Total_Errors_Detected > 0 or else not Bad_Compilations.Is_Empty then -- If switch -k or -jnn (with nn > 1), output a summary of the -- sources that could not be compiled. if (Opt.Keep_Going or else Get_Maximum_Processes > 1) and then not Bad_Compilations.Is_Empty and then not Opt.No_Exit_Message then New_Line; for Index in Bad_Compilations.Iterate loop declare Source : constant Source_Id := Bad_Compilations_Set.Key (Index); Slave : constant String := Bad_Compilations_Set.Element (Index); begin if Source /= No_Source then Put (" compilation of "); Put (Get_Name_String (Source.Display_File)); Put (" failed"); if Slave /= "" then Put (" on " & Slave); end if; New_Line; end if; end; end loop; New_Line; end if; if Exit_Code = Osint.E_Success then Exit_Code := (if Bad_Compilations.Is_Empty then E_Fatal else E_Subtool); end if; if Opt.Keep_Going and then Project.Qualifier = Aggregate then Bad_Compilations.Clear; else if Distributed_Mode and then Slave_Initialized then GPR.Compilation.Slave.Unregister_Remote_Slaves; end if; Compilation_Phase_Failed (Tree, Exit_Code, No_Message => Opt.No_Exit_Message); end if; end if; end if; end Do_Compile; procedure Compile_All is new For_Project_And_Aggregated (Do_Compile); begin Compile_All (Main_Project, Project_Tree); -- Unregister the slaves and get back compiled object code. This is a -- nop if no compilation has been done. GPR.Compilation.Slave.Unregister_Remote_Slaves; end Run; ----------------------- -- Compilation_Phase -- ----------------------- procedure Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref) is type Local_Project_Data is record Include_Language : Language_Ptr := No_Language_Index; -- Prepared arguments for "include" parameters (-I or include file). -- These are specific to each language and project. Include_Path_File : Path_Name_Type; -- The path name of the source search directory file Imported_Dirs_Switches : Argument_List_Access; -- List of the source search switches (-I) to be used -- when compiling. Include_Path : OS_Lib.String_Access := null; -- The search source path for the project. Used as the value for an -- environment variable, specified by attribute Include_Path -- (). The names of the environment variables are in component -- Include_Path of the records Language_Config. Include_Switches_Spec_File : Path_Name_Type; end record; -- project-specific data required for this procedure. These are not -- stored in the Project_Data record so that projects kept in memory do -- not have to allocate space for these temporary data No_Local_Project_Data : constant Local_Project_Data := (Include_Language => No_Language_Index, Include_Path => null, Imported_Dirs_Switches => null, Include_Path_File => No_Path, Include_Switches_Spec_File => No_Path); package Local_Projects_HT is new Dynamic_HTables.Simple_HTable (Header_Num => GPR.Header_Num, Element => Local_Project_Data, No_Element => No_Local_Project_Data, Key => Project_Id, Hash => GPR.Hash, Equal => "="); Local_Projects : Local_Projects_HT.Instance; Keep_Dep_File : Boolean := False; -- We need to keep dependency file in some error cases for diagnostic The_Config_Paths : Config_Paths (1 .. 2 + Natural (Cmd_Line_Adc_Files.Length)); -- Paths of eventual global and local configuration pragmas files -- and files from -gnatec= command line parameters. Last_Config_Path : Natural := 0; procedure Add_Config_File_Switch (Config : Language_Config; Path_Name : Path_Name_Type); procedure Record_ALI_For (Source_Identity : Queue.Source_Info; The_ALI : ALI.ALI_Id := ALI.No_ALI_Id); -- Record the Id of an ALI file in Good_ALI table. -- The_ALI can contain the pre-parsed ali file, to save time. -- Tree is the tree to which Source_Identity belongs function Phase_2_Makefile (Src_Data : Queue.Source_Info) return Boolean; function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean; -- Process Wait_For_Available_Slot depending on Src_Data.Dependency type -- This returns whether the compilation is considered as successful or -- not. procedure Set_Options_For_File (Id : Source_Id); -- Prepare the compiler options to use when building Id procedure Process_Project_Phase_1 (Source : Queue.Source_Info); -- If some compilation is needed for this project, perform it function Must_Exit_Because_Of_Error return Boolean; -- Return True if there were errors and the user decided to exit in such -- a case. This waits for any outstanding compilation. function Check_Switches_File (Id : Source_Id) return Boolean; -- Check in its switches file where Id was compiled with the same -- switches procedure Update_Object_Path (Id : Source_Id; Source_Project : Project_Id); -- Update, if necessary, the path of the object file, of the dependency -- file and of the switches file, in the case of the compilation of a -- source in an extended project, when the source is in a project being -- extended. procedure Add_Dependency_Options (Id : Source_Id); -- Add switches to the compilation command line to create the -- dependency file procedure Add_Object_File_Switches (Id : Source_Id); -- If there are switches to specify the name of the object file, add -- them. procedure Add_Object_Path_Switches (Id : Source_Id); -- If attribute Compiler'Object_Path_Switches has been specified, create -- the temporary object path file, if not already done, and add the -- switch(es) to the invocation of the compiler. procedure Get_Config_Paths (Id : Source_Id; Source_Project : Project_Id); -- Find the config files for the source and put their paths in -- The_Config_Paths. procedure Add_Config_File_Switches (Id : Source_Id; Source_Project : Project_Id); -- If Config_File_Switches is specified, check if a config file need to -- be specified. Return the path to the config file procedure Add_Trailing_Switches (Id : Source_Id); -- Add the trailing required switches, if any, so that they will be put -- in the switches file. procedure Add_Name_Of_Source_Switches (Id : Source_Id); -- Add the name of the source to be compiled function Add_Mapping_File_Switches (Source : Queue.Source_Info; Source_Project : Project_Id) return Path_Name_Type; -- If the compiler supports mapping files, add the necessary switch. -- Returns the name of the mapping file to use (or No_File) procedure Add_Multi_Unit_Switches (Id : Source_Id); -- Add, if needed, the required switches to compile a multi-unit source -- file. procedure Spawn_Compiler_And_Register (Source : Queue.Source_Info; Source_Project : Project_Id; Compiler_Path : String; Mapping_File_Path : Path_Name_Type; Last_Switches_For_File : Integer); -- Spawn the compiler with the arguments currently set in -- Compiler_Options. It registers the process we just spawned, so that -- we start monitoring it. -- This also displays on the output the command we are spawning. -- Last_Switches_For_File is the index in Compilation_Options of the -- last switch that should be written to the switches file. All -- following switches are not output in that file. function Get_Compatible_Languages (Lang : Language_Ptr) return Name_Ids; -- Return the list of languages that Id could potentially include (for -- instance "C" if Id is a "C++" file. This also includes Id's own -- language. procedure Prepare_Imported_Dirs_Switches (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr); -- Add the switches for include directories to the command line (these -- are the "-I" switches in the case of C for instance). procedure Prepare_Include_Path_File (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr); -- Create a file to pass the include directories to the compiler procedure Start_Compile_If_Possible; -- Checks if there is more work that we can do (ie the Queue is non -- empty). If there is, do it only if we have not yet used up all the -- available processes. procedure Wait_For_Available_Slot; -- Check if we should wait for a compilation to finish. This is the case -- if all the available processes are busy compiling sources or there is -- nothing else to do (that is the Q is empty and there are outstanding -- compilations). procedure Set_Env_For_Include_Dirs (Id : Source_Id; Source_Project : Project_Id); -- Set environment variables or switches to pass the include directories -- to the compiler procedure Check_Interface_And_Indirect_Imports (The_ALI : ALI.ALI_Id; Src_Data : Queue.Source_Info; Success : in out Boolean); -- From the given ALI data and the associated source Src_Data, checks -- the withed units for the following error cases: -- - The unit is not in the interface of the source's project -- - The unit is from an indirect import and the --no-indirect-import -- flag is set. -- Success is set to False if those occur. ------------------------------------------ -- Check_Interface_And_Indirect_Imports -- ------------------------------------------ procedure Check_Interface_And_Indirect_Imports (The_ALI : ALI.ALI_Id; Src_Data : Queue.Source_Info; Success : in out Boolean) is Sfile : File_Name_Type; Afile : File_Name_Type; Source_2 : Source_Id; begin for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop if not ALI.Withs.Table (K).Implicit_With_From_Instantiation then Sfile := ALI.Withs.Table (K).Sfile; -- Skip generics if Sfile /= No_File then -- Look for this source Afile := ALI.Withs.Table (K).Afile; Source_2 := Source_Files_Htable.Get (Src_Data.Tree.Source_Files_HT, Sfile); while Source_2 /= No_Source loop if Is_Compilable (Source_2) and then Source_2.Dep_Name = Afile then case Source_2.Kind is when Spec => null; when Impl => if Is_Subunit (Source_2) then Source_2 := No_Source; end if; when Sep => Source_2 := No_Source; end case; exit; end if; Source_2 := Source_2.Next_With_File_Name; end loop; -- If it is the source of a project that is not the -- project of the source just compiled, check if it -- is allowed to be imported. if Source_2 /= No_Source then if not Project_Extends (Src_Data.Id.Project, Source_2.Project) and then not Project_Extends (Source_2.Project, Src_Data.Id.Project) then if not Indirect_Imports and then not Directly_Imports (Src_Data.Id.Project, Source_2.Project) then -- It is in a project that is not directly -- imported. Report an error and -- invalidate the compilation. Put ("Unit """); Put (Get_Name_String (Src_Data.Id.Unit.Name)); Put (""" cannot import unit """); Put (Get_Name_String (Source_2.Unit.Name)); Put_Line (""":"); Put (" """); Put (Get_Name_String (Src_Data.Id.Project.Display_Name)); Put (""" does not directly import project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Exit_Code := E_General; Success := False; elsif not Source_2.In_Interfaces then -- It is not an interface of its project. -- Report an error and invalidate the -- compilation. Put ("Unit """); Put (Get_Name_String (Src_Data.Id.Unit.Name)); Put (""" cannot import unit """); Put (Get_Name_String (Source_2.Unit.Name)); Put_Line (""":"); Put (" it is not part of the " & "interfaces of its project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Success := False; end if; end if; end if; end if; end if; end loop; end loop; end Check_Interface_And_Indirect_Imports; ---------------------------- -- Add_Config_File_Switch -- ---------------------------- procedure Add_Config_File_Switch (Config : Language_Config; Path_Name : Path_Name_Type) is List : Name_List_Index := Config.Config_File_Switches; Nam : Name_Node; begin while List /= No_Name_List loop Nam := Project_Tree.Shared.Name_Lists.Table (List); Get_Name_String (Nam.Name); if Nam.Next = No_Name_List then Get_Name_String_And_Append (Path_Name); end if; Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode); List := Nam.Next; end loop; end Add_Config_File_Switch; -------------------- -- Record_ALI_For -- -------------------- procedure Record_ALI_For (Source_Identity : Queue.Source_Info; The_ALI : ALI.ALI_Id := ALI.No_ALI_Id) is Local_ALI : ALI.ALI_Id := The_ALI; Text : Text_Buffer_Ptr; begin if The_ALI = ALI.No_ALI_Id then Text := Read_Library_Info_From_Full (File_Name_Type (Source_Identity.Id.Dep_Path), Source_Identity.Id.Dep_TS'Access); if Text /= null then -- Read the ALI file but read only the necessary lines Local_ALI := ALI.Scan_ALI (File_Name_Type (Source_Identity.Id.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "W"); Free (Text); end if; end if; if Local_ALI /= ALI.No_ALI_Id then Queue.Insert_Withed_Sources_For (Local_ALI, Source_Identity.Tree); ALI.Initialize_ALI; -- ALI.Util.Initialize_ALI_Source; end if; end Record_ALI_For; ---------------------- -- Phase_2_Makefile -- ---------------------- function Phase_2_Makefile (Src_Data : Queue.Source_Info) return Boolean is Object_Path : GNAT.OS_Lib.String_Access; Dep_File : Text_File; Start : Natural; Finish : Natural; Last_Obj : Natural; Was : Boolean := False; type Src_Record (F_Len : Natural) is record File : String (1 .. F_Len); TS : Time_Stamp_Type; end record; package Src_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Src_Record); Srcs : Src_Vectors.Vector; Compilation_OK : Boolean := True; Dep_File_OK : Boolean := False; Dep_Path : constant String := Get_Name_String (Src_Data.Id.Dep_Path); begin Open (Dep_File, Dep_Path); if Is_Valid (Dep_File) then Big_Loop : loop Skip_Loop : while not End_Of_File (Dep_File) loop Get_Line (Dep_File, Name_Buffer, Name_Len); if Name_Len > 0 and then Name_Buffer (1) /= '#' then -- Skip a first line that is an empty continuation line for J in 1 .. Name_Len - 1 loop exit Skip_Loop when Name_Buffer (J) /= ' '; end loop; exit Skip_Loop when Name_Buffer (Name_Len) /= '\'; end if; end loop Skip_Loop; Start := 1; Finish := Index (Name_Buffer (1 .. Name_Len), ": "); exit Big_Loop when Finish = 0; Last_Obj := Finish; loop Last_Obj := Last_Obj - 1; exit when Last_Obj = Start or else Name_Buffer (Last_Obj) /= ' '; end loop; while Start < Last_Obj and then Name_Buffer (Start) = ' ' loop Start := Start + 1; end loop; Object_Path := new String'(Name_Buffer (Start .. Last_Obj)); Dep_File_OK := True; Start := Finish + 2; -- Process each line Line_Loop : loop declare Line : constant String := Name_Buffer (1 .. Name_Len); Last : constant Natural := Name_Len; begin Name_Loop : loop -- Find the beginning of the next source path -- name. while Start < Last and then Line (Start) = ' ' loop Start := Start + 1; end loop; -- Go to next line when there is a -- continuation character \ at the end of the -- line. exit Name_Loop when Start = Last and then Line (Start) = '\'; -- We should not be at the end of the line, -- without a continuation character \. exit Line_Loop when Start = Last; -- Look for the end of the source path name Finish := Start; while Finish < Last loop if Line (Finish) = '\' then -- On Windows, a '\' is part of the path name, -- except when it is not the first character -- followed by another '\' or by a space. -- On other platforms, when we are getting a '\' -- that is not the last character of the line, -- the next character is part of the path name, -- even if it is a space. if On_Windows and then Finish = Start and then Line (Finish + 1) = '\' then Finish := Finish + 2; if Finish > Last then Put ("file """); Put (Dep_Path); Put_Line (""" has wrong format"); Keep_Dep_File := True; Compilation_OK := False; exit Big_Loop; end if; else Finish := Finish + 1; end if; else -- A space that is not preceded by '\' -- indicates the end of the path name. exit when Line (Finish + 1) = ' '; Finish := Finish + 1; end if; end loop; -- Check this source declare Src_Name : constant String := Line (Start .. Finish); -- This is a filename encoded by GCC for use as a -- Makefile dependency, with some characters -- escaped for this specific purpose. We are about -- to reuse it in a rewritten dependency file. -- We used to Normalize the path name at this -- point, and this turned out both wrong and -- unnecessary. -- It would be an error to apply Normalize_Pathname -- on it because normalised it can be different -- filename. For example on windows -- c:\path\filename.c escaped became -- c\:path\\filename.c. Normalize_Pathname would -- not understand that it is drive letter at first -- characters and prepend it with current -- directory. We do not need filename to be -- normalised in the GPR rewritten dependency file -- because it is going to be normalised relatively -- to the object directory at reading in -- GPR.Util.Need_To_Compile.Process_Makefile_Deps. Unescaped : constant String := OS_Lib.Normalize_Pathname (Unescape (Src_Name), Directory => Dir_Name (Dep_Path), Case_Sensitive => False); Source_2 : Source_Id; Src_TS : Time_Stamp_Type; begin Source_2 := Source_Paths_Htable.Get (Src_Data.Tree.Source_Paths_HT, Get_Path_Name_Id (Unescaped)); Src_TS := File_Stamp (Unescaped); if Src_TS = Empty_Time_Stamp then -- File from dependency list does not exist Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put_Line (""""); Put (ASCII.HT & "depends on non-existent """); Put (Unescaped); Put_Line (""""); Put (ASCII.HT & "noted in the """); Put (Dep_Path); Put_Line (""""); Keep_Dep_File := True; Compilation_OK := False; end if; if Source_2 /= No_Source then -- It is a source of a project if not Project_Extends (Src_Data.Id.Project, Source_2.Project) and then not Project_Extends (Source_2.Project, Src_Data.Id.Project) then -- It is not a source of the same project -- as the source just compiled. Check if -- it can be imported. if not Indirect_Imports then if Directly_Imports (Src_Data.Id.Project, Source_2.Project) then -- It is a source of a directly -- imported project. Record its -- project, for later processing. Imports.Set (Source_2.Project, True); else -- It is a source of a project that -- is not directly imported. Record -- the source for later processing. Included_Sources.Append (Source_2); end if; end if; if not Source_2.In_Interfaces and then not Source_2.Locally_Removed then -- It is not a source in the interfaces -- of its project. Report an error and -- invalidate the compilation. Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put (""" cannot import """); Put (Unescaped); Put_Line (""":"); Put (" it is not part of the " & "interfaces of its project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Compilation_OK := False; end if; end if; end if; Srcs.Append (Src_Record' (F_Len => Src_Name'Length, File => Src_Name, TS => Src_TS)); end; exit Line_Loop when Finish = Last; -- Go get the next source on the line Start := Finish + 1; end loop Name_Loop; end; -- If we are here, we had a continuation character -- \ at the end of the line, so we continue with -- the next line. Get_Line (Dep_File, Name_Buffer, Name_Len); Start := 1; Finish := 1; end loop Line_Loop; end loop Big_Loop; Close (Dep_File); if not Included_Sources.Is_Empty then -- Sources in project that are not directly imported -- have been found. Check if they may be imported by -- other allowed imported sources. declare L : Project_List := Src_Data.Id.Project.Imported_Projects; begin -- Put in hash table Imports the project trees -- rooted at the projects that are already in -- Imports. while L /= null loop if Imports.Get (L.Project) then Recursive_Import (L.Project); end if; L := L.Next; end loop; -- For all the imported sources from project not -- directly imported, check if their projects are -- in table imports. for Included of Included_Sources loop if not Imports.Get (Included.Project) then -- This source is either directly imported or -- imported from another source that should not be -- imported. Report an error and invalidate the -- compilation. Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put (""" cannot import """); Put (Get_Name_String (Included.Path.Display_Name)); Put_Line (""":"); Put (" """); Put (Get_Name_String (Src_Data.Id.Project.Display_Name)); Put (""" does not directly import project """); Put (Get_Name_String (Included.Project.Display_Name)); Put_Line (""""); Compilation_OK := False; end if; end loop; end; end if; end if; if Compilation_OK and Dep_File_OK then Create (Dep_File, Dep_Path); Put (Dep_File, Object_Path.all); Put (Dep_File, ": "); for Src of Srcs loop if Was then Put_Line (Dep_File, " \"); else Was := True; end if; Put (Dep_File, Src.File); Put (Dep_File, " "); Put (Dep_File, String (Src.TS)); end loop; Put_Line (Dep_File, ""); Close (Dep_File); end if; Free (Object_Path); return Compilation_OK; end Phase_2_Makefile; ----------------- -- Phase_2_ALI -- ----------------- function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean is Compilation_OK : Boolean := True; Text : Text_Buffer_Ptr := Read_Library_Info_From_Full (File_Name_Type (Src_Data.Id.Dep_Path), Src_Data.Id.Dep_TS'Access); The_ALI : ALI.ALI_Id := ALI.No_ALI_Id; procedure Check_Source (Sfile : File_Name_Type); -- Check if source Sfile is in the same project file as the Src_Data -- source file. Invalidate the compilation if it is not. ------------------ -- Check_Source -- ------------------ procedure Check_Source (Sfile : File_Name_Type) is Source_3 : constant Source_Id := Find_Source (Src_Data.Tree, No_Project, Base_Name => Sfile); begin if Source_3 = No_Source then Put ("source "); Put (Get_Name_String (Sfile)); Put_Line (" is not a source of a project"); Compilation_OK := False; elsif Ultimate_Extending_Project_Of (Source_3.Project) /= Ultimate_Extending_Project_Of (Src_Data.Id.Project) then Put ("sources "); Put (Get_Name_String (Source_3.File)); Put (" and "); Put (Get_Name_String (Src_Data.Id.File)); Put (" belong to different projects: "); Put (Get_Name_String (Source_3.Project.Display_Name)); Put (" and "); Put_Line (Get_Name_String (Src_Data.Id.Project.Display_Name)); Compilation_OK := False; end if; end Check_Source; begin if Text /= null then -- Read the ALI file but read only the necessary lines The_ALI := ALI.Scan_ALI (File_Name_Type (Src_Data.Id.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "DW"); if The_ALI /= ALI.No_ALI_Id then Check_Interface_And_Indirect_Imports (The_ALI => The_ALI, Src_Data => Src_Data, Success => Compilation_OK); if Opt.No_Split_Units then -- Initialized the list of subunits with the unit name Subunits.Clear; Subunits.Append (Get_Name_String (Src_Data.Id.Unit.Name)); -- First check that the spec and the body are in the same -- project. for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop Check_Source (ALI.Units.Table (J).Sfile); end loop; -- Next, check the subunits, if any declare Subunit_Found : Boolean; Already_Found : Boolean; Last : Positive; begin -- Loop until we don't find new subunits loop Subunit_Found := False; for D in ALI.ALIs.Table (The_ALI).First_Sdep .. ALI.ALIs.Table (The_ALI).Last_Sdep loop if ALI.Sdep.Table (D).Subunit_Name /= No_Name then Get_Name_String (ALI.Sdep.Table (D).Subunit_Name); -- First check if we already found this subunit Already_Found := Subunits.Contains (Name_Buffer (1 .. Name_Len)); if not Already_Found then -- Find the name of the parent Last := Name_Len - 1; while Last > 1 and then Name_Buffer (Last + 1) /= '.' loop Last := Last - 1; end loop; if Subunits.Contains (Name_Buffer (1 .. Last)) then -- It is a new subunit, add it o the -- list and check if it is in the right -- project. Subunits.Append (Name_Buffer (1 .. Name_Len)); Subunit_Found := True; Check_Source (ALI.Sdep.Table (D).Sfile); end if; end if; end if; end loop; exit when not Subunit_Found; end loop; end; end if; if Compilation_OK and then (Builder_Data (Src_Data.Tree).Closure_Needed or else Src_Data.Closure) then Record_ALI_For (Src_Data, The_ALI); end if; end if; Free (Text); end if; return Compilation_OK; end Phase_2_ALI; -------------------------- -- Set_Options_For_File -- -------------------------- procedure Set_Options_For_File (Id : Source_Id) is Config : Language_Config renames Id.Language.Config; Builder_Options_Instance : constant String_Vector_Access := Builder_Compiling_Options_HTable.Get (Id.Language.Name); Comp_Opt : constant String_Vector_Access := Compiling_Options_HTable.Get (Id.Language.Name); List : Name_List_Index; Nam_Nod : Name_Node; First : Boolean; Index : Natural := 0; begin Compilation_Options.Clear; -- 1a) The leading required switches List := Config.Compiler_Leading_Required_Switches; First := True; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); if Nam_Nod.Name /= Empty_String then Add_Option_Internal_Codepeer (Value => Get_Name_String (Nam_Nod.Name), To => Compilation_Options, Display => First or Opt.Verbose_Mode); First := False; end if; List := Nam_Nod.Next; end loop; -- 1b) The switches in CodePeer mode if Opt.CodePeer_Mode then -- Replace -x ada with -x adascil for J in 1 .. Compilation_Options.Last_Index loop if Compilation_Options (J).Name = "-x" then Compilation_Options.Replace_Element (J + 1, Option_Type' (Name_Len => 7, Name => "adascil", Displayed => True, Simple_Name => False)); Index := J; exit; end if; end loop; if Index = 0 then Add_Option (Value => "-x", To => Compilation_Options, Display => True, Simple_Name => False); Add_Option (Value => "adascil", To => Compilation_Options, Display => True, Simple_Name => False); end if; Add_Option (Value => "-gnatcC", To => Compilation_Options, Display => True); end if; -- 2) The compilation switches specified in package Builder -- for all compilers, following "-cargs", if any. for Option of All_Language_Builder_Compiling_Options loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; -- 3) The compilation switches specified in package Builder -- for the compiler of the language, following -- -cargs:. if Builder_Options_Instance /= null then for Option of Builder_Options_Instance.all loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; end if; -- 4) Compiler'Switches(), if it is -- defined, otherwise Compiler'Switches (), -- if defined. Add_Compilation_Switches (Id); -- 5) The switches specified on the gprbuild command line -- for all compilers, following "-cargs", if any. for Option of All_Language_Compiling_Options loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; -- 6) The switches specified on the gprbuild command line -- for the compiler of the language, following -- -cargs:. if Comp_Opt /= null then for Opt of Comp_Opt.all loop Add_Option_Internal_Codepeer (Value => Opt, To => Compilation_Options, Display => True); end loop; end if; -- 7) The PIC option if it exists, for shared and "static-pic" -- libraries. if Id.Project.Library and then Id.Project.Library_Kind /= Static then List := Config.Compilation_PIC_Option; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); Add_Option_Internal_Codepeer (Value => Get_Name_String (Nam_Nod.Name), To => Compilation_Options, Display => True); List := Nam_Nod.Next; end loop; end if; end Set_Options_For_File; ------------------------- -- Check_Switches_File -- ------------------------- function Check_Switches_File (Id : Source_Id) return Boolean is File : Text_IO.File_Type; File_Content : String_Vectors.Vector; Expected_Content : String_Vectors.Vector; function Assert_Line (Current : String) return Boolean; -- Return False if Current is not the next line in the switches file ----------------- -- Assert_Line -- ----------------- function Assert_Line (Current : String) return Boolean is Line : String (1 .. 1_000); Last : Natural; begin if End_Of_File (File) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file has fewer switches"); end if; Close (File); return False; end if; Get_Line (File, Line, Last); if Line (1 .. Last) /= Current then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file '" & Get_Name_String (Id.Switches_Path) & "' has different line"); Put_Line (" " & Line (1 .. Last)); Put_Line (" " & Current); end if; Close (File); return False; end if; return True; end Assert_Line; List : Name_List_Index; Nam_Nod : Name_Node; use GPR.Debug; begin if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_S then Expected_Content.Append (String (Id.Object_TS)); for Opt of Compilation_Options loop Expected_Content.Append (Opt.Name); end loop; List := Id.Language.Config.Compiler_Trailing_Required_Switches; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); Expected_Content.Append (Get_Name_String (Nam_Nod.Name)); List := Nam_Nod.Next; end loop; end if; Open (File, In_File, Get_Name_String (Id.Switches_Path)); if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_S then declare Line : String (1 .. 1_000); Last : Natural; begin while not End_Of_File (File) loop Get_Line (File, Line, Last); File_Content.Append (Line (1 .. Last)); end loop; end; Reset (File); Put_Line (" expected .cswi file content:"); for S of Expected_Content loop Put_Line (" " & S); end loop; Put_Line (" actual .cswi file content:"); for S of File_Content loop Put_Line (" " & S); end loop; end if; if not Assert_Line (String (Id.Object_TS)) then return True; end if; for Opt of Compilation_Options loop if not Assert_Line (Opt.Name) then return True; end if; end loop; List := Id.Language.Config.Compiler_Trailing_Required_Switches; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); if not Assert_Line (Get_Name_String (Nam_Nod.Name)) then return True; end if; List := Nam_Nod.Next; end loop; if not End_Of_File (File) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file has more switches"); end if; Close (File); return True; end if; Close (File); return False; exception when others => if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no switches file"); end if; return True; end Check_Switches_File; ------------------------ -- Update_Object_Path -- ------------------------ procedure Update_Object_Path (Id : Source_Id; Source_Project : Project_Id) is begin Id.Object_Project := Source_Project; if Id.Object_Project /= Id.Project then if Id.Object /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Object); Id.Object_Path := Name_Find; end if; if Id.Dep_Name /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Dep_Name); Id.Dep_Path := Name_Find; end if; if Id.Switches /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Switches); Id.Switches_Path := Name_Find; end if; end if; end Update_Object_Path; ---------------------------- -- Add_Dependency_Options -- ---------------------------- procedure Add_Dependency_Options (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Dependency_Option; Node : Name_Node; begin if Id.Language.Config.Dependency_Kind /= None then while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); List := Node.Next; if List = No_Name_List then Add_Option (Value => Get_Name_String (Node.Name) & Get_Name_String (Id.Dep_Name), To => Compilation_Options, Display => Opt.Verbose_Mode); else Add_Option (Value => Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; end if; end Add_Dependency_Options; ------------------------------ -- Add_Object_File_Switches -- ------------------------------ procedure Add_Object_File_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Object_File_Switches; Node : Name_Node; begin if List /= No_Name_List then loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); List := Node.Next; end loop; Get_Name_String (Node.Name); Get_Name_String_And_Append (Id.Object); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); -- Always specify object-file for a multi-unit source file elsif Id.Index /= 0 then Add_Option ("-o", To => Compilation_Options, Display => True); Add_Option (Get_Name_String (Id.Object), To => Compilation_Options, Display => True); end if; end Add_Object_File_Switches; ------------------------------ -- Add_Object_Path_Switches -- ------------------------------ procedure Add_Object_Path_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Object_Path_Switches; Node : Name_Node; begin if List /= No_Name_List then if Id.Project.Object_Path_File = No_Path then Create_Object_Path_File (Id.Project, Project_Tree.Shared); end if; while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); List := Node.Next; end loop; Get_Name_String (Node.Name); Get_Name_String_And_Append (Id.Project.Object_Path_File); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end Add_Object_Path_Switches; ---------------------- -- Get_Config_Paths -- ---------------------- procedure Get_Config_Paths (Id : Source_Id; Source_Project : Project_Id) is Config : constant Language_Config := Id.Language.Config; procedure Add_Config_File (Project : Project_Id; Pkg, Attr : Name_Id); procedure Add_Config_File (Project : Project_Id; Pkg, Attr : Name_Id) is Config_File_Path : constant Path_Information := Config_File_For (Project => Project, Package_Name => Pkg, Attribute_Name => Attr, Language => Id.Language.Name); begin if Config_File_Path /= No_Path_Information and then not Cmd_Line_Adc_Files.Contains (Name_Id (Config_File_Path.Name)) then Last_Config_Path := Last_Config_Path + 1; The_Config_Paths (Last_Config_Path) := Config_File_Path; end if; end Add_Config_File; begin Last_Config_Path := 0; if Config.Config_File_Switches /= No_Name_List and then (Config.Config_Body /= No_Name or else Config.Config_Body_Index /= No_Name or else Config.Config_Body_Pattern /= No_Name or else Config.Config_Spec /= No_Name or else Config.Config_Spec_Index /= No_Name or else Config.Config_Spec_Pattern /= No_Name) and then not Config.Config_File_Unique then Add_Config_File (Main_Project, Name_Builder, Name_Global_Config_File); Add_Config_File (Source_Project, Name_Compiler, Name_Local_Config_File); end if; for CF in Cmd_Line_Adc_Files.Iterate loop Last_Config_Path := Last_Config_Path + 1; The_Config_Paths (Last_Config_Path) := (Name => Path_Name_Type (Name_Id_Maps.Key (CF)), Display_Name => Path_Name_Type (Name_Id_Maps.Element (CF))); end loop; end Get_Config_Paths; ------------------------------ -- Add_Config_File_Switches -- ------------------------------ procedure Add_Config_File_Switches (Id : Source_Id; Source_Project : Project_Id) is Config : constant Language_Config := Id.Language.Config; -- Config_File_Path : Path_Name_Type; begin if Config.Config_File_Switches /= No_Name_List and then (Config.Config_Body /= No_Name or else Config.Config_Body_Index /= No_Name or else Config.Config_Body_Pattern /= No_Name or else Config.Config_Spec /= No_Name or else Config.Config_Spec_Index /= No_Name or else Config.Config_Spec_Pattern /= No_Name) then Create_Config_File (For_Project => Source_Project, Config => Config, Language => Id.Language.Name); if Source_Project.Config_File_Name /= No_Path then Add_Config_File_Switch (Config => Config, Path_Name => Source_Project.Config_File_Name); end if; for J in 1 .. Last_Config_Path loop Add_Config_File_Switch (Config => Config, Path_Name => The_Config_Paths (J).Display_Name); end loop; end if; end Add_Config_File_Switches; ------------------------------- -- Add_Mapping_File_Switches -- ------------------------------- function Add_Mapping_File_Switches (Source : Queue.Source_Info; Source_Project : Project_Id) return Path_Name_Type is List : Name_List_Index := Source.Id.Language.Config.Mapping_File_Switches; Node : Name_Node; Mapping_File_Path : Path_Name_Type; begin if List /= No_Name_List then -- Check if there is a temporary mapping file we can use Mapping_File_Path := Mapping_Files_Htable.Get_First (Source.Id.Language.Mapping_Files); if Mapping_File_Path /= No_Path then -- Reuse this temporary mapping file and remove its -- name from the HTable so that it is not reused -- before the compilation terminates. Mapping_Files_Htable.Remove (Source.Id.Language.Mapping_Files, Mapping_File_Path); else -- Create a new temporary mapping file, as there are -- none that can be reused. GPR.Env.Create_Mapping_File (Project => Source_Project, Language => Source.Id.Language.Name, In_Tree => Source.Tree, Name => Mapping_File_Path); end if; while List /= No_Name_List loop Node := Source.Tree.Shared.Name_Lists.Table (List); List := Node.Next; if List /= No_Name_List then Add_Option (Value => Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); else Get_Name_String (Node.Name); Get_Name_String_And_Append (Mapping_File_Path); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; return Mapping_File_Path; else return No_Path; end if; end Add_Mapping_File_Switches; ----------------------------- -- Add_Multi_Unit_Switches -- ----------------------------- procedure Add_Multi_Unit_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Multi_Unit_Switches; begin if Id.Index /= 0 and then List /= No_Name_List then declare Index_Img : constant String := Id.Index'Img; Node : Name_Node; begin loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => True); List := Node.Next; end loop; Get_Name_String (Node.Name); Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => True); end; end if; end Add_Multi_Unit_Switches; --------------------------- -- Add_Trailing_Switches -- --------------------------- procedure Add_Trailing_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Compiler_Trailing_Required_Switches; Node : Name_Node; begin while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); List := Node.Next; end loop; end Add_Trailing_Switches; --------------------------------- -- Add_Name_Of_Source_Switches -- --------------------------------- procedure Add_Name_Of_Source_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Source_File_Switches; Node : Name_Node; begin -- Add any source file prefix if List /= No_Name_List then loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); List := Node.Next; end loop; end if; -- Then handle the source file Add_Option (Get_Name_String_Or_Null (Node.Name) & Get_Name_String (Id.Path.Display_Name), To => Compilation_Options, Display => True, Simple_Name => not Opt.Verbose_Mode); end Add_Name_Of_Source_Switches; --------------------------------- -- Spawn_Compiler_And_Register -- --------------------------------- procedure Spawn_Compiler_And_Register (Source : Queue.Source_Info; Source_Project : Project_Id; Compiler_Path : String; Mapping_File_Path : Path_Name_Type; Last_Switches_For_File : Integer) is procedure Add_Process (Process : GPR.Compilation.Id; Source : Queue.Source_Info; Source_Project : Project_Id; Mapping_File : Path_Name_Type; Purpose : Process_Purpose; Options : String_Vectors.Vector); -- Add compilation process and indicate that the object directory is -- busy. procedure Escape_Options (Options : in out Options_Data); -- On all platforms, escapes the characters '\', ' ' and '"' with -- character '\' before them. ----------------- -- Add_Process -- ----------------- procedure Add_Process (Process : GPR.Compilation.Id; Source : Queue.Source_Info; Source_Project : Project_Id; Mapping_File : Path_Name_Type; Purpose : Process_Purpose; Options : String_Vectors.Vector) is begin Compilation_Htable.Set (Process, (Process, Source, Source_Project, Mapping_File, Purpose, Options)); Outstanding_Compiles := Outstanding_Compiles + 1; Queue.Set_Obj_Dir_Busy (Source.Id.Project.Object_Directory.Name); end Add_Process; -------------------- -- Escape_Options -- -------------------- procedure Escape_Options (Options : in out Options_Data) is Last : constant Natural := Options.Last_Index; begin for J in 1 .. Last loop declare Opt : constant String := Options (J).Name; Nopt : constant String := Escape_Path (Opt); begin if Nopt'Length > Opt'Length then Options.Replace_Element (J, Option_Type' (Name_Len => Nopt'Length, Name => Nopt, Displayed => Options.Element (J).Displayed, Simple_Name => Options.Element (J).Simple_Name)); end if; end; end loop; end Escape_Options; ------------------ -- Get_Language -- ------------------ function Get_Language return String is (if Source.Id.Language /= null then Get_Name_String (Source.Id.Language.Name) else ""); Process : GPR.Compilation.Id; Response_File : Path_Name_Type := No_Path; -- Start of processing of Spawn_Compiler_And_Register begin if Opt.Use_GNU_Make_Jobserver and then not Preorder_Token then return; else if not Opt.Quiet_Output then Name_Len := 0; if Opt.Verbose_Mode then Add_Str_To_Name_Buffer (Compiler_Path); for Opt of Compilation_Options loop Add_Str_To_Name_Buffer (" "); if Opt.Simple_Name then Add_Str_To_Name_Buffer (Base_Name (Opt.Name)); else Add_Str_To_Name_Buffer (Opt.Name); end if; end loop; Put_Line (Name_Buffer (1 .. Name_Len)); else Display (Section => GPR.Compile, Command => Get_Name_String (Source.Id.Language.Display_Name), Argument => Get_Name_String (Source.Id.File)); end if; end if; if Source_Project.Config.Max_Command_Line_Length > 0 and then Source.Id.Language.Config.Resp_File_Format = GCC_GNU then declare Arg_Length : Natural := 0; begin for Opt of Compilation_Options loop Arg_Length := Arg_Length + 1 + Opt.Name'Length; end loop; if Arg_Length > Source_Project.Config.Max_Command_Line_Length then declare use GPR.Tempdir; FD : File_Descriptor; Status : Integer; Closing_Status : Boolean; begin -- Escape the following characters in the options: -- '\', ' ' and '"'. Escape_Options (Compilation_Options); Create_Temp_File (FD, Response_File); Record_Temp_File (Shared => Source.Tree.Shared, Path => Response_File); Option_Loop : for Opt of Compilation_Options loop Status := Write (FD, Opt.Name (1)'Address, Opt.Name'Length); if Status /= Opt.Name'Length then Put_Line ("Could not write option """ & Opt.Name & """ in response file """ & Get_Name_String (Response_File) & """"); Response_File := No_Path; exit Option_Loop; end if; Status := Write (FD, ASCII.LF'Address, 1); end loop Option_Loop; Close (FD, Closing_Status); if not Closing_Status and then Response_File /= No_Path then Put_Line ("Could not close response file """ & Get_Name_String (Response_File) & """"); Response_File := No_Path; end if; end; if Opt.Verbosity_Level > Opt.Low and then Response_File /= No_Path then Put_Line ("using a response file"); end if; end if; end; end if; Process := Run (Compiler_Path, Options_List (Compilation_Options), Source_Project, Source => Get_Name_String (Source.Id.File), Language => Get_Language, Dep_Name => (if Source.Id.Dep_Name = No_File then "" else Get_Name_String (Source.Id.Dep_Name)), Obj_Name => (if Source.Id.Object = No_File then "" else Get_Name_String (Source.Id.Object)), Response_File => Response_File); if Last_Switches_For_File >= 0 then while Compilation_Options.Last_Index > Last_Switches_For_File loop Compilation_Options.Delete_Last; end loop; Add_Trailing_Switches (Source.Id); end if; Add_Process (Process => Process, Source => Source, Source_Project => Source_Project, Mapping_File => Mapping_File_Path, Purpose => Compilation, Options => Options_List (Compilation_Options)); if Opt.Use_GNU_Make_Jobserver then Register_Token_Id (Id => Process); end if; end if; end Spawn_Compiler_And_Register; ------------------------------ -- Get_Compatible_Languages -- ------------------------------ function Get_Compatible_Languages (Lang : Language_Ptr) return Name_Ids is NL : Name_List_Index := Lang.Config.Include_Compatible_Languages; Languages : Name_Ids (1 .. 1 + Length (Project_Tree.Shared.Name_Lists, NL)); Index : Positive := 1; begin Languages (Index) := Lang.Name; while NL /= No_Name_List loop Index := Index + 1; Languages (Index) := Project_Tree.Shared.Name_Lists.Table (NL).Name; NL := Project_Tree.Shared.Name_Lists.Table (NL).Next; end loop; return Languages; end Get_Compatible_Languages; ------------------------------- -- Prepare_Include_Path_File -- ------------------------------- procedure Prepare_Include_Path_File (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr) is FD : File_Descriptor; Status : Boolean; begin Get_Directories (Project_Tree => Project_Tree, For_Project => Project, Activity => Compilation, Languages => Get_Compatible_Languages (Lang)); GPR.Env.Create_New_Path_File (Shared => Project_Tree.Shared, Path_FD => FD, Path_Name => Data.Include_Path_File); if FD = Invalid_FD then Fail_Program (Project_Tree, "could not create temporary path file"); end if; for Index in 1 .. Directories.Last loop Get_Name_String (Directories.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (FD, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include path file"); end if; end loop; Close (FD, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include path file"); end if; end Prepare_Include_Path_File; ------------------------------------ -- Prepare_Imported_Dirs_Switches -- ------------------------------------ procedure Prepare_Imported_Dirs_Switches (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr) is Len : constant Natural := Length (Project_Tree.Shared.Name_Lists, Lang.Config.Include_Option); -- Host_Path : OS_Lib.String_Access; Last : Natural := 0; List : Name_List_Index; Nam : Name_Node; begin Get_Directories (Project_Tree => Project_Tree, For_Project => Project, Activity => Compilation, Languages => Get_Compatible_Languages (Lang)); Free (Data.Imported_Dirs_Switches); Data.Imported_Dirs_Switches := new String_List (1 .. Directories.Last * Len); for Index in 1 .. Directories.Last loop List := Lang.Config.Include_Option; while List /= No_Name_List loop Nam := Project_Tree.Shared.Name_Lists.Table (List); exit when Nam.Next = No_Name_List; Last := Last + 1; Data.Imported_Dirs_Switches (Last) := new String'(Get_Name_String (Nam.Name)); List := Nam.Next; end loop; Get_Name_String (Directories.Table (Index)); while Name_Len > 1 and then (Name_Buffer (Name_Len) = Directory_Separator or else Name_Buffer (Name_Len) = '/') loop Name_Len := Name_Len - 1; end loop; Last := Last + 1; -- Concatenate the last switch and the path in a single option Data.Imported_Dirs_Switches (Last) := new String' (Get_Name_String (Nam.Name) & Name_Buffer (1 .. Name_Len)); end loop; end Prepare_Imported_Dirs_Switches; ------------------------------ -- Set_Env_For_Include_Dirs -- ------------------------------ procedure Set_Env_For_Include_Dirs (Id : Source_Id; Source_Project : Project_Id) is Current_Project : Project_Id := No_Project; Current_Language_Ind : Language_Ptr := No_Language_Index; -- The project for which the include path environment has been set -- last, to avoid computing it several times. Data : Local_Project_Data := Local_Projects_HT.Get (Local_Projects, Id.Object_Project); begin -- Prepare (if not already done) the data for Project/Lang. -- All files for a given language are processed sequentially, before -- we switch to the next language, so we are only preparing once per -- language here. if Data.Include_Language /= Id.Language then Free (Data.Include_Path); Free (Data.Imported_Dirs_Switches); Data := No_Local_Project_Data; if Id.Language.Config.Include_Option /= No_Name_List then Prepare_Imported_Dirs_Switches (Data, Id.Object_Project, Id.Language); elsif Id.Language.Config.Include_Switches_Via_Spec /= No_Name_List then declare Include_Switches_Spec : File_Descriptor := Invalid_FD; Switches_File_Name : Path_Name_Type; Switches_File : File_Descriptor := Invalid_FD; Status : Boolean := False; Compiler : OS_Lib.String_Access; Switch : OS_Lib.String_Access; List : Name_List_Index := Id.Language.Config.Include_Switches_Via_Spec; Elem : Name_Node; begin Elem := Project_Tree.Shared.Name_Lists.Table (List); Compiler := new String'(Get_Name_String (Elem.Name)); List := Elem.Next; Elem := Project_Tree.Shared.Name_Lists.Table (List); Switch := new String'(Get_Name_String (Elem.Name)); Get_Directories (Project_Tree => Project_Tree, For_Project => Id.Object_Project, Activity => Compilation, Languages => Get_Compatible_Languages (Id.Language)); GPR.Env.Create_Temp_File (Project_Tree.Shared, Switches_File, Switches_File_Name, "include switches"); for Index in 1 .. Directories.Last loop Set_Name_Buffer (Switch.all); Add_Str_To_Name_Buffer (Escape_Path (Get_Name_String (Directories.Table (Index)))); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Switches_File, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches file"); end if; end loop; Close (Switches_File, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include switches file"); end if; GPR.Env.Create_Temp_File (Project_Tree.Shared, Include_Switches_Spec, Data.Include_Switches_Spec_File, "include switches spec"); Name_Len := 1; Name_Buffer (1) := '*'; Add_Str_To_Name_Buffer (Compiler.all); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ':'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Include_Switches_Spec, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Set_Name_Buffer ("+ @"); Add_Str_To_Name_Buffer (Escape_Path (Get_Name_String (Switches_File_Name))); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Include_Switches_Spec, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Close (Include_Switches_Spec, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Free (Compiler); Free (Switch); declare Path : constant String := Get_Name_String (Data.Include_Switches_Spec_File); begin Data.Imported_Dirs_Switches := new String_List' (1 => new String'("-specs=" & Path)); end; end; elsif Id.Language.Config.Include_Path_File /= No_Name then if Id.Language.Config.Mapping_File_Switches = No_Name_List or else Opt.Use_Include_Path_File then Prepare_Include_Path_File (Data, Id.Object_Project, Id.Language); end if; elsif Id.Language.Config.Include_Path /= No_Name then Get_Directories (Project_Tree => Project_Tree, For_Project => Id.Object_Project, Activity => Compilation, Languages => Get_Compatible_Languages (Id.Language)); Data.Include_Path := Create_Path_From_Dirs; end if; Data.Include_Language := Id.Language; Local_Projects_HT.Set (Local_Projects, Id.Object_Project, Data); end if; -- Reset environment variables if they have changed if Id.Object_Project /= Current_Project or else Id.Language /= Current_Language_Ind then Current_Project := Id.Object_Project; Current_Language_Ind := Id.Language; if Data.Include_Path_File /= No_Path then Setenv (Get_Name_String (Id.Language.Config.Include_Path_File), Get_Name_String (Data.Include_Path_File)); elsif Data.Include_Path /= null then GPR.Compilation.Process.Record_Environment (Source_Project, Id.Language.Name, Get_Name_String (Id.Language.Config.Include_Path), Data.Include_Path.all); if Opt.Verbosity_Level > Opt.Low then Put (Get_Name_String (Id.Language.Config.Include_Path)); Put (" = "); Put_Line (Data.Include_Path.all); end if; end if; end if; -- But always set the switches if Data.Imported_Dirs_Switches /= null then for J in Data.Imported_Dirs_Switches'Range loop if Data.Imported_Dirs_Switches (J)'Length > 0 then Add_Option (Value => Data.Imported_Dirs_Switches (J).all, To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; end if; end Set_Env_For_Include_Dirs; ----------------------------- -- Process_Project_Phase_1 -- ----------------------------- procedure Process_Project_Phase_1 (Source : Queue.Source_Info) is Id : constant Source_Id := Source.Id; Project_Tree : constant Project_Tree_Ref := Source.Tree; Source_Project : constant Project_Id := Ultimate_Extending_Project_Of (Id.Project); Dummy : Boolean; Compilation_Needed : Boolean := True; Last_Switches_For_File : Integer; Mapping_File : Path_Name_Type; The_ALI : ALI.ALI_Id; Compiler : OS_Lib.String_Access; begin Get_Config_Paths (Id, Source_Project); if Always_Compile or else not Source_Project.Externally_Built then Need_To_Compile (Source => Id, Tree => Source.Tree, In_Project => Source_Project, Conf_Paths => The_Config_Paths (1 .. Last_Config_Path), Must_Compile => Compilation_Needed, The_ALI => The_ALI, Object_Check => Object_Checked, Always_Compile => Always_Compile); if Total_Errors_Detected > 0 then Compilation_Phase_Failed (Source.Tree, No_Message => Opt.No_Exit_Message); end if; if The_ALI /= ALI.No_ALI_Id then declare Success : Boolean := True; begin Check_Interface_And_Indirect_Imports (The_ALI => The_ALI, Src_Data => Source, Success => Success); if not Success then Compilation_Phase_Failed (Source.Tree, (if Exit_Code = E_Success then E_Fatal else Exit_Code), No_Message => Opt.No_Exit_Message); end if; end; end if; if Compilation_Needed and then Opt.Keep_Going then -- When in Keep_Going mode first check that we did not already -- tried to compile this source as part of another import of -- the corresponding project file. if Bad_Compilations.Contains (Id) then Compilation_Needed := False; end if; end if; if Compilation_Needed or else Opt.Check_Switches then Set_Options_For_File (Id); if Opt.Check_Switches and then not Compilation_Needed then Compilation_Needed := Check_Switches_File (Id); end if; end if; if Compilation_Needed then -- If Distributed_Mode activated, parse Remote package to -- register and initialize the slaves. if Distributed_Mode and then not Slave_Initialized then begin GPR.Compilation.Slave.Register_Remote_Slaves (Project_Tree, Main_Project); Slave_Initialized := True; exception when E : Constraint_Error => Fail_Program (Project_Tree, Exception_Information (E)); end; end if; Update_Object_Path (Id, Source_Project); Change_To_Object_Directory (Source_Project, Must_Be_Writable => True); -- Record the last recorded option index, to be able to -- write the switches file later. if Id.Language.Config.Object_Generated then Last_Switches_For_File := Compilation_Options.Last_Index; else Last_Switches_For_File := -1; end if; Add_Dependency_Options (Id); Set_Env_For_Include_Dirs (Id, Source_Project); Add_Config_File_Switches (Id, Source_Project); Mapping_File := Add_Mapping_File_Switches (Source, Source_Project); Add_Trailing_Switches (Id); Add_Name_Of_Source_Switches (Id); Add_Object_File_Switches (Id); Add_Multi_Unit_Switches (Id); Add_Object_Path_Switches (Id); Compiler := Get_Compiler_Driver_Path (Source_Project, Id.Language); if Compiler /= null then if Id.Switches_Path /= No_Path then -- Need to remove .cswi file so that it doesn't get -- reused in case of compilation failure. OS_Lib.Delete_File (Get_Name_String (Id.Switches_Path), Dummy); end if; Spawn_Compiler_And_Register (Source => Source, Source_Project => Source_Project, Compiler_Path => Compiler.all, Mapping_File_Path => Mapping_File, Last_Switches_For_File => Last_Switches_For_File); end if; else Print_Compilation_Outputs (Id); if Source.Closure or else (Builder_Data (Source.Tree).Closure_Needed and then Id.Language.Config.Dependency_Kind in ALI_Dependency) then Record_ALI_For (Source, The_ALI); else ALI.Initialize_ALI; end if; end if; end if; end Process_Project_Phase_1; -------------------------------- -- Must_Exit_Because_Of_Error -- -------------------------------- function Must_Exit_Because_Of_Error return Boolean is Source_Identity : Queue.Source_Info; Compilation_OK : Boolean; Slave : Unbounded_String; Cur : Bad_Compilations_Set.Cursor; OK : Boolean; begin if not Bad_Compilations.Is_Empty and then not Opt.Keep_Going then while Outstanding_Compiles > 0 loop Await_Compile (Source_Identity, Compilation_OK, Slave); if not Compilation_OK then Bad_Compilations.Insert (Source_Identity.Id, To_String (Slave), Cur, OK); end if; end loop; return True; end if; return False; end Must_Exit_Because_Of_Error; ------------------------------- -- Start_Compile_If_Possible -- ------------------------------- procedure Start_Compile_If_Possible is Found : Boolean; Source : Queue.Source_Info; begin if not Queue.Is_Empty and then (Opt.Use_GNU_Make_Jobserver or else Outstanding_Compiles < Get_Maximum_Processes) then Queue.Get (Found, Source); if Found then Initialize_Source_Record (Source.Id); Process_Project_Phase_1 (Source); end if; if Opt.Use_GNU_Make_Jobserver and then Unavailable_Token then null; elsif Found then Queue.Next; end if; end if; end Start_Compile_If_Possible; ----------------------------- -- Wait_For_Available_Slot -- ----------------------------- procedure Wait_For_Available_Slot is Source_Identity : Queue.Source_Info; Compilation_OK : Boolean; No_Check : Boolean; Slave : Unbounded_String; use Queue; Cur : Bad_Compilations_Set.Cursor; OK : Boolean; function No_Slot_Available return Boolean; ----------------------- -- No_Slot_Available -- ----------------------- function No_Slot_Available return Boolean is begin if Opt.Use_GNU_Make_Jobserver then return (Unavailable_Token and then Registered_Processes); else return (Outstanding_Compiles = Get_Maximum_Processes); end if; end No_Slot_Available; begin if No_Slot_Available or else (Queue.Is_Virtually_Empty and then Outstanding_Compiles > 0) then Await_Compile (Source_Identity, Compilation_OK, Slave); if Compilation_OK and then Source_Identity /= Queue.No_Source_Info then -- Check if dependencies are on sources in Interfaces and, -- when --direct-import-only is used, the imported sources -- come from directly withed projects. Imports.Reset; Included_Sources.Clear; case Source_Identity.Id.Language.Config.Dependency_Kind is when None => null; when Makefile => Compilation_OK := Phase_2_Makefile (Source_Identity); when ALI_Dependency => Compilation_OK := Phase_2_ALI (Source_Identity); end case; -- If the compilation was invalidated, delete the compilation -- artifacts. if not Compilation_OK then if Source_Identity.Id.Dep_Path /= No_Path and then not Keep_Dep_File then Delete_File (Get_Name_String (Source_Identity.Id.Dep_Path), No_Check); end if; if Source_Identity.Id.Object_Path /= No_Path then Delete_File (Get_Name_String (Source_Identity.Id.Object_Path), No_Check); end if; if Source_Identity.Id.Switches_Path /= No_Path then Delete_File (Get_Name_String (Source_Identity.Id.Switches_Path), No_Check); end if; end if; end if; if not Compilation_OK then Bad_Compilations.Insert (Source_Identity.Id, To_String (Slave), Cur, OK); end if; end if; end Wait_For_Available_Slot; -- Start of processing for Compilation_Phase begin Outstanding_Compiles := 0; -- Then process each files in the queue (new files might be added to -- the queue as a result). Compilation_Loop : while not Queue.Is_Empty or else Outstanding_Compiles > 0 loop exit Compilation_Loop when Must_Exit_Because_Of_Error; Start_Compile_If_Possible; Wait_For_Available_Slot; if Opt.Display_Compilation_Progress then Put_Line ("completed" & Queue.Processed'Img & " out of" & Queue.Size'Img & " (" & Trim (Source => Int (((Queue.Processed) * 100) / Queue.Size)'Img, Side => Ada.Strings.Left) & "%)..."); end if; end loop Compilation_Loop; -- Release local memory declare Data : Local_Project_Data := Local_Projects_HT.Get_First (Local_Projects); begin while Data /= No_Local_Project_Data loop Free (Data.Include_Path); Free (Data.Imported_Dirs_Switches); Data := Local_Projects_HT.Get_Next (Local_Projects); end loop; Local_Projects_HT.Reset (Local_Projects); end; end Compilation_Phase; --------------------- -- Project_Extends -- --------------------- function Project_Extends (Extending : Project_Id; Extended : Project_Id) return Boolean is Current : Project_Id := Extending; begin loop if Current = No_Project then return False; elsif Current = Extended then return True; end if; Current := Current.Extends; end loop; end Project_Extends; end Gprbuild.Compile;