------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Containers.Indefinite_Vectors; with Ada.Environment_Variables; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.HTable; with GNAT.Regexp; use GNAT.Regexp; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Com; with GPR.Debug; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Ext; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Tempdir; package body Gpr_Build_Util is use ALI; function File_Not_A_Source_Of (Project_Tree : Project_Tree_Ref; Uname : Name_Id; Sfile : File_Name_Type) return Boolean; -- Check that file name Sfile is one of the source of unit Uname. Returns -- True if the unit is in one of the project file, but the file name is not -- one of its source. Returns False otherwise. procedure Verbose_Msg (N1 : Name_Id; S1 : String; N2 : Name_Id := No_Name; S2 : String := ""; Prefix : String := " -> "; Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at -- least equal to Minimum_Verbosity, then print Prefix to standard output -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 -- is printed last. Both N1 and N2 are printed in quotation marks. The two -- forms differ only in taking Name_Id or File_name_Type arguments. --------- -- Add -- --------- procedure Add (Option : String_Access; To : in out String_List_Access; Last : in out Natural) is begin if Last = To'Last then declare New_Options : constant String_List_Access := new String_List (1 .. To'Last * 2); begin New_Options (To'Range) := To.all; -- Set all elements of the original options to null to avoid -- deallocation of copies. To.all := (others => null); Free (To); To := New_Options; end; end if; Last := Last + 1; To (Last) := Option; end Add; procedure Add (Option : String; To : in out String_List_Access; Last : in out Natural) is begin Add (Option => new String'(Option), To => To, Last => Last); end Add; --------------------------- -- Add_Gpr_Tool_External -- --------------------------- procedure Add_Gpr_Tool_External is use Ada.Environment_Variables; Gpr_Tool : constant String := Value ("GPR_TOOL", ""); begin -- Set GPR_TOOL unless already set if Gpr_Tool = "" then Ada.Environment_Variables.Set ("GPR_TOOL", "gprbuild"); end if; end Add_Gpr_Tool_External; ---------------------------- -- Aggregate_Libraries_In -- ---------------------------- function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean is List : Project_List; begin List := Tree.Projects; while List /= null loop if List.Project.Qualifier = Aggregate_Library then return True; end if; List := List.Next; end loop; return False; end Aggregate_Libraries_In; ------------------------- -- Base_Name_Index_For -- ------------------------- function Base_Name_Index_For (Main : String; Main_Index : Int; Index_Separator : Character) return File_Name_Type is Result : File_Name_Type; begin Set_Name_Buffer (Base_Name (Main)); -- Remove the extension, if any, that is the last part of the base name -- starting with a dot and following some characters. for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then Name_Len := J - 1; exit; end if; end loop; -- Add the index info, if index is different from 0 if Main_Index > 0 then Add_Char_To_Name_Buffer (Index_Separator); declare Img : constant String := Main_Index'Img; begin Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); end; end if; Result := Name_Find; return Result; end Base_Name_Index_For; ------------------------------ -- Check_Source_Info_In_ALI -- ------------------------------ function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id; Tree : Project_Tree_Ref) return Name_Id is Result : Name_Id := No_Name; Unit_Name : Name_Id; begin -- Loop through units for U in ALIs.Table (The_ALI).First_Unit .. ALIs.Table (The_ALI).Last_Unit loop -- Check if the file name is one of the source of the unit Get_Name_String (Units.Table (U).Uname); Name_Len := Name_Len - 2; Unit_Name := Name_Find; if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then return No_Name; end if; if Result = No_Name then Result := Unit_Name; end if; -- Loop to do same check for each of the withed units for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop declare WR : ALI.With_Record renames Withs.Table (W); begin if WR.Sfile /= No_File then Get_Name_String (WR.Uname); Name_Len := Name_Len - 2; Unit_Name := Name_Find; if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then return No_Name; end if; end if; end; end loop; end loop; -- Loop to check subunits and replaced sources for D in ALIs.Table (The_ALI).First_Sdep .. ALIs.Table (The_ALI).Last_Sdep loop declare SD : Sdep_Record renames Sdep.Table (D); begin Unit_Name := SD.Subunit_Name; if Unit_Name = No_Name then -- Check if this source file has been replaced by a source with -- a different file name. if Tree /= null and then Tree.Replaced_Source_Number > 0 then declare Replacement : constant File_Name_Type := Replaced_Source_HTable.Get (Tree.Replaced_Sources, SD.Sfile); begin if Replacement /= No_File then if Opt.Verbosity_Level > Opt.Low then Put_Line ("source file" & Get_Name_String (SD.Sfile) & " has been replaced by " & Get_Name_String (Replacement)); end if; return No_Name; end if; end; end if; -- Check that a dependent source for a unit that is from a -- project is indeed a source of this unit. Unit_Name := SD.Unit_Name; if Unit_Name /= No_Name -- and then not Fname.Is_Internal_File_Name (SD.Sfile) and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile) then return No_Name; end if; else -- For separates, the file is no longer associated with the -- unit ("proc-sep.adb" is not associated with unit "proc.sep") -- so we need to check whether the source file still exists in -- the source tree: it will if it matches the naming scheme -- (and then will be for the same unit). if GPR.Find_Source (In_Tree => Tree, Project => No_Project, Base_Name => SD.Sfile) = No_Source then Get_Name_String (SD.Sfile); if Name_Len < 3 or else Name_Buffer (2) /= '-' or else (Name_Buffer (1) /= 'a' and then Name_Buffer (1) /= 'g' and then Name_Buffer (1) /= 'i' and then Name_Buffer (1) /= 's') then if Opt.Verbosity_Level > Opt.Low then Put_Line ("While parsing ALI file, file " & Get_Name_String (SD.Sfile) & " is indicated as containing subunit " & Get_Name_String (Unit_Name) & " but this does not match what was found while" & " parsing the project. Will recompile"); end if; return No_Name; end if; end if; end if; end; end loop; return Result; end Check_Source_Info_In_ALI; -------------------------------- -- Create_Binder_Mapping_File -- -------------------------------- function Create_Binder_Mapping_File (Project_Tree : Project_Tree_Ref) return Path_Name_Type is Mapping_Path : Path_Name_Type := No_Path; Mapping_FD : File_Descriptor := Invalid_FD; -- A File Descriptor for an eventual mapping file ALI_Unit : Unit_Name_Type := No_Unit_Name; -- The unit name of an ALI file ALI_Name : File_Name_Type := No_File; -- The file name of the ALI file ALI_Project : Project_Id := No_Project; -- The project of the ALI file Bytes : Integer; OK : Boolean := False; Unit : Unit_Index; Status : Boolean; -- For call to Close Iter : Source_Iterator := For_Each_Source (In_Tree => Project_Tree, Language => Name_Ada, Encapsulated_Libs => False, Locally_Removed => False); Source : GPR.Source_Id; begin Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); Record_Temp_File (Project_Tree.Shared, Mapping_Path); if Mapping_FD /= Invalid_FD then OK := True; loop Source := Element (Iter); exit when Source = No_Source; Unit := Source.Unit; if Source.Replaced_By /= No_Source or else Unit = No_Unit_Index or else Unit.Name = No_Name then ALI_Name := No_File; -- If this is a body, put it in the mapping elsif Source.Kind = Impl and then Unit.File_Names (Impl) /= No_Source and then Unit.File_Names (Impl).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%b"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Impl).Display_File); ALI_Project := Unit.File_Names (Impl).Project; -- Otherwise, if this is a spec and there is no body, put it in -- the mapping. elsif Source.Kind = Spec and then Unit.File_Names (Impl) = No_Source and then Unit.File_Names (Spec) /= No_Source and then Unit.File_Names (Spec).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%s"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Spec).Display_File); ALI_Project := Unit.File_Names (Spec).Project; else ALI_Name := No_File; end if; -- If we have something to put in the mapping then do it now. If -- the project is extended, look for the ALI file in the project, -- then in the extending projects in order, and use the last one -- found. if ALI_Name /= No_File then -- Look in the project and the projects that are extending it -- to find the real ALI file. declare ALI : constant String := Get_Name_String (ALI_Name); ALI_Path : Name_Id := No_Name; begin loop -- For library projects, use the library ALI directory, -- for other projects, use the object directory. if ALI_Project.Library then Get_Name_String (ALI_Project.Library_ALI_Dir.Display_Name); else Get_Name_String (ALI_Project.Object_Directory.Display_Name); end if; Add_Str_To_Name_Buffer (ALI); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then ALI_Path := Name_Find; end if; ALI_Project := ALI_Project.Extended_By; exit when ALI_Project = No_Project; end loop; if ALI_Path /= No_Name then -- First line is the unit name Get_Name_String (ALI_Unit); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := Bytes = Name_Len; exit when not OK; -- Second line is the ALI file name Get_Name_String (ALI_Name); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := (Bytes = Name_Len); exit when not OK; -- Third line is the ALI path name Get_Name_String (ALI_Path); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := (Bytes = Name_Len); -- If OK is False, it means we were unable to write a -- line. No point in continuing with the other units. exit when not OK; end if; end; end if; Next (Iter); end loop; Close (Mapping_FD, Status); OK := OK and Status; end if; -- If the creation of the mapping file was successful, we add the switch -- to the arguments of gnatbind. if OK then return Mapping_Path; else return No_Path; end if; end Create_Binder_Mapping_File; ----------------- -- Escape_Path -- ----------------- function Escape_Path (Path : String) return String is Result : String (1 .. Path'Length * 2); Last : Natural := 0; begin for J in Path'Range loop if Path (J) in '\' | ' ' | '"' then Last := Last + 1; Result (Last) := '\'; end if; Last := Last + 1; Result (Last) := Path (J); end loop; return Result (1 .. Last); end Escape_Path; -------------------------- -- File_Not_A_Source_Of -- -------------------------- function File_Not_A_Source_Of (Project_Tree : Project_Tree_Ref; Uname : Name_Id; Sfile : File_Name_Type) return Boolean is Unit : constant Unit_Index := Units_Htable.Get (Project_Tree.Units_HT, Uname); At_Least_One_File : Boolean := False; begin if Unit /= No_Unit_Index then for F in Unit.File_Names'Range loop if Unit.File_Names (F) /= null then At_Least_One_File := True; if Unit.File_Names (F).File = Sfile then return False; end if; end if; end loop; if not At_Least_One_File then -- The unit was probably created initially for a separate unit -- (which are initially created as IMPL when both suffixes are the -- same). Later on, Override_Kind changed the type of the file, -- and the unit is no longer valid in fact. return False; end if; Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); return True; end if; return False; end File_Not_A_Source_Of; --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (Project_Tree : Project_Tree_Ref; For_Project : Project_Id; Activity : Activity_Type; Languages : Name_Ids) is procedure Recursive_Add (Project : Project_Id; Tree : Project_Tree_Ref; Extended : in out Boolean); -- Add all the source directories of a project to the path only if -- this project has not been visited. Calls itself recursively for -- projects being extended, and imported projects. procedure Add_Dir (Value : Path_Name_Type); -- Add directory Value in table Directories, if it is defined and not -- already there. ------------- -- Add_Dir -- ------------- procedure Add_Dir (Value : Path_Name_Type) is Add_It : Boolean := True; begin if Value /= No_Path and then Is_Directory (Get_Name_String (Value)) then for Index in 1 .. Directories.Last loop if Directories.Table (Index) = Value then Add_It := False; exit; end if; end loop; if Add_It then Directories.Increment_Last; Directories.Table (Directories.Last) := Value; end if; end if; end Add_Dir; ------------------- -- Recursive_Add -- ------------------- procedure Recursive_Add (Project : Project_Id; Tree : Project_Tree_Ref; Extended : in out Boolean) is Current : String_List_Id; Dir : String_Element; OK : Boolean := False; Lang_Proc : Language_Ptr := Project.Languages; Lang_Is_Ada : Boolean := False; begin -- Add to path all directories of this project if Activity = Compilation then for J in Languages'Range loop if Languages (J) = Name_Ada then OK := True; Lang_Is_Ada := True; exit; end if; end loop; if not OK then Lang_Loop : while Lang_Proc /= No_Language_Index loop for J in Languages'Range loop OK := Lang_Proc.Name = Languages (J); exit Lang_Loop when OK; end loop; Lang_Proc := Lang_Proc.Next; end loop Lang_Loop; end if; if OK then Current := Project.Source_Dirs; while Current /= Nil_String loop Dir := Tree.Shared.String_Elements.Table (Current); -- For Ada we put all the source directories, as a -- preprocessing data file may be in a source directory -- with no source. if Lang_Is_Ada or else not Lang_Proc.Config.Only_Dirs_With_Sources then Add_Dir (Path_Name_Type (Dir.Value)); else -- For other languages, if Only_Dirs_With_Sources has -- been set to True, put the source directories with -- at least one source of the language(s). declare Dir_Name : constant String := Get_Name_String (Dir.Value); Src : GPR.Source_Id := Lang_Proc.First_Source; begin while Src /= No_Source loop if Index (Get_Name_String (Src.Path.Name), Dir_Name) = 1 then Add_Dir (Path_Name_Type (Dir.Value)); exit; end if; Src := Src.Next_In_Lang; end loop; end; end if; Current := Dir.Next; end loop; end if; elsif Project.Library then if Activity = SAL_Binding and then Extended then Add_Dir (Project.Object_Directory.Display_Name); else Add_Dir (Project.Library_ALI_Dir.Display_Name); end if; else Add_Dir (Project.Object_Directory.Display_Name); end if; if Project.Extends = No_Project then Extended := False; end if; end Recursive_Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); Extended : Boolean := True; -- Start of processing for Get_Directories begin Directories.Init; For_All_Projects (For_Project, Project_Tree, Extended); end Get_Directories; ------------ -- Inform -- ------------ procedure Inform (N : File_Name_Type; Msg : String) is begin Inform (Name_Id (N), Msg); end Inform; procedure Inform (N : Name_Id := No_Name; Msg : String) is begin Write_Program_Name; if N /= No_Name then Write_Char ('"'); declare Name : constant String := Get_Name_String (N); begin if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then Write_Str (File_Name (Name)); else Write_Str (Name); end if; end; Write_Str (""" "); end if; Write_Line (Msg); end Inform; ---------------------------- -- Is_External_Assignment -- ---------------------------- function Is_External_Assignment (Env : GPR.Tree.Environment; Argv : String) return Boolean is Start : Positive := 3; Finish : Natural := Argv'Last; pragma Assert (Argv'First = 1); pragma Assert (Argv (1 .. 2) = "-X"); begin if Argv'Last < 5 then return False; elsif Argv (3) = '"' then if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then return False; else Start := 4; Finish := Argv'Last - 1; end if; end if; return GPR.Ext.Check (Self => Env.External, Declaration => Argv (Start .. Finish)); end Is_External_Assignment; ------------------- -- Lib_File_Name -- ------------------- function Lib_File_Name (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type is begin Get_Name_String (Source_File); for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then Name_Len := J - 1; exit; end if; end loop; if Munit_Index /= 0 then Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); Add_Nat_To_Name_Buffer (Munit_Index); end if; Add_Str_To_Name_Buffer (".ali"); return Name_Find; end Lib_File_Name; ----------- -- Mains -- ----------- package body Mains is package Main_Info_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Main_Info); -- The vector that stores the mains Names : Main_Info_Vectors.Vector; Current : Natural := 0; -- The index of the last main retrieved from the table Count_Of_Mains_With_No_Tree : Natural := 0; -- Number of main units for which we do not know the project tree -------------- -- Add_Main -- -------------- procedure Add_Main (Name : String; Index : Int := 0; Location : Source_Ptr := No_Location; Project : Project_Id := No_Project; Tree : Project_Tree_Ref := null) is Canonical_Name : File_Name_Type; begin Set_Name_Buffer (Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Name := Name_Find; -- Check if this main is already in table Names. If it is, do not -- put it again, to avoid binding and linking the same main several -- times in parallel when -jnn is used, as this does not work on all -- platforms. for N of Names loop if Canonical_Name = N.File and then Index = N.Index and then Project = N.Project then return; end if; end loop; if Current_Verbosity = High then Debug_Output ("Add_Main """ & Name & """ " & Index'Img & " with_tree? " & Boolean'Image (Tree /= null)); end if; Set_Name_Buffer (Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Names.Append ((Name_Find, Index, Location, No_Source, Project, Tree, String_Vectors.Empty_Vector), 1); if Tree /= null then Builder_Data (Tree).Number_Of_Mains := Builder_Data (Tree).Number_Of_Mains + 1; else Mains.Count_Of_Mains_With_No_Tree := Mains.Count_Of_Mains_With_No_Tree + 1; end if; end Add_Main; -------------------- -- Complete_Mains -- -------------------- procedure Complete_Mains (Flags : Processing_Flags; Root_Project : Project_Id; Project_Tree : Project_Tree_Ref; Unique_Compile : Boolean := False) is procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref); -- Check the mains for this specific project procedure Complete_All is new For_Project_And_Aggregated (Do_Complete); procedure Add_Multi_Unit_Sources (Tree : Project_Tree_Ref; Source : GPR.Source_Id); -- Add all units from the same file as the multi-unit Source function Find_File_Add_Extension (Tree : Project_Tree_Ref; Base_Main : String) return GPR.Source_Id; -- Search for Main in the project, adding body or spec extensions ---------------------------- -- Add_Multi_Unit_Sources -- ---------------------------- procedure Add_Multi_Unit_Sources (Tree : Project_Tree_Ref; Source : GPR.Source_Id) is Iter : Source_Iterator; Src : GPR.Source_Id; begin Debug_Output ("found multi-unit source file in project", Source.Project.Name); Iter := For_Each_Source (In_Tree => Tree, Project => Source.Project); while Element (Iter) /= No_Source loop Src := Element (Iter); if Src.File = Source.File and then Src.Index /= Source.Index then if Src.File = Source.File then Debug_Output ("add main in project, index=" & Src.Index'Img); end if; Names.Append ((File => Src.File, Index => Src.Index, Location => No_Location, Source => Src, Project => Src.Project, Tree => Tree, Command => String_Vectors.Empty_Vector), 1); Builder_Data (Tree).Number_Of_Mains := Builder_Data (Tree).Number_Of_Mains + 1; end if; Next (Iter); end loop; end Add_Multi_Unit_Sources; ----------------------------- -- Find_File_Add_Extension -- ----------------------------- function Find_File_Add_Extension (Tree : Project_Tree_Ref; Base_Main : String) return GPR.Source_Id is Spec_Source : GPR.Source_Id := No_Source; Source : GPR.Source_Id; Iter : Source_Iterator; Suffix : File_Name_Type; begin Source := No_Source; Iter := For_Each_Source (Tree); -- In all projects loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Kind = Impl then Get_Name_String (Source.File); if Name_Len > Base_Main'Length and then Name_Buffer (1 .. Base_Main'Length) = Base_Main then Suffix := Source.Language.Config.Naming_Data.Body_Suffix; if Suffix /= No_File then declare Suffix_Str : String := Get_Name_String (Suffix); begin Canonical_Case_File_Name (Suffix_Str); exit when Name_Buffer (Base_Main'Length + 1 .. Name_Len) = Suffix_Str; end; end if; end if; elsif Source.Kind = Spec and then Source.Language.Config.Kind = Unit_Based then -- An Ada spec needs to be taken into account unless there -- is also a body. So we delay the decision for them. Get_Name_String (Source.File); if Name_Len > Base_Main'Length and then Name_Buffer (1 .. Base_Main'Length) = Base_Main then Suffix := Source.Language.Config.Naming_Data.Spec_Suffix; if Suffix /= No_File then declare Suffix_Str : String := Get_Name_String (Suffix); begin Canonical_Case_File_Name (Suffix_Str); if Name_Buffer (Base_Main'Length + 1 .. Name_Len) = Suffix_Str then Spec_Source := Source; end if; end; end if; end if; end if; Next (Iter); end loop; if Source = No_Source then Source := Spec_Source; end if; return Source; end Find_File_Add_Extension; ----------------- -- Do_Complete -- ----------------- procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref) is J : Integer; begin if Mains.Number_Of_Mains (Tree) > 0 or else Mains.Count_Of_Mains_With_No_Tree > 0 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 turn. J := Names.Last_Index; Main_Loop : loop declare File : Main_Info := Names (J); Main_Id : File_Name_Type := File.File; Main : constant String := Get_Name_String (Main_Id); Base : constant String := Base_Name (Main); Source : GPR.Source_Id := No_Source; Absolute : array (Boolean) of File_Name_Type := (others => No_File); begin if Base /= Main then -- Keep 2 absolute path values with and without -- symbolic names resolution, so that users can -- specify any name on the command line. If the -- project itself uses links, the user will be using -- -eL anyway, and thus files are also stored with -- resolved names. for Links in Absolute'Range loop Absolute (Links) := Create_Name (Normalize_Pathname (Name => Main, Directory => "", Resolve_Links => Links, Case_Sensitive => False)); end loop; Main_Id := Create_Name (Base); end if; -- If no project or tree was specified for the main, it -- came from the command line. -- Note that the assignments below will not modify inside -- the table itself. if File.Project = null then File.Project := Project; end if; if File.Tree = null then File.Tree := Tree; end if; if File.Source = null then if Current_Verbosity = High then Debug_Output ("search for main """ & Main & '"' & File.Index'Img & " in " & Get_Name_String (Debug_Name (File.Tree)) & ", project", Project.Name); end if; -- First, look for the main as specified. We need to -- search for the base name though, and if needed -- check later that we found the correct file. declare Sources : constant Source_Ids := Find_All_Sources (In_Tree => File.Tree, Project => File.Project, Base_Name => Main_Id, Index => File.Index, In_Imported_Only => True); begin if Absolute (False) /= No_File then for S of Sources loop if File_Name_Type (S.Path.Name) in Absolute (False) | Absolute (True) then Source := S; File.File := File_Name_Type (S.Path.Name); exit; end if; end loop; elsif Sources'Length > 1 then -- This is only allowed if the units are from -- the same multi-unit source file. Source := Sources (1); for J in 2 .. Sources'Last loop if Sources (J).Path /= Source.Path or else Sources (J).Index = Source.Index then Error_Msg_File_1 := Main_Id; GPR.Err.Error_Msg (Flags, "several main sources {", No_Location, File.Project); exit Main_Loop; end if; end loop; elsif Sources'Length = 1 then Source := Sources (Sources'First); end if; end; if Source = No_Source then Source := Find_File_Add_Extension (File.Tree, Get_Name_String (Main_Id)); end if; if Absolute (False) /= No_File and then Source /= No_Source and then File_Name_Type (Source.Path.Name) /= File.File then Debug_Output ("Found a non-matching file", Name_Id (Source.Path.Display_Name)); Source := No_Source; end if; if Source /= No_Source then if not Is_Allowed_Language (Source.Language.Name) then -- Remove any main that is not in the list of -- restricted languages. Names.Delete (J); else -- If we have found a multi-unit source file but -- did not specify an index initially, we'll -- need to compile all the units from the same -- source file. if Source.Index /= 0 and then File.Index = 0 then Add_Multi_Unit_Sources (File.Tree, Source); end if; -- A main cannot be a source of a library -- project. if (not Opt.Compile_Only or else Opt.Bind_Only) and then not Unique_Compile and then Source.Project.Library then Error_Msg_File_1 := Main_Id; GPR.Err.Error_Msg (Flags, "main cannot be a source" & " of a library project: {", No_Location, File.Project); else -- Now update the original Main, otherwise it -- will be reported as not found. Debug_Output ("found main in project", Source.Project.Name); Names (J).File := Source.File; Names (J).Project := Source.Project; if Names (J).Tree = null then Names (J).Tree := File.Tree; Builder_Data (File.Tree).Number_Of_Mains := Builder_Data (File.Tree).Number_Of_Mains + 1; Mains.Count_Of_Mains_With_No_Tree := Mains.Count_Of_Mains_With_No_Tree - 1; end if; Names (J).Source := Source; Names (J).Index := Source.Index; end if; end if; elsif File.Location /= No_Location then -- If the main is declared in package Builder of -- the main project, report an error. If the main -- is on the command line, it may be a main from -- another project, so do nothing: if the main does -- not exist in another project, an error will be -- reported later. Error_Msg_File_1 := Main_Id; Error_Msg_Name_1 := File.Project.Name; GPR.Err.Error_Msg (Flags, "{ is not a source of project %%", File.Location, File.Project); end if; end if; end; J := J - 1; exit Main_Loop when J < Names.First_Index; end loop Main_Loop; end if; if Total_Errors_Detected > 0 then Fail_Program (Tree, "problems with main sources", Exit_Code => E_General); end if; end Do_Complete; -- Start of processing for Complete_Mains begin Complete_All (Root_Project, Project_Tree); for N of Names loop if N.Source = No_Source then Fail_Program (Project_Tree, '"' & Get_Name_String (N.File) & """ was not found in the sources of any project", Exit_Code => E_General); end if; end loop; end Complete_Mains; ------------ -- Delete -- ------------ procedure Delete is begin Names.Clear; Mains.Reset; end Delete; ----------------------- -- Fill_From_Project -- ----------------------- procedure Fill_From_Project (Root_Project : Project_Id; Project_Tree : Project_Tree_Ref) is procedure Add_Mains_From_Project (Project : Project_Id; Tree : Project_Tree_Ref); -- Add the main units from this project into Mains. -- This takes into account the aggregated projects ---------------------------- -- Add_Mains_From_Project -- ---------------------------- procedure Add_Mains_From_Project (Project : Project_Id; Tree : Project_Tree_Ref) is List : String_List_Id; Element : String_Element; begin if Number_Of_Mains (Tree) = 0 and then Mains.Count_Of_Mains_With_No_Tree = 0 then Debug_Output ("Add_Mains_From_Project", Project.Name); List := Project.Mains; if List /= GPR.Nil_String then -- The attribute Main is not an empty list. Get the mains in -- the list. while List /= GPR.Nil_String loop Element := Tree.Shared.String_Elements.Table (List); Debug_Output ("Add_Main", Element.Value); if Project.Library then Fail_Program (Tree, "cannot specify a main program " & "for a library project file"); end if; Add_Main (Name => Get_Name_String (Element.Value), Index => Element.Index, Location => Element.Location, Project => Project, Tree => Tree); List := Element.Next; end loop; end if; end if; if Total_Errors_Detected > 0 then Fail_Program (Tree, "problems with main sources"); end if; end Add_Mains_From_Project; procedure Fill_All is new For_Project_And_Aggregated (Add_Mains_From_Project); -- Start of processing for Fill_From_Project begin Fill_All (Root_Project, Project_Tree); end Fill_From_Project; --------------- -- Next_Main -- --------------- function Next_Main return String is Info : constant Main_Info := Next_Main; begin if Info = No_Main_Info then return ""; else return Get_Name_String (Info.File); end if; end Next_Main; function Next_Main return Main_Info is begin if Current >= Names.Last_Index then return No_Main_Info; else Current := Current + 1; return Names (Current); end if; end Next_Main; --------------------- -- Number_Of_Mains -- --------------------- function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is begin if Tree = null then return Names.Last_Index; else return Builder_Data (Tree).Number_Of_Mains; end if; end Number_Of_Mains; ----------- -- Reset -- ----------- procedure Reset is begin Current := 0; end Reset; -------------------------- -- Set_Multi_Unit_Index -- -------------------------- procedure Set_Multi_Unit_Index (Project_Tree : Project_Tree_Ref := null; Index : Int := 0) is begin if Index /= 0 then if Names.Last_Index = 0 then Fail_Program (Project_Tree, "cannot specify a multi-unit index but no main on the" & " command line", Exit_Code => E_General); elsif Names.Last_Index > 1 then Fail_Program (Project_Tree, "cannot specify several mains with a multi-unit index", Exit_Code => E_General); else Names (Names.Last_Index).Index := Index; end if; end if; end Set_Multi_Unit_Index; end Mains; ----------------------- -- Path_Or_File_Name -- ----------------------- function Path_Or_File_Name (Path : Path_Name_Type) return String is Path_Name : constant String := Get_Name_String (Path); begin if Debug.Debug_Flag_F then return File_Name (Path_Name); else return Path_Name; end if; end Path_Or_File_Name; ----------------- -- Verbose_Msg -- ----------------- procedure Verbose_Msg (N1 : Name_Id; S1 : String; N2 : Name_Id := No_Name; S2 : String := ""; Prefix : String := " -> "; Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) is begin if not Opt.Verbose_Mode or else Minimum_Verbosity > Opt.Verbosity_Level then return; end if; Put (Prefix); Put (""""); Put (Get_Name_String (N1)); Put (""" "); Put (S1); if N2 /= No_Name then Put (" """); Put (Get_Name_String (N2)); Put (""" "); end if; Put (S2); New_Line; end Verbose_Msg; ----------- -- Queue -- ----------- package body Queue is type Q_Record is record Info : Source_Info; Processed : Boolean; end record; package Q is new GNAT.Table (Table_Component_Type => Q_Record, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 1000, Table_Increment => 100); -- This is the actual Queue package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Path_Name_Type, Hash => Hash, Equal => "="); Q_Processed : Natural := 0; Q_Initialized : Boolean := False; Q_First : Natural := 1; -- Points to the first valid element in the queue Q_Prev_First : Natural := 1; -- Points to the previous first valid element in the queue One_Queue_Per_Obj_Dir : Boolean := False; -- See parameter to Initialize function Available_Obj_Dir (S : Source_Info) return Boolean; -- Whether the object directory for S is available for a build procedure Debug_Display (S : Source_Info); -- A debug display for S function Insert_No_Roots (Source : Source_Info; Repeat : Boolean := False) return Boolean; -- Insert Source, but do not look for its roots (see doc for Insert). -- If Repeat is True the source inserted even if it was ----------------------- -- Available_Obj_Dir -- ----------------------- function Available_Obj_Dir (S : Source_Info) return Boolean is begin return not Busy_Obj_Dirs.Get (S.Id.Project.Object_Directory.Name); end Available_Obj_Dir; ------------------- -- Debug_Display -- ------------------- procedure Debug_Display (S : Source_Info) is begin Put (Get_Name_String (S.Id.File)); if S.Id.Index /= 0 then Put (","); Put (S.Id.Index'Img); end if; end Debug_Display; ------------- -- Extract -- ------------- procedure Extract (Found : out Boolean; Source : out Source_Info) is begin Found := False; if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then Found := True; Source := Q.Table (J).Info; Q.Table (J).Processed := True; if J = Q_First then while Q_First <= Q.Last and then Q.Table (Q_First).Processed loop Q_First := Q_First + 1; end loop; end if; exit; end if; end loop; elsif Q_First <= Q.Last then Source := Q.Table (Q_First).Info; Q.Table (Q_First).Processed := True; Q_First := Q_First + 1; Found := True; end if; if Found then Q_Processed := Q_Processed + 1; end if; if Found and then Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q - [ "); Debug_Display (Source); Ada.Text_IO.Put (" ]"); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Extract; --------- -- Get -- --------- procedure Get (Found : out Boolean; Source : out Source_Info) is begin Found := False; if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then Found := True; Source := Q.Table (J).Info; if Q_First /= J then Q_Prev_First := Q_First; end if; Q_First := J; exit; end if; end loop; elsif Q_First <= Q.Last then Source := Q.Table (Q_First).Info; Found := True; end if; if Found and then Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q = [ "); Debug_Display (Source); Ada.Text_IO.Put (" ]"); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q_Prev_First ="); Ada.Text_IO.Put (Q_Prev_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Get; ---------- -- Next -- ---------- procedure Next is begin Q.Table (Q_First).Processed := True; Q_Processed := Q_Processed + 1; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q - [ "); Debug_Display (Q.Table (Q_First).Info); Ada.Text_IO.Put (" ]"); New_Line; end if; if One_Queue_Per_Obj_Dir and then Q_First /= Q_Prev_First then Q_First := Q_Prev_First; while Q_First <= Q.Last and then Q.Table (Q_First).Processed loop Q_First := Q_First + 1; end loop; Q_Prev_First := Q_First; else Q_First := Q_First + 1; Q_Prev_First := Q_First; end if; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q_Prev_First ="); Ada.Text_IO.Put (Q_Prev_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Next; --------------- -- Processed -- --------------- function Processed return Natural is begin return Q_Processed; end Processed; ---------------- -- Initialize -- ---------------- procedure Initialize (Queue_Per_Obj_Dir : Boolean; Force : Boolean := False) is begin if Force or else not Q_Initialized then Q_Initialized := True; for J in 1 .. Q.Last loop Q.Table (J).Info.Id.In_The_Queue := False; end loop; Q.Init; Q_Processed := 0; Q_First := 1; One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; end if; end Initialize; --------------------- -- Insert_No_Roots -- --------------------- function Insert_No_Roots (Source : Source_Info; Repeat : Boolean := False) return Boolean is begin pragma Assert (Source.Id /= No_Source); -- Only insert in the Q if it is not already done, to avoid -- simultaneous compilations if -jnnn is used. if not Repeat and then Source.Id.In_The_Queue then return False; end if; -- Check if a source has already been inserted in the queue from the -- same project in a different project tree. for J in (if Repeat then Q_First + 1 else 1) .. Q.Last loop if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name and then Source.Id.Index = Q.Table (J).Info.Id.Index and then Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name = Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project). Path.Name then -- No need to insert this source in the queue, but still -- return True as we may need to insert its roots. return True; end if; end loop; if Current_Verbosity = High then Put ("Adding """); Debug_Display (Source); Put_Line (""" to the queue"); end if; Q.Append (New_Val => (Info => Source, Processed => False)); Source.Id.In_The_Queue := True; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q + [ "); Debug_Display (Source); Ada.Text_IO.Put (" ] "); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; return True; end Insert_No_Roots; ------------ -- Insert -- ------------ function Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False) return Boolean is Root_Arr : Array_Element_Id; Roots : Variable_Value; List : String_List_Id; Elem : String_Element; Unit_Name : Name_Id; Pat_Root : Boolean; Root_Pattern : Regexp; Root_Found : Boolean; Roots_Found : Boolean; Root_Source : GPR.Source_Id; Iter : Source_Iterator; Dummy : Boolean; begin if not Insert_No_Roots (Source, Repeat) then -- Was already in the queue return False; end if; if With_Roots then Debug_Output ("looking for roots of", Name_Id (Source.Id.File)); Root_Arr := GPR.Util.Value_Of (Name => Name_Roots, In_Arrays => Source.Id.Project.Decl.Arrays, Shared => Source.Tree.Shared); Roots := GPR.Util.Value_Of (Index => Name_Id (Source.Id.File), Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared); -- If there is no roots for the specific main, try the language if Roots = Nil_Variable_Value then Roots := GPR.Util.Value_Of (Index => Source.Id.Language.Name, Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared, Force_Lower_Case_Index => True); end if; -- Then try "*" if Roots = Nil_Variable_Value then Roots := GPR.Util.Value_Of (Index => The_Star_String, Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared, Force_Lower_Case_Index => True); end if; if Roots = Nil_Variable_Value then Debug_Output (" -> no roots declared"); else List := Roots.Values; -- case of empty root list if List = Nil_String then Source.Id.Roots := new Source_Roots' (Root => No_Source, Next => null); end if; Pattern_Loop : while List /= Nil_String loop Elem := Source.Tree.Shared.String_Elements.Table (List); Get_Name_String (Elem.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Unit_Name := Name_Find; -- Check if it is a unit name or a pattern Pat_Root := False; for J in 1 .. Name_Len loop if Name_Buffer (J) not in 'a' .. 'z' | '0' .. '9' | '_' | '.' then Pat_Root := True; exit; end if; end loop; if Pat_Root then begin Root_Pattern := Compile (Pattern => Name_Buffer (1 .. Name_Len), Glob => True); exception when Error_In_Regexp => Error_Msg_Name_1 := Unit_Name; Error_Msg ("invalid pattern %", Roots.Location); exit Pattern_Loop; end; end if; Roots_Found := False; Iter := For_Each_Source (Source.Tree); Source_Loop : loop Root_Source := GPR.Element (Iter); exit Source_Loop when Root_Source = No_Source; Root_Found := False; if Pat_Root then Root_Found := Root_Source.Unit /= No_Unit_Index and then Match (Get_Name_String (Root_Source.Unit.Name), Root_Pattern); else Root_Found := Root_Source.Unit /= No_Unit_Index and then Root_Source.Unit.Name = Unit_Name; end if; if Root_Found then case Root_Source.Kind is when Impl => null; when Spec => Root_Found := Other_Part (Root_Source) = No_Source; when Sep => Root_Found := False; end case; end if; if Root_Found then Roots_Found := True; Debug_Output (" -> ", Name_Id (Root_Source.Display_File)); Dummy := Queue.Insert_No_Roots (Source => (Tree => Source.Tree, Id => Root_Source, Closure => False)); Initialize_Source_Record (Root_Source); if Other_Part (Root_Source) /= No_Source then Initialize_Source_Record (Other_Part (Root_Source)); end if; -- Save the root for the binder Source.Id.Roots := new Source_Roots' (Root => Root_Source, Next => Source.Id.Roots); exit Source_Loop when not Pat_Root; end if; Next (Iter); end loop Source_Loop; if not Roots_Found then if Pat_Root then if not Quiet_Output then Error_Msg_Name_1 := Unit_Name; Error_Msg ("?no unit matches pattern %", Roots.Location); end if; else Error_Msg ("Unit " & Get_Name_String (Unit_Name) & " does not exist", Roots.Location); end if; end if; List := Elem.Next; end loop Pattern_Loop; end if; end if; return True; end Insert; ------------ -- Insert -- ------------ procedure Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False) is Discard : Boolean; begin Discard := Insert (Source, With_Roots, Repeat); end Insert; -------------- -- Is_Empty -- -------------- function Is_Empty return Boolean is begin return Q_Processed >= Q.Last; end Is_Empty; ------------------------ -- Is_Virtually_Empty -- ------------------------ function Is_Virtually_Empty return Boolean is begin if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then return False; end if; end loop; return True; else return Is_Empty; end if; end Is_Virtually_Empty; ---------------------- -- Set_Obj_Dir_Busy -- ---------------------- procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is begin if One_Queue_Per_Obj_Dir then Busy_Obj_Dirs.Set (Obj_Dir, True); end if; end Set_Obj_Dir_Busy; ---------------------- -- Set_Obj_Dir_Free -- ---------------------- procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is begin if One_Queue_Per_Obj_Dir then Busy_Obj_Dirs.Set (Obj_Dir, False); end if; end Set_Obj_Dir_Free; ---------- -- Size -- ---------- function Size return Natural is begin return Q.Last; end Size; ------------- -- Element -- ------------- function Element (Rank : Positive) return File_Name_Type is begin if Rank <= Q.Last then return Q.Table (Rank).Info.Id.File; else return No_File; end if; end Element; ---------------------------- -- Insert_Project_Sources -- ---------------------------- procedure Insert_Project_Sources (Project : Project_Id; Project_Tree : Project_Tree_Ref; All_Projects : Boolean; Unique_Compile : Boolean) is procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context); -- Insert appropriate project sources into compilation queue --------------- -- Do_Insert -- --------------- procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context) is Unit_Based : constant Boolean := Unique_Compile or else not Builder_Data (Tree).Closure_Needed; -- When Unit_Based is True, we enqueue all compilable sources -- including the unit based (Ada) one. When Unit_Based is False, -- put the Ada sources only when they are in a library project. Iter : Source_Iterator; Source : GPR.Source_Id; OK : Boolean; Closure : Boolean; Proj : Project_Id; Location : Source_Ptr; function String_List_Contains (List : String_List_Id; Item : File_Name_Type) return Boolean; -- Returns True if Item is in the List -------------------------- -- String_List_Contains -- -------------------------- function String_List_Contains (List : String_List_Id; Item : File_Name_Type) return Boolean is Iterate : String_List_Id := List; Element : String_Element; begin while Iterate /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (Iterate); if Element.Value = Name_Id (Item) then return True; end if; Iterate := Element.Next; end loop; return False; end String_List_Contains; begin -- Nothing to do when "-u" was specified and some files were -- specified on the command line if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then return; end if; Iter := For_Each_Source (Tree); loop Source := GPR.Element (Iter); exit when Source = No_Source; Proj := Ultimate_Extending_Project_Of (Source.Project); if not Proj.Externally_Built then -- Fail if no compiler if Is_Allowed_Language (Source.Language.Name) and then Source.Language.Config.Compiler_Driver = No_File then -- Always provide a non null location if Source.Location = No_Location then Location := Source.Project.Location; else Location := Source.Location; end if; Error_Msg_Name_1 := Source.Language.Display_Name; Error_Msg_File_1 := Source.File; Error_Msg ("no compiler for language %%, cannot compile {{", Flag_Location => Location); Compilation_Phase_Failed (Project_Tree); end if; if Is_Allowed_Language (Source.Language.Name) and then Is_Compilable (Source) and then (All_Projects or else Is_Extending (Project, Source.Project)) and then not Source.Locally_Removed and then Source.Replaced_By = No_Source and then Source.Kind /= Sep and then Source.Path /= No_Path_Information then if Source.Kind = Impl or else (Source.Unit /= No_Unit_Index and then Source.Kind = Spec and then (Other_Part (Source) = No_Source or else Other_Part (Source).Locally_Removed)) then if (Unit_Based or else Source.Unit = No_Unit_Index or else Proj.Library or else Context.In_Aggregate_Lib or else Project.Qualifier = Aggregate_Library) and then not Is_Subunit (Source) then OK := True; Closure := False; if (Proj.Library or else Project.Qualifier = Aggregate_Library or else Context.In_Aggregate_Lib) and then Source.Project.Standalone_Library /= No then -- Check if the source is in the interface if Source.Unit = No_Unit_Index then OK := True; Closure := String_List_Contains (Source.Project.Other_Interfaces, Source.File); else OK := String_List_Contains (Source.Project.Lib_Interface_ALIs, Source.Dep_Name); Closure := OK; end if; end if; if OK then Queue.Insert (Source => (Tree => Tree, Id => Source, Closure => Closure), With_Roots => Closure); end if; end if; end if; end if; end if; Next (Iter); end loop; end Do_Insert; procedure Insert_All is new For_Project_And_Aggregated_Context (Do_Insert); begin Insert_All (Project, Project_Tree); end Insert_Project_Sources; ------------------------------- -- Insert_Withed_Sources_For -- ------------------------------- procedure Insert_Withed_Sources_For (The_ALI : ALI.ALI_Id; Project_Tree : Project_Tree_Ref; Excluding_Shared_SALs : Boolean := False) is Sfile : File_Name_Type; Afile : File_Name_Type; Src_Id : GPR.Source_Id; begin -- Insert in the queue the unmarked source files (i.e. those which -- have never been inserted in the queue and hence never considered). 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 Sfile := ALI.Withs.Table (K).Sfile; -- Skip generics if Sfile /= No_File then Afile := ALI.Withs.Table (K).Afile; Src_Id := Source_Files_Htable.Get (Project_Tree.Source_Files_HT, Sfile); while Src_Id /= No_Source loop Initialize_Source_Record (Src_Id); if Is_Compilable (Src_Id) and then Src_Id.Dep_Name = Afile then case Src_Id.Kind is when Spec => declare Bdy : constant GPR.Source_Id := Other_Part (Src_Id); begin if Bdy /= No_Source and then not Bdy.Locally_Removed then Src_Id := Other_Part (Src_Id); end if; end; when Impl => if Is_Subunit (Src_Id) then Src_Id := No_Source; end if; when Sep => Src_Id := No_Source; end case; exit; end if; Src_Id := Src_Id.Next_With_File_Name; end loop; -- If Excluding_Shared_SALs is True, do not insert in the -- queue the sources of a shared Stand-Alone Library. if Src_Id /= No_Source and then (not Excluding_Shared_SALs or else Src_Id.Project.Standalone_Library = No or else Src_Id.Project.Library_Kind = Static) then Queue.Insert (Source => (Tree => Project_Tree, Id => Src_Id, Closure => True)); end if; end if; end loop; end loop; end Insert_Withed_Sources_For; end Queue; ---------- -- Free -- ---------- procedure Free (Data : in out Builder_Project_Tree_Data) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Binding_Data_Record, Binding_Data); TmpB, Binding : Binding_Data := Data.Binding; begin while Binding /= null loop TmpB := Binding.Next; Unchecked_Free (Binding); Binding := TmpB; end loop; end Free; ------------------ -- Builder_Data -- ------------------ function Builder_Data (Tree : Project_Tree_Ref) return Builder_Data_Access is begin if Tree.Appdata = null then Tree.Appdata := new Builder_Project_Tree_Data; end if; return Builder_Data_Access (Tree.Appdata); end Builder_Data; -------------------------------- -- Compute_Compilation_Phases -- -------------------------------- procedure Compute_Compilation_Phases (Tree : Project_Tree_Ref; Root_Project : Project_Id; Option_Unique_Compile : Boolean := False; -- Was "-u" specified ? Option_Compile_Only : Boolean := False; -- Was "-c" specified ? Option_Bind_Only : Boolean := False; Option_Link_Only : Boolean := False) is procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref); ---------------- -- Do_Compute -- ---------------- procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is Data : constant Builder_Data_Access := Builder_Data (Tree); All_Phases : constant Boolean := not Option_Compile_Only and then not Option_Bind_Only and then not Option_Link_Only; -- Whether the command line asked for all three phases. Depending on -- the project settings, we might still disable some of the phases. Has_Mains : constant Boolean := Data.Number_Of_Mains > 0; -- Whether there are some main units defined for this project tree -- (either from one of the projects, or from the command line) begin if Option_Unique_Compile then -- If -u or -U is specified on the command line, disregard any -c, -- -b or -l switch: only perform compilation. Data.Closure_Needed := False; Data.Need_Compilation := True; Data.Need_Binding := False; Data.Need_Linking := False; else Data.Closure_Needed := Has_Mains or else (Root_Project.Library and then Root_Project.Standalone_Library /= No); Data.Need_Compilation := All_Phases or Option_Compile_Only; Data.Need_Binding := All_Phases or Option_Bind_Only; Data.Need_Linking := (All_Phases or Option_Link_Only) and Has_Mains; end if; if Current_Verbosity = High then Debug_Output ("compilation phases: " & " compile=" & Data.Need_Compilation'Img & " bind=" & Data.Need_Binding'Img & " link=" & Data.Need_Linking'Img & " closure=" & Data.Closure_Needed'Img & " mains=" & Data.Number_Of_Mains'Img, Project.Name); end if; end Do_Compute; procedure Compute_All is new For_Project_And_Aggregated (Do_Compute); begin Compute_All (Root_Project, Tree); end Compute_Compilation_Phases; ------------------------------ -- Compute_Builder_Switches -- ------------------------------ procedure Compute_Builder_Switches (Project_Tree : Project_Tree_Ref; Env : GPR.Tree.Environment; Main_Project : Project_Id; Only_For_Lang : Name_Id := No_Name) is Builder_Package : constant Package_Id := Value_Of (Name_Builder, Main_Project.Decl.Packages, Project_Tree.Shared); Global_Compilation_Array : Array_Element_Id := No_Array_Element; Global_Compilation_Elem : Array_Element; Global_Compilation_Switches : Variable_Value; Default_Switches_Array : Array_Id; Builder_Switches_Lang : Name_Id := No_Name; List : String_List_Id; Element : String_Element; Index : Name_Id; Source : GPR.Source_Id; Lang : Name_Id := No_Name; -- language index for Switches Switches_For_Lang : Variable_Value := Nil_Variable_Value; -- Value of Builder'Default_Switches(lang) Name : Name_Id := No_Name; -- main file index for Switches Switches_For_Main : Variable_Value := Nil_Variable_Value; -- Switches for a specific main. When there are several mains, Name is -- set to No_Name, and Switches_For_Main might be left with an actual -- value (so that we can display a warning that it was ignored). Other_Switches : Variable_Value := Nil_Variable_Value; -- Value of Builder'Switches(others) Defaults : Variable_Value := Nil_Variable_Value; Switches : Variable_Value := Nil_Variable_Value; -- The computed builder switches Success : Boolean := False; begin if Builder_Package /= No_Package then Global_Compilation_Array := Value_Of (Name => Name_Global_Compilation_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays, Shared => Project_Tree.Shared); if Main_Project.Qualifier = Aggregate or else Main_Project.Qualifier = Aggregate_Library then Other_Switches := GPR.Util.Value_Of (Name => All_Other_Names, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared); else Mains.Reset; -- If there is no main, and there is only one compilable language, -- use this language as the switches index. if Mains.Number_Of_Mains (Project_Tree) = 0 then if Only_For_Lang = No_Name then declare Language : Language_Ptr := Main_Project.Languages; begin while Language /= No_Language_Index loop if Language.Config.Compiler_Driver not in No_File | Empty_File then if Lang /= No_Name then Lang := No_Name; exit; else Lang := Language.Name; end if; end if; Language := Language.Next; end loop; end; else Lang := Only_For_Lang; end if; else for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop Source := Mains.Next_Main.Source; if Source /= No_Source then if Switches_For_Main = Nil_Variable_Value then Switches_For_Main := Value_Of (Name => Name_Id (Source.File), Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => False, Allow_Wildcards => True); -- If not found, try without extension. -- That's because gnatmake accepts truncated file -- names in Builder'Switches if Switches_For_Main = Nil_Variable_Value and then Source.Unit /= null then Switches_For_Main := Value_Of (Name => Source.Unit.Name, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => False, Allow_Wildcards => True); end if; end if; if Index = 1 then Lang := Source.Language.Name; Name := Name_Id (Source.File); else Name := No_Name; -- Can't use main specific switches if Lang /= Source.Language.Name then Lang := No_Name; end if; end if; end if; end loop; end if; Default_Switches_Array := Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays; while Default_Switches_Array /= No_Array and then Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /= Name_Default_Switches loop Default_Switches_Array := Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next; end loop; if Lang /= No_Name then Switches_For_Lang := GPR.Util.Value_Of (Name => Lang, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); Defaults := GPR.Util.Value_Of (Name => Lang, Index => 0, Attribute_Or_Array_Name => Name_Default_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; Other_Switches := GPR.Util.Value_Of (Name => All_Other_Names, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared); if not Quiet_Output and then Mains.Number_Of_Mains (Project_Tree) > 1 and then Switches_For_Main /= Nil_Variable_Value then -- More than one main, but we had main-specific switches that -- are ignored. if Switches_For_Lang /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Switches(""" & Get_Name_String (Lang) & """), as there are several mains"); elsif Other_Switches /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Switches(others), " & "as there are several mains"); elsif Defaults /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Default_Switches(""" & Get_Name_String (Lang) & """), as there are several mains"); else Put_Line ("Warning: using no switches from package " & "Builder, as there are several mains"); end if; end if; end if; Builder_Switches_Lang := Lang; if Name /= No_Name then -- Get the switches for the single main Switches := Switches_For_Main; end if; if Switches = Nil_Variable_Value or else Switches.Default then -- Get the switches for the common language of the mains Switches := Switches_For_Lang; end if; if Switches = Nil_Variable_Value or else Switches.Default then Switches := Other_Switches; end if; -- For backward compatibility with gnatmake, if no Switches -- are declared, check for Default_Switches (). if Switches = Nil_Variable_Value or else Switches.Default then Switches := Defaults; end if; -- If switches have been found, scan them if Switches /= Nil_Variable_Value and then not Switches.Default then List := Switches.Values; while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); Get_Name_String (Element.Value); if Name_Len /= 0 then declare -- Add_Switch might itself be using the name_buffer, so -- we make a temporary here. Switch : constant String := Name_Buffer (1 .. Name_Len); begin Success := Add_Switch (Switch => Switch, For_Lang => Builder_Switches_Lang, For_Builder => True, Has_Global_Compilation_Switches => Global_Compilation_Array /= No_Array_Element); end; if not Success then for J in reverse 1 .. Name_Len loop Name_Buffer (J + J) := Name_Buffer (J); Name_Buffer (J + J - 1) := '''; end loop; Name_Len := Name_Len + Name_Len; GPR.Err.Error_Msg (Env.Flags, '"' & Name_Buffer (1 .. Name_Len) & """ is not a builder switch. Consider moving " & "it to Global_Compilation_Switches.", Element.Location); Fail_Program (Project_Tree, "*** illegal switch """ & Get_Name_String (Element.Value) & '"', Exit_Code => E_General); end if; end if; List := Element.Next; end loop; end if; -- Reset the Builder Switches language Builder_Switches_Lang := No_Name; -- Take into account attributes Global_Compilation_Switches while Global_Compilation_Array /= No_Array_Element loop Global_Compilation_Elem := Project_Tree.Shared.Array_Elements.Table (Global_Compilation_Array); Get_Name_String (Global_Compilation_Elem.Index); To_Lower (Name_Buffer (1 .. Name_Len)); Index := Name_Find; if Only_For_Lang = No_Name or else Index = Only_For_Lang then Global_Compilation_Switches := Global_Compilation_Elem.Value; if Global_Compilation_Switches /= Nil_Variable_Value and then not Global_Compilation_Switches.Default then -- We have found an attribute -- Global_Compilation_Switches for a language: put the -- switches in the appropriate table. List := Global_Compilation_Switches.Values; while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); if Element.Value /= No_Name then Success := Add_Switch (Switch => Get_Name_String (Element.Value), For_Lang => Index, For_Builder => False, Has_Global_Compilation_Switches => Global_Compilation_Array /= No_Array_Element); end if; List := Element.Next; end loop; end if; end if; Global_Compilation_Array := Global_Compilation_Elem.Next; end loop; end if; end Compute_Builder_Switches; -------------- -- Unescape -- -------------- function Unescape (Path : String) return String is Result : String (Path'Range); Source : Natural := Path'First; Target : Integer := Path'First - 1; begin while Source <= Path'Last loop if Source < Path'Last and then Path (Source .. Source + 1) in "\\" | "\#" | "\ " | "\:" | "$$" then Source := Source + 1; end if; Target := Target + 1; Result (Target) := Path (Source); Source := Source + 1; end loop; return Result (Path'First .. Target); end Unescape; --------------------- -- Write_Path_File -- --------------------- procedure Write_Path_File (FD : File_Descriptor) is Last : Natural; Status : Boolean; begin Name_Len := 0; for Index in Directories.First .. Directories.Last loop Get_Name_String_And_Append (Directories.Table (Index)); Add_Char_To_Name_Buffer (ASCII.LF); end loop; Last := Write (FD, Name_Buffer (1)'Address, Name_Len); if Last = Name_Len then Close (FD, Status); else Status := False; end if; if not Status then GPR.Com.Fail ("could not write temporary file"); end if; end Write_Path_File; end Gpr_Build_Util;