------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, 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.Calendar; with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Ordered_Sets; with Ada.Containers.Vectors; with Ada.Directories; use Ada.Directories; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Text_IO; use Ada.Text_IO; with Ada.Streams.Stream_IO; use Ada.Streams; with Ada.Exceptions; with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.HTable; with GNAT.Regexp; use GNAT.Regexp; with GNAT.Table; with GNAT.Calendar; use GNAT.Calendar; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Interfaces.C.Strings; with System; use System; with GPR.ALI; use GPR.ALI; with GPR.Com; with GPR.Conf; with GPR.Debug; with GPR.Env; with GPR.Err; with GPR.Jobserver; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; with GPR.Sdefault; with GPR.Sinput; with GPR.Snames; use GPR.Snames; with GPR.Version; use GPR.Version; with Gpr_Build_Util; use Gpr_Build_Util; package body GPR.Util is use Ada.Containers; Program_Name : String_Access := null; type File_Stamp_Record is record Known : Boolean := False; TS : Time_Stamp_Type := Empty_Time_Stamp; end record; Unknow_File_Stamp : constant File_Stamp_Record := (False, Empty_Time_Stamp); package File_Stamp_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => File_Stamp_Record, No_Element => Unknow_File_Stamp, Key => Path_Name_Type, Hash => GPR.Hash, Equal => "="); -- A hash table to cache time stamps of files package Source_Info_Table is new GNAT.Table (Table_Component_Type => Source_Info_Iterator, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Natural, No_Element => 0, Key => Name_Id, Hash => GPR.Hash, Equal => "="); procedure Free is new Ada.Unchecked_Deallocation (Text_File_Data, Text_File); package Processed_ALIs is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => GPR.Hash, Equal => "="); True_Checksum : constant File_Name_Type := File_Name_Type (First_Name_Id); -- Special constant to declare that checksum in Source record is calculated -- from source file content. function To_Path_String_Access (Path_Addr : Address; Path_Len : Integer) return String_Access; -- Converts a C String to an Ada String. function Locate_Directory (Dir_Name : C_File_Name; Path : C_File_Name) return String_Access; function C_String_Length (S : Address) return Integer; -- Returns the length of C (null-terminated) string at S, or 0 for -- Null_Address. function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type; -- Get the time stamp of Path. Take it from File_Stamp_HTable if it is -- already there, otherwise get it from OS and put into File_Stamp_HTable -- to be able to get it next time. --------------------- -- C_String_Length -- --------------------- function C_String_Length (S : Address) return Integer is function strlen (A : Address) return size_t; pragma Import (Intrinsic, strlen, "strlen"); begin if S = Null_Address then return 0; else return Integer (strlen (S)); end if; end C_String_Length; ------------------------ -- Calculate_Checksum -- ------------------------ function Calculate_Checksum (Source : Source_Id) return Boolean is Source_Index : Source_File_Index; begin if Source.Checksum_Src = True_Checksum then -- Checksum already calculated return True; end if; Source_Index := Sinput.Load_File (Get_Name_String (Source.Path.Display_Name)); if Source_Index /= No_Source_File then Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada); -- Scan the complete file to compute its -- checksum. loop Err.Scanner.Scan; exit when Token = Tok_EOF; end loop; Source.Checksum := Scans.Checksum; Source.Checksum_Src := True_Checksum; -- If there were errors we can't Clear_Source_File_Table because the -- error messages refer to this table content. if Total_Errors_Detected = 0 then -- To avoid using too much memory, free the -- memory allocated. Sinput.Clear_Source_File_Table; end if; return True; end if; return False; end Calculate_Checksum; ------------------------ -- Calculate_Checksum -- ------------------------ function Calculate_Checksum (File : Path_Name_Type) return Word is Source_Index : Source_File_Index; Checksum : Word := 0; begin Source_Index := Sinput.Load_File (Get_Name_String (File)); if Source_Index /= No_Source_File then Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada); -- Scan the complete file to compute its -- checksum. loop Err.Scanner.Scan; exit when Token = Tok_EOF; end loop; Checksum := Scans.Checksum; -- If there were errors we can't Clear_Source_File_Table because the -- error messages refer to this table content. if Total_Errors_Detected = 0 then -- To avoid using too much memory, free the -- memory allocated. Sinput.Clear_Source_File_Table; end if; return Checksum; end if; return Checksum; end Calculate_Checksum; ---------------------------- -- Clear_Time_Stamp_Cache -- ---------------------------- procedure Clear_Time_Stamp_Cache is begin File_Stamp_HTable.Reset; end Clear_Time_Stamp_Cache; ---------------- -- File_Stamp -- ---------------- function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type is begin if Path = No_Path then return Empty_Time_Stamp; else declare FSR : File_Stamp_Record := File_Stamp_HTable.Get (Path); begin if FSR.Known then return FSR.TS; else declare Result : constant Time_Stamp_Type := Osint.File_Stamp (Path); begin FSR := (True, Result); File_Stamp_HTable.Set (Path, FSR); return Result; end; end if; end; end if; end File_Stamp; ----------------------- -- Update_File_Stamp -- ----------------------- procedure Update_File_Stamp (Path : Path_Name_Type; Stamp : Time_Stamp_Type) is begin if Path = No_Path then null; else File_Stamp_HTable.Set (Path, (True, Stamp)); end if; end Update_File_Stamp; ---------------------- -- Locate_Directory -- ---------------------- function Locate_Directory (Dir_Name : C_File_Name; Path : C_File_Name) return String_Access is function Is_Dir (Name : Address) return Integer; pragma Import (C, Is_Dir, "__gnat_is_directory"); function Locate_File_With_Predicate (File_Name, Path_Val, Predicate : Address) return Address; pragma Import (C, Locate_File_With_Predicate, "__gnat_locate_file_with_predicate"); Result_Addr : Address; Result_Len : Integer; Result : String_Access := null; begin Result_Addr := Locate_File_With_Predicate (Dir_Name, Path, Is_Dir'Address); Result_Len := C_String_Length (Result_Addr); if Result_Len /= 0 then Result := To_Path_String_Access (Result_Addr, Result_Len); end if; return Result; end Locate_Directory; function Locate_Directory (Dir_Name : String; Path : String) return String_Access is C_Dir_Name : String (1 .. Dir_Name'Length + 1); C_Path : String (1 .. Path'Length + 1); Result : String_Access; begin C_Dir_Name (1 .. Dir_Name'Length) := Dir_Name; C_Dir_Name (C_Dir_Name'Last) := ASCII.NUL; C_Path (1 .. Path'Length) := Path; C_Path (C_Path'Last) := ASCII.NUL; Result := Locate_Directory (C_Dir_Name'Address, C_Path'Address); if Result /= null and then not Is_Absolute_Path (Result.all) then declare Absolute_Path : constant String := Normalize_Pathname (Result.all); begin Free (Result); Result := new String'(Absolute_Path); end; end if; return Result; end Locate_Directory; --------------------------- -- To_Path_String_Access -- --------------------------- function To_Path_String_Access (Path_Addr : Address; Path_Len : Integer) return String_Access is subtype Path_String is String (1 .. Path_Len); type Path_String_Access is access Path_String; function Address_To_Access is new Ada.Unchecked_Conversion (Source => Address, Target => Path_String_Access); Path_Access : constant Path_String_Access := Address_To_Access (Path_Addr); Return_Val : String_Access; begin Return_Val := new String (1 .. Path_Len); for J in 1 .. Path_Len loop Return_Val (J) := Path_Access (J); end loop; return Return_Val; end To_Path_String_Access; -------------- -- Closures -- -------------- type Project_And_Tree is record Project : Project_Id; Tree : Project_Tree_Ref; end record; function "<" (Left, Right : Project_And_Tree) return Boolean; package Projects_And_Trees_Sets is new Ada.Containers.Indefinite_Ordered_Sets (Element_Type => Project_And_Tree); type Main_Project_Tree is record Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref; end record; function "<" (Left, Right : Main_Project_Tree) return Boolean; package MPT_Sets is new Ada.Containers.Indefinite_Ordered_Sets (Element_Type => Main_Project_Tree); package File_Name_Vectors is new Ada.Containers.Vectors (Positive, File_Name_Type); subtype File_Names is File_Name_Vectors.Vector; package Path_Sets renames String_Sets; --------- -- "<" -- --------- function "<" (Left, Right : Project_And_Tree) return Boolean is begin return Left.Project.Name < Right.Project.Name; end "<"; function "<" (Left, Right : Main_Project_Tree) return Boolean is begin if Left.Project.Name /= Right.Project.Name then return Left.Project.Name < Right.Project.Name; else return Left.Main.File < Right.Main.File; end if; end "<"; ----------- -- Close -- ----------- procedure Close (File : in out Text_File) is Len : Integer; Status : Boolean; begin if File = null then GPR.Com.Fail ("Close attempted on an invalid Text_File"); end if; if File.Out_File then if File.Buffer_Len > 0 then Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); if Len /= File.Buffer_Len then GPR.Com.Fail ("Unable to write to an out Text_File"); end if; end if; Close (File.FD, Status); if not Status then GPR.Com.Fail ("Unable to close an out Text_File"); end if; else -- Close in file, no need to test status, since this is a file that -- we read, and the file was read successfully before we closed it. Close (File.FD); end if; Free (File); end Close; ------------------------------ -- Compilation_Phase_Failed -- ------------------------------ procedure Compilation_Phase_Failed (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Fatal; No_Message : Boolean := False) is begin Fail_Program (Project_Tree, "*** compilation phase failed", Exit_Code, No_Message => No_Message); end Compilation_Phase_Failed; ------------ -- Create -- ------------ procedure Create (File : out Text_File; Name : String) is FD : File_Descriptor; File_Name : String (1 .. Name'Length + 1); begin File_Name (1 .. Name'Length) := Name; File_Name (File_Name'Last) := ASCII.NUL; FD := Create_File (Name => File_Name'Address, Fmode => GNAT.OS_Lib.Text); if FD = Invalid_FD then File := null; else File := new Text_File_Data; File.FD := FD; File.Out_File := True; File.End_Of_File_Reached := True; end if; end Create; ------------------------------- -- Common_Path_Prefix_Length -- ------------------------------- function Common_Path_Prefix_Length (A, B : String) return Integer is Slash : Integer := A'First; -- At the last slash seen in A At_A : Integer := A'First; At_B : Integer := B'First; begin loop if At_A > A'Last then if At_B > B'Last or else B (At_B) = '/' then return A'Length; else return Slash - A'First; end if; elsif At_B > B'Last then if A (At_A) = '/' then -- A cannot be shorter than B here return B'Length; else return Slash - A'First; end if; elsif A (At_A) /= B (At_B) then return Slash - A'First; elsif A (At_A) = '/' then Slash := At_A; end if; At_A := At_A + 1; At_B := At_B + 1; end loop; end Common_Path_Prefix_Length; ------------------- -- Common_Prefix -- ------------------- function Common_Prefix (Pathname1, Pathname2 : String) return String is P1 : constant String := Normalize_Pathname (Pathname1); P2 : constant String := Normalize_Pathname (Pathname2); I1 : Positive := P1'First; I2 : Positive := P2'First; begin while I1 <= P1'Last and then I2 <= P2'Last and then P1 (I1) = P2 (I2) loop I1 := I1 + 1; I2 := I2 + 1; end loop; if I1 <= P1'Last or else I2 <= P2'Last then return P1 (P1'First .. I1 - 1); elsif I1 > P1'Last then return P2; else return P1; end if; end Common_Prefix; --------------- -- Duplicate -- --------------- procedure Duplicate (This : in out Name_List_Index; Shared : Shared_Project_Tree_Data_Access) is Old_Current : Name_List_Index; New_Current : Name_List_Index; begin if This /= No_Name_List then Old_Current := This; Name_List_Table.Increment_Last (Shared.Name_Lists); New_Current := Name_List_Table.Last (Shared.Name_Lists); This := New_Current; Shared.Name_Lists.Table (New_Current) := (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); loop Old_Current := Shared.Name_Lists.Table (Old_Current).Next; exit when Old_Current = No_Name_List; Shared.Name_Lists.Table (New_Current).Next := New_Current + 1; Name_List_Table.Increment_Last (Shared.Name_Lists); New_Current := New_Current + 1; Shared.Name_Lists.Table (New_Current) := (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); end loop; end if; end Duplicate; ----------------- -- End_Of_File -- ----------------- function End_Of_File (File : Text_File) return Boolean is begin if File = null then GPR.Com.Fail ("End_Of_File attempted on an invalid Text_File"); end if; return File.End_Of_File_Reached; end End_Of_File; ------------------- -- Executable_Of -- ------------------- function Executable_Of (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; Main : File_Name_Type; Index : Int; Language : String := ""; Include_Suffix : Boolean := True) return File_Name_Type is pragma Assert (Project /= No_Project); The_Packages : constant Package_Id := Project.Decl.Packages; Builder_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Builder, In_Packages => The_Packages, Shared => Shared); Executable : Variable_Value := GPR.Util.Value_Of (Name => Name_Id (Main), Index => Index, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Shared); Lang : Language_Ptr; Spec_Suffix : Name_Id := No_Name; Body_Suffix : Name_Id := No_Name; Spec_Suffix_Length : Natural := 0; Body_Suffix_Length : Natural := 0; procedure Get_Suffixes (B_Suffix : File_Name_Type; S_Suffix : File_Name_Type); -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix function Add_Suffix (File : File_Name_Type) return File_Name_Type; -- Return the name of the executable, based on File, and adding the -- executable suffix if needed ------------------ -- Get_Suffixes -- ------------------ procedure Get_Suffixes (B_Suffix : File_Name_Type; S_Suffix : File_Name_Type) is begin if B_Suffix /= No_File then Body_Suffix := Name_Id (B_Suffix); Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); end if; if S_Suffix /= No_File then Spec_Suffix := Name_Id (S_Suffix); Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); end if; end Get_Suffixes; ---------------- -- Add_Suffix -- ---------------- function Add_Suffix (File : File_Name_Type) return File_Name_Type is Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; Result : File_Name_Type; begin if Include_Suffix then if Project.Config.Executable_Suffix /= No_Name then Executable_Extension_On_Target := Project.Config.Executable_Suffix; end if; Result := Executable_Name (File); Executable_Extension_On_Target := Saved_EEOT; return Result; end if; return File; end Add_Suffix; -- Start of processing for Executable_Of begin if Language /= "" then Lang := Get_Language_From_Name (Project, Language); end if; if Lang /= null then Get_Suffixes (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); end if; if Builder_Package /= No_Package then if Executable = Nil_Variable_Value then Get_Name_String (Main); -- Try as index the name minus the implementation suffix or minus -- the specification suffix. declare Name : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Last : Positive := Name_Len; Truncated : Boolean := False; begin if Body_Suffix /= No_Name and then Last > Natural (Length_Of_Name (Body_Suffix)) and then Name (Last - Body_Suffix_Length + 1 .. Last) = Get_Name_String (Body_Suffix) then Truncated := True; Last := Last - Body_Suffix_Length; end if; if Spec_Suffix /= No_Name and then not Truncated and then Last > Spec_Suffix_Length and then Name (Last - Spec_Suffix_Length + 1 .. Last) = Get_Name_String (Spec_Suffix) then Truncated := True; Last := Last - Spec_Suffix_Length; end if; if Truncated then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name (1 .. Last); Executable := GPR.Util.Value_Of (Name => Name_Find, Index => 0, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Shared); end if; end; end if; -- If we have found an Executable attribute, return its value, -- possibly suffixed by the executable suffix. if Executable /= Nil_Variable_Value and then Executable.Value /= No_Name and then Length_Of_Name (Executable.Value) /= 0 then return Add_Suffix (File_Name_Type (Executable.Value)); end if; end if; Get_Name_String (Main); -- If there is a body suffix or a spec suffix, remove this suffix, -- otherwise remove any suffix ('.' followed by other characters), if -- there is one. if Body_Suffix /= No_Name and then Name_Len > Body_Suffix_Length and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = Get_Name_String (Body_Suffix) then -- Found the body termination, remove it Name_Len := Name_Len - Body_Suffix_Length; elsif Spec_Suffix /= No_Name and then Name_Len > Spec_Suffix_Length and then Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = Get_Name_String (Spec_Suffix) then -- Found the spec termination, remove it Name_Len := Name_Len - Spec_Suffix_Length; else -- Remove any suffix, if there is one Get_Name_String (Strip_Suffix (Main)); end if; return Add_Suffix (Name_Find); end Executable_Of; ---------------------------- -- Executable_Prefix_Path -- ---------------------------- function Executable_Prefix_Path return String is Exec_Name : constant String := Command_Name; function Get_Install_Dir (S : String) return String; -- S is the executable name preceded by the absolute or relative path, -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin" -- lies (in the example "C:\usr"). If the executable is not in a "bin" -- directory, return "". --------------------- -- Get_Install_Dir -- --------------------- function Get_Install_Dir (S : String) return String is Exec : String := Normalize_Pathname (S, Resolve_Links => True); Path_Last : Integer := 0; begin for J in reverse Exec'Range loop if Is_Directory_Separator (Exec (J)) then Path_Last := J - 1; exit; end if; end loop; if Path_Last >= Exec'First + 2 then To_Lower (Exec (Path_Last - 2 .. Path_Last)); end if; if Path_Last < Exec'First + 2 or else Exec (Path_Last - 2 .. Path_Last) /= "bin" or else (Path_Last - 3 >= Exec'First and then not Is_Directory_Separator (Exec (Path_Last - 3))) then return ""; end if; return (Exec (Exec'First .. Path_Last - 4)) & Directory_Separator; end Get_Install_Dir; -- Beginning of Executable_Prefix_Path begin -- First determine if a path prefix was placed in front of the -- executable name. for J in reverse Exec_Name'Range loop if Is_Directory_Separator (Exec_Name (J)) then return Get_Install_Dir (Exec_Name); end if; end loop; -- If we get here, the user has typed the executable name with no -- directory prefix. declare Path : String_Access := Locate_Exec_On_Path (Exec_Name); begin if Path = null then return ""; else declare Dir : constant String := Get_Install_Dir (Path.all); begin Free (Path); return Dir; end; end if; end; end Executable_Prefix_Path; ------------ -- Expect -- ------------ procedure Expect (The_Token : Token_Type; Token_Image : String) is begin if Token /= The_Token then -- ??? Should pass user flags here instead Err.Error_Msg (Gprbuild_Flags, Token_Image & " expected", Token_Ptr, One_Line => True); end if; end Expect; ------------------ -- Fail_Program -- ------------------ procedure Fail_Program (Project_Tree : Project_Tree_Ref; Message : String; Exit_Code : Exit_Code_Type := E_Fatal; Flush_Messages : Boolean := True; No_Message : Boolean := False; Command : String := "") is begin if Flush_Messages and not No_Message then if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then Err.Finalize; end if; end if; GPR.Jobserver.Unregister_All_Token_Id; Finish_Program (Project_Tree, Exit_Code => Exit_Code, Message => Message, No_Message => No_Message, Command => Command); end Fail_Program; -------------------- -- Finish_Program -- -------------------- procedure Finish_Program (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Success; Message : String := ""; No_Message : Boolean := False; Command : String := "") is begin if not Opt.Keep_Temporary_Files then Delete_All_Temp_Files (if Project_Tree = null then null else Project_Tree.Shared); end if; if Message'Length > 0 and then not No_Message then if Exit_Code not in E_Success | E_Subtool then Set_Standard_Error; end if; Write_Program_Name; Write_Line (Message); if Command /= "" then Write_Program_Name; Write_Line (Command); end if; end if; Exit_Program (Exit_Code); end Finish_Program; --------------------------- -- For_Interface_Sources -- --------------------------- procedure For_Interface_Sources (Tree : Project_Tree_Ref; Project : Project_Id) is package Dep_Names renames String_Sets; function Less_Than (Left, Right : Source_Id) return Boolean is (Get_Name_String (Left.File) < Get_Name_String (Right.File)); package Interface_Source_Ids is new Ada.Containers.Ordered_Sets (Element_Type => Source_Id, "<" => Less_Than, "=" => "="); function Load_ALI (Filename : String) return ALI_Id; -- Load an ALI file and return its id -------------- -- Load_ALI -- -------------- function Load_ALI (Filename : String) return ALI_Id is Result : ALI_Id := No_ALI_Id; Text : Text_Buffer_Ptr; Lib_File : File_Name_Type; begin if Ada.Directories.Exists (Filename) then Lib_File := Get_File_Name_Id (Filename); Text := Osint.Read_Library_Info (Lib_File); Result := ALI.Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True, Read_Lines => "UD"); Free (Text); end if; return Result; end Load_ALI; -- Local declarations Iter : Source_Iterator; Sid : Source_Id; ALI : ALI_Id; First_Unit : Unit_Id; Second_Unit : Unit_Id; Body_Needed : Boolean; Deps : Dep_Names.Set; Sids : Interface_Source_Ids.Set; -- Start of processing for For_Interface_Sources begin if Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Tree); else Iter := For_Each_Source (Tree, Project); end if; -- First look at each spec, check if the body is needed loop Sid := Element (Iter); exit when Sid = No_Source; -- Skip sources that are removed/excluded and sources not part of -- the interface for standalone libraries. if Sid.Kind = Spec and then (not Sid.Project.Externally_Built or else Sid.Project = Project) and then not Sid.Locally_Removed and then (Project.Standalone_Library = No or else Sid.Declared_In_Interfaces) -- Handle case of non-compilable languages and then Sid.Dep_Name /= No_File then Sids.Include (Sid); -- Check ALI for dependencies on body and sep ALI := Load_ALI (Get_Name_String (Get_Object_Directory (Sid.Project, True)) & Get_Name_String (Sid.Dep_Name)); if ALI /= No_ALI_Id then First_Unit := ALIs.Table (ALI).First_Unit; Second_Unit := No_Unit_Id; Body_Needed := True; -- If there is both a spec and a body, check if both needed if Units.Table (First_Unit).Utype = Is_Body then Second_Unit := ALIs.Table (ALI).Last_Unit; -- If the body is not needed, then reset First_Unit if not Units.Table (Second_Unit).Body_Needed_For_SAL then Body_Needed := False; end if; elsif Units.Table (First_Unit).Utype = Is_Spec_Only then Body_Needed := False; end if; -- Handle all the separates, if any if Body_Needed then if Other_Part (Sid) /= null then Deps.Include (Get_Name_String (Other_Part (Sid).File)); end if; for Dep in ALIs.Table (ALI).First_Sdep .. ALIs.Table (ALI).Last_Sdep loop if Sdep.Table (Dep).Subunit_Name /= No_Name then Deps.Include (Get_Name_String (Sdep.Table (Dep).Sfile)); end if; end loop; end if; end if; end if; Next (Iter); end loop; -- Now handle the bodies and separates if needed if Deps.Length /= 0 then if Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Tree); else Iter := For_Each_Source (Tree, Project); end if; loop Sid := Element (Iter); exit when Sid = No_Source; if Sid.Kind /= Spec and then Deps.Contains (Get_Name_String (Sid.File)) then Sids.Include (Sid); end if; Next (Iter); end loop; end if; -- Call Action for all the sources, in order for E of Sids loop Action (E); end loop; end For_Interface_Sources; ------------------ -- Get_Closures -- ------------------ procedure Get_Closures (Project : Project_Id; In_Tree : Project_Tree_Ref; Mains : String_Vectors.Vector; All_Projects : Boolean := True; Include_Externally_Built : Boolean := False; Status : out Status_Type; Result : out String_Vectors.Vector) is Closures : Path_Sets.Set; Projects_And_Trees : Projects_And_Trees_Sets.Set; Mains_Projects_Trees : MPT_Sets.Set; The_File_Names : File_Names := File_Name_Vectors.Empty_Vector; procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref); -- Add project Proc with its Tree to the list of projects procedure Add_To_Mains (Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref); -- Add main Main with its Project and Tree to the list of mains procedure Add_To_Closures (Source : Source_Id; Added : out Boolean); -- Add Source to the list of closures. Added is True when Source is -- effectively added. If Source was already in the list of closures, it -- is not added again and Added is False. procedure Look_For_Mains; -- Look for mains in the project trees. Status is Success only if -- all mains have been found. procedure Get_Aggregated (Proj : Project_Id); -- Get the non aggregated projects from Aggregate project Proj procedure Cleanup; -- Deallocate the local lists procedure Initialize_Sources; -- Initialize all the source records in all the trees procedure Process (Source : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref); -- Get the sources in the closure of Main and add them to the list of -- closures. --------------------- -- Add_To_Closures -- --------------------- procedure Add_To_Closures (Source : Source_Id; Added : out Boolean) is Position : Path_Sets.Cursor; begin Added := False; if Source /= No_Source then Path_Sets.Insert (Container => Closures, New_Item => Get_Name_String (Source.Path.Display_Name), Position => Position, Inserted => Added); end if; end Add_To_Closures; ------------------ -- Add_To_Mains -- ------------------ procedure Add_To_Mains (Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref) is Position : MPT_Sets.Cursor; Inserted : Boolean; begin Mains_Projects_Trees.Insert (New_Item => (Main, Project, Tree), Position => Position, Inserted => Inserted); end Add_To_Mains; --------------------- -- Add_To_Projects -- --------------------- procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref) is begin Projects_And_Trees.Insert ((Proj, Tree)); end Add_To_Projects; ------------- -- Cleanup -- ------------- procedure Cleanup is begin Closures.Clear; Projects_And_Trees.Clear; Mains_Projects_Trees.Clear; The_File_Names.Clear; end Cleanup; -------------------- -- Get_Aggregated -- -------------------- procedure Get_Aggregated (Proj : Project_Id) is List : Aggregated_Project_List := null; Prj : Project_Id; begin if Proj.Qualifier = Aggregate then List := Proj.Aggregated_Projects; end if; while List /= null loop Prj := List.Project; case Prj.Qualifier is when Library | Configuration | Abstract_Project | Aggregate_Library => null; when Unspecified | Standard => if not Prj.Library and then not Prj.Externally_Built then Add_To_Projects (Prj, List.Tree); end if; when Aggregate => Get_Aggregated (Prj); end case; List := List.Next; end loop; end Get_Aggregated; ------------------------ -- Initialize_Sources -- ------------------------ procedure Initialize_Sources is Last : constant Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.Last (Projects_And_Trees); Position : Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.First (Projects_And_Trees); Iter : Source_Iterator; Src : Source_Id; The_Project_And_Tree : Project_And_Tree; use type Projects_And_Trees_Sets.Cursor; begin loop The_Project_And_Tree := Projects_And_Trees_Sets.Element (Position); -- Initialize all the Ada sources of the project tree, even if -- All_Projects is False. Iter := For_Each_Source (In_Tree => The_Project_And_Tree.Tree, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; Initialize_Source_Record (Src); Next (Iter); end loop; exit when Position = Last; Projects_And_Trees_Sets.Next (Position); end loop; end Initialize_Sources; -------------------- -- Look_For_Mains -- -------------------- procedure Look_For_Mains is begin for FName of The_File_Names loop declare Saved_Mains_Length : constant Ada.Containers.Count_Type := Mains_Projects_Trees.Length; Position : Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.First (Projects_And_Trees); Last : constant Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.Last (Projects_And_Trees); use type Projects_And_Trees_Sets.Cursor; The_PT : Project_And_Tree; begin loop The_PT := Projects_And_Trees_Sets.Element (Position); -- find the main in the project tree declare Source : Source_Id; The_Tree : constant Project_Tree_Ref := The_PT.Tree; The_Project : constant Project_Id := The_PT.Project; Sources : constant Source_Ids := Find_All_Sources (In_Tree => The_Tree, Project => The_Project, In_Imported_Only => False, In_Extended_Only => False, Base_Name => FName); begin for L in Sources'Range loop Source := Sources (L); if Source.Language.Config.Kind /= Unit_Based then Status := Invalid_Main; return; elsif Source.Project = The_Project then Add_To_Mains (Main => Source, Project => The_Project, Tree => The_Tree); elsif All_Projects then if not Source.Project.Externally_Built or else Include_Externally_Built then Add_To_Mains (Main => Source, Project => The_Project, Tree => The_Tree); end if; end if; end loop; end; exit when Position = Last; Projects_And_Trees_Sets.Next (Position); end loop; if Mains_Projects_Trees.Length = Saved_Mains_Length then Status := Invalid_Main; return; end if; end; end loop; end Look_For_Mains; ------------- -- Process -- ------------- procedure Process (Source : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref) is -- Add Source to the closures, if not there yet, and continue with -- the sources it imports. Text : Text_Buffer_Ptr; Idread : ALI_Id; First_Unit : Unit_Id; Last_Unit : Unit_Id; Unit_Data : Unit_Record; The_ALI : File_Name_Type; Added : Boolean; procedure Find_Unit (Uname : String); -- Find the sources for this unit name --------------- -- Find_Unit -- --------------- procedure Find_Unit (Uname : String) is Iter : Source_Iterator; Src : Source_Id; Unit_Name : constant String := Uname (Uname'First .. Uname'Last - 2); Proj : Project_Id; begin if All_Projects then Proj := No_Project; else Proj := Project; end if; Iter := For_Each_Source (In_Tree => Tree, Project => Proj, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; if Src.Unit /= No_Unit_Index and then Get_Name_String (Src.Unit.Name) = Unit_Name then Process (Src, Src.Project, Tree); end if; Next (Iter); end loop; end Find_Unit; begin -- Nothing to do if the project is externally built and -- Include_Externally_Built is False. if Project.Externally_Built and then not Include_Externally_Built then return; end if; Add_To_Closures (Source, Added); if not Added then return; end if; The_ALI := File_Name_Type (Source.Dep_Path); if not Processed_ALIs.Get (The_ALI) then Processed_ALIs.Set (The_ALI, True); Text := Read_Library_Info (The_ALI); if Text = null then Status := Incomplete_Closure; else Idread := Scan_ALI (F => The_ALI, T => Text, Ignore_ED => False, Err => True, Read_Lines => "WD"); Free (Text); if Idread = No_ALI_Id then Status := Incomplete_Closure; else First_Unit := ALI.ALIs.Table (Idread).First_Unit; Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; for Unit in First_Unit .. Last_Unit loop Unit_Data := ALI.Units.Table (Unit); if Unit = First_Unit then declare Uname : constant String := Get_Name_String (Unit_Data.Uname); begin Find_Unit (Uname); -- For a body, check if there are subunits if Uname (Uname'Last - 1 .. Uname'Last) = "%b" then for D in ALI.ALIs.Table (Idread).First_Sdep .. ALI.ALIs.Table (Idread).Last_Sdep loop declare Sdep : constant Sdep_Record := ALI.Sdep.Table (D); begin if Sdep.Subunit_Name /= No_Name then declare Subunit_Name : constant String := Get_Name_String (Sdep.Subunit_Name); File_Name : constant File_Name_Type := Sdep.Sfile; Iter : Source_Iterator; Src : Source_Id; begin if Subunit_Name'Length >= Uname'Length - 2 and then Subunit_Name (Subunit_Name'First .. Subunit_Name'First + Uname'Length - 3) = Uname (Uname'First .. Uname'Last - 2) and then Subunit_Name (Subunit_Name'First + Uname'Length - 2) = '.' then -- Add the subunit to the closure -- First, find the source Iter := For_Each_Source (In_Tree => Tree, Project => Project, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; exit when Src.File = File_Name; Next (Iter); end loop; -- If the source has been found, -- add it to the closure. if Src /= No_Source then Add_To_Closures (Src, Added); end if; end if; end; end if; end; end loop; end if; end; end if; for W in Unit_Data.First_With .. Unit_Data.Last_With loop Find_Unit (Get_Name_String (Withs.Table (W).Uname)); end loop; end loop; end if; end if; end if; end Process; begin Status := Success; Result := String_Vectors.Empty_Vector; -- Fail immediately if there are no Mains if Mains.Is_Empty then Status := No_Main; Cleanup; return; else The_File_Names.Clear; for Src of Mains loop if Src'Length = 0 then Status := No_Main; Cleanup; return; else Name_Len := Src'Length; Name_Buffer (1 .. Name_Len) := Src; The_File_Names.Append (Name_Find); end if; end loop; end if; -- First check if there are any valid project or projects if Project = No_Project or else In_Tree = No_Project_Tree then Err.Error_Msg (Gprbuild_Flags, "Project not found", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; if Project.Externally_Built then Err.Error_Msg (Gprbuild_Flags, "No closures for external projects", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; case Project.Qualifier is when Configuration | Abstract_Project => Err.Error_Msg (Gprbuild_Flags, "No closures for abstract or configuration", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; when Standard | Library | Unspecified => Add_To_Projects (Project, In_Tree); when Aggregate | Aggregate_Library => if not All_Projects then Err.Error_Msg (Gprbuild_Flags, "Aggregate closure must be recursive", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; Get_Aggregated (Project); end case; if Projects_And_Trees.Length = 0 then Err.Error_Msg (Gprbuild_Flags, "No projects to closure", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; -- Initialize the source records for all sources in the project trees Initialize_Sources; -- Now that we have the valid project(s), look for the mains Look_For_Mains; if Status /= Success then Cleanup; return; end if; -- Now that we have the main sources, get their closures Processed_ALIs.Reset; declare Position : MPT_Sets.Cursor := MPT_Sets.First (Mains_Projects_Trees); Last : constant MPT_Sets.Cursor := MPT_Sets.Last (Mains_Projects_Trees); The_MPT : Main_Project_Tree; use type MPT_Sets.Cursor; begin loop The_MPT := MPT_Sets.Element (Position); Process (The_MPT.Main, The_MPT.Project, The_MPT.Tree); exit when Position = Last; MPT_Sets.Next (Position); end loop; end; for Closure of Closures loop Result.Append (Closure); end loop; Cleanup; exception when Ex : others => Debug_Output (Ada.Exceptions.Exception_Information (Ex)); Result.Clear; Status := Unknown_Error; end Get_Closures; -------------- -- Get_Line -- -------------- procedure Get_Line (File : Text_File; Line : out String; Last : out Natural) is C : Character; procedure Advance; ------------- -- Advance -- ------------- procedure Advance is begin if File.Cursor = File.Buffer_Len then File.Buffer_Len := Read (FD => File.FD, A => File.Buffer'Address, N => File.Buffer'Length); if File.Buffer_Len = 0 then File.End_Of_File_Reached := True; return; else File.Cursor := 1; end if; else File.Cursor := File.Cursor + 1; end if; end Advance; -- Start of processing for Get_Line begin if File = null then GPR.Com.Fail ("Get_Line attempted on an invalid Text_File"); elsif File.Out_File then GPR.Com.Fail ("Get_Line attempted on an out file"); end if; Last := Line'First - 1; if not File.End_Of_File_Reached then loop C := File.Buffer (File.Cursor); exit when C = ASCII.CR or else C = ASCII.LF; Last := Last + 1; Line (Last) := C; Advance; if File.End_Of_File_Reached then return; end if; exit when Last = Line'Last; end loop; if C = ASCII.CR or else C = ASCII.LF then Advance; if File.End_Of_File_Reached then return; end if; end if; if C = ASCII.CR and then File.Buffer (File.Cursor) = ASCII.LF then Advance; end if; end if; end Get_Line; -------------- -- Get_Line -- -------------- function Get_Line (File : Text_File; Max_Length : Positive := 4096) return String is Result : String (1 .. Max_Length); Last : Natural; begin Get_Line (File, Result, Last); return Result (1 .. Last); end Get_Line; ------------------ -- Get_Switches -- ------------------ procedure Get_Switches (Source : GPR.Source_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean) is begin Get_Switches (Source_File => Source.File, Source_Lang => Source.Language.Name, Source_Prj => Source.Project, Pkg_Name => Pkg_Name, Project_Tree => Project_Tree, Value => Value, Is_Default => Is_Default); end Get_Switches; procedure Get_Switches (Source_File : File_Name_Type; Source_Lang : Name_Id; Source_Prj : Project_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean; Test_Without_Suffix : Boolean := False; Check_ALI_Suffix : Boolean := False) is Project : constant Project_Id := Ultimate_Extending_Project_Of (Source_Prj); Pkg : constant Package_Id := GPR.Util.Value_Of (Name => Pkg_Name, In_Packages => Project.Decl.Packages, Shared => Project_Tree.Shared); Lang : Language_Ptr; begin Is_Default := False; if Source_File /= No_File then Value := GPR.Util.Value_Of (Name => Name_Id (Source_File), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; if Value = Nil_Variable_Value and then Test_Without_Suffix then Lang := Get_Language_From_Name (Project, Get_Name_String (Source_Lang)); if Lang /= null then declare Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; SF_Name : constant String := Get_Name_String (Source_File); Last : Positive := SF_Name'Length; Name : String (1 .. Last + 3); Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix); Body_Suffix : String := Get_Name_String (Naming.Body_Suffix); Truncated : Boolean := False; begin Canonical_Case_File_Name (Spec_Suffix); Canonical_Case_File_Name (Body_Suffix); Name (1 .. Last) := SF_Name; if Last > Body_Suffix'Length and then Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix then Truncated := True; Last := Last - Body_Suffix'Length; end if; if not Truncated and then Last > Spec_Suffix'Length and then Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix then Truncated := True; Last := Last - Spec_Suffix'Length; end if; if Truncated then Value := GPR.Util.Value_Of (Name => Get_Name_Id (Name (1 .. Last)), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; if Value = Nil_Variable_Value and then Check_ALI_Suffix then Last := SF_Name'Length; while Name (Last) /= '.' loop Last := Last - 1; end loop; Value := GPR.Util.Value_Of (Get_Name_Id (Name (1 .. Last) & "ali"), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; end; end if; end if; if Value = Nil_Variable_Value then Is_Default := True; Value := GPR.Util.Value_Of (Name => Source_Lang, Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Value = Nil_Variable_Value then Value := GPR.Util.Value_Of (Name => All_Other_Names, Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Value = Nil_Variable_Value then Value := GPR.Util.Value_Of (Name => Source_Lang, Attribute_Or_Array_Name => Name_Default_Switches, In_Package => Pkg, Shared => Project_Tree.Shared); end if; end Get_Switches; ---------------- -- Initialize -- ---------------- procedure Initialize (Iter : out Source_Info_Iterator; For_Project : Name_Id) is Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); begin if Ind = 0 then Iter := (No_Source_Info, 0); else Iter := Source_Info_Table.Table (Ind); end if; end Initialize; ------------------------------ -- Initialize_Source_Record -- ------------------------------ procedure Initialize_Source_Record (Source : GPR.Source_Id; Always : Boolean := False) is Main_Source_File : File_Name_Type := Source.File; procedure Set_Object_Project (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; Stamp : Time_Stamp_Type); -- Update information about object file, switches file,... ------------------------ -- Set_Object_Project -- ------------------------ procedure Set_Object_Project (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; Stamp : Time_Stamp_Type) is begin Source.Object_Project := Obj_Proj; Source.Object_Path := Obj_Path; Source.Object_TS := Stamp; if Source.Language.Config.Dependency_Kind /= None then declare Dep_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Obj_Dir); begin if not Gprls_Mode or else Obj_Proj.Extends = No_Project or else Is_Regular_File (Dep_Path) then Source.Dep_Path := Create_Name (Dep_Path); Source.Dep_TS := Unknown_Attributes; end if; end; end if; -- Get the path of the switches file, even if Opt.Check_Switches is -- not set, as switch -s may be in the Builder switches that have not -- been scanned yet. declare Switches_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Switches), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Obj_Dir); begin Source.Switches_Path := Create_Name (Switches_Path); if Stamp /= Empty_Time_Stamp then Source.Switches_TS := File_Stamp (Source.Switches_Path); end if; end; end Set_Object_Project; Obj_Proj : Project_Id; begin -- Nothing to do if source record has already been fully initialized if Source.Initialized and not Always then return; end if; -- Systematically recompute the time stamp Source.Source_TS := File_Stamp (Source.Path.Display_Name); -- Parse the source file to check whether we have a subunit if Source.Language.Config.Kind = Unit_Based and then Source.Kind = Impl and then Is_Subunit (Source) then Source.Kind := Sep; end if; if Source.Language.Config.Object_Generated and then Is_Compilable (Source) then -- First, get the correct object file name and dependency file if Source.Unit /= No_Unit_Index and then Source.Kind = Spec and then Other_Part (Source) /= No_Source then Main_Source_File := Other_Part (Source).File; Source.Object := Object_Name (Main_Source_File, Source.Language.Config.Object_File_Suffix); Source.Dep_Name := Dependency_Name (Source.Object, Source.Language.Config.Dependency_Kind); end if; if Source.Index /= 0 then Source.Object := Object_Name (Source_File_Name => Main_Source_File, Source_Index => Source.Index, Index_Separator => Source.Language.Config.Multi_Unit_Object_Separator, Object_File_Suffix => Source.Language.Config.Object_File_Suffix); Source.Dep_Name := Dependency_Name (Source.Object, Source.Language.Config.Dependency_Kind); end if; -- Find the object file for that source. It could be either in the -- current project or in an extended project (it might actually not -- exist yet in the ultimate extending project, but if not found -- elsewhere that's where we'll expect to find it). Obj_Proj := Source.Project; while Obj_Proj /= No_Project loop if Obj_Proj.Object_Directory /= No_Path_Information then declare Dir : constant String := Get_Name_String (Obj_Proj.Object_Directory.Display_Name); Object_Path : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Object), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Dir); Obj_Path : constant Path_Name_Type := Create_Name (Object_Path); Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin -- For specs, we do not check object files if there is a -- body. This saves a system call. On the other hand, we do -- need to know the object_path, in case the user has passed -- the .ads on the command line to compile the spec only. if Source.Kind /= Spec or else Source.Unit = No_Unit_Index or else Source.Unit.File_Names (Impl) = No_Source then Stamp := File_Stamp (Obj_Path); end if; if Stamp /= Empty_Time_Stamp or else (Obj_Proj.Extended_By = No_Project and then Source.Object_Project = No_Project) then Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp); end if; end; end if; Obj_Proj := Obj_Proj.Extended_By; end loop; if Source.Language.Config.Dependency_Kind /= None and then Source.Dep_Path = No_Path then -- If we have not found a dependency file in the object -- project, it means that the Source.Project is extended and that -- we are in gprls node. We need to look for an actual dependency -- file in the extended projects. If none is found, the dependency -- file is set in the ultimate extending project. Obj_Proj := Source.Project; while Obj_Proj /= No_Project loop if Obj_Proj.Object_Directory /= No_Path_Information then declare Dir : constant String := Get_Name_String (Obj_Proj.Object_Directory.Display_Name); Dep_Path_Name : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Dir); Dep_Path : constant Path_Name_Type := Create_Name (Dep_Path_Name); Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin if Source.Kind /= Spec or else Source.Unit = No_Unit_Index or else Source.Unit.File_Names (Impl) = No_Source then Stamp := File_Stamp (Dep_Path); end if; if Stamp /= Empty_Time_Stamp or else (Source.Dep_Path = No_Path and then Obj_Proj.Extended_By = No_Project) then Source.Dep_Path := Dep_Path; Source.Dep_TS := Unknown_Attributes; end if; end; end if; Obj_Proj := Obj_Proj.Extended_By; end loop; end if; elsif Source.Language.Config.Dependency_Kind = Makefile then declare Object_Dir : constant String := Get_Name_String (Source.Project.Object_Directory.Display_Name); Dep_Path : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Object_Dir); begin Source.Dep_Path := Create_Name (Dep_Path); Source.Dep_TS := Unknown_Attributes; end; end if; Source.Initialized := True; end Initialize_Source_Record; --------------------------------- -- Is_Ada_Predefined_File_Name -- --------------------------------- function Is_Ada_Predefined_File_Name (Fname : File_Name_Type) return Boolean is subtype Str8 is String (1 .. 8); Predef_Names : constant array (1 .. 12) of Str8 := ("ada ", -- Ada "interfac", -- Interfaces "system ", -- System "gnat ", -- GNAT "calendar", -- Calendar "machcode", -- Machine_Code "unchconv", -- Unchecked_Conversion "unchdeal", -- Unchecked_Deallocation "directio", -- Direct_IO "ioexcept", -- IO_Exceptions "sequenio", -- Sequential_IO "text_io "); -- Text_IO begin Get_Name_String (Fname); -- Remove extension (.ads/.adb) if present if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then Name_Len := Name_Len - 4; end if; -- Definitely predefined if prefix is a- i- or s- followed by letter if Name_Len >= 3 and then Name_Buffer (2) = '-' and then (Name_Buffer (1) = 'a' or else Name_Buffer (1) = 'g' or else Name_Buffer (1) = 'i' or else Name_Buffer (1) = 's') and then (Name_Buffer (3) in 'a' .. 'z' or else Name_Buffer (3) in 'A' .. 'Z') then return True; -- Definitely false if longer than 12 characters (8.3) elsif Name_Len > 8 then return False; end if; -- Otherwise check against special list, first padding to 8 characters while Name_Len < 8 loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ' '; end loop; for J in Predef_Names'Range loop if Name_Buffer (1 .. 8) = Predef_Names (J) then return True; end if; end loop; return False; end Is_Ada_Predefined_File_Name; ---------------------------- -- Is_Ada_Predefined_Unit -- ---------------------------- function Is_Ada_Predefined_Unit (Unit : String) return Boolean is Lower_Unit : String := Unit; begin To_Lower (Lower_Unit); return Lower_Unit in "ada" | "gnat" | "interfaces" | "system" | "calendar" | "machine_code" | "unchecked_conversion" | "unchecked_deallocation" | "direct_io" | "io_exceptions" | "sequential_io" | "text_io" or else Starts_With (Lower_Unit, "ada.") or else Starts_With (Lower_Unit, "gnat.") or else Starts_With (Lower_Unit, "system.") or else Starts_With (Lower_Unit, "interfaces."); end Is_Ada_Predefined_Unit; ---------------------------- -- Is_Pragmas_Config_File -- ---------------------------- function Is_Pragmas_Config_File (Fname : File_Name_Type) return Boolean is Filename : constant String := Get_Name_String (Fname); Pragma_Config_File_Suffix : constant String := ".adc"; E_First : constant Integer := Filename'Last - Pragma_Config_File_Suffix'Length + 1; E_Last : constant Integer := Filename'Last; begin if Filename'Length > Pragma_Config_File_Suffix'Length then return (Filename (E_First .. E_Last) = Pragma_Config_File_Suffix); else return False; end if; end Is_Pragmas_Config_File; ---------------- -- Is_Subunit -- ---------------- function Is_Subunit (Source : GPR.Source_Id) return Boolean is Src_Ind : Source_File_Index; begin if Source.Kind = Sep then return True; -- A Spec, a file based language source or a body with a spec cannot be -- a subunit. elsif Source.Kind = Spec or else Source.Unit = No_Unit_Index or else Other_Part (Source) /= No_Source then return False; end if; -- Here, we are assuming that the language is Ada, as it is the only -- unit based language that we know. pragma Assert (Source.Path /= No_Path_Information, "no path information for " & Get_Name_String (Source.File) & ' ' & Source.Locally_Removed'Img); Src_Ind := Sinput.Load_File (Get_Name_String (Source.Path.Display_Name)); return Sinput.Source_File_Is_Subunit (Src_Ind); end Is_Subunit; -------------- -- Is_Valid -- -------------- function Is_Valid (File : Text_File) return Boolean is begin return File /= null; end Is_Valid; ---------- -- Next -- ---------- procedure Next (Iter : in out Source_Info_Iterator) is begin if Iter.Next = 0 then Iter.Info := No_Source_Info; else Iter := Source_Info_Table.Table (Iter.Next); end if; end Next; -------------------- -- Object_Project -- -------------------- function Object_Project (Project : Project_Id; Must_Be_Writable : Boolean := False) return Project_Id is Result : Project_Id := No_Project; procedure Check_Project (P : Project_Id); -- Find a project with an object dir ------------------- -- Check_Project -- ------------------- procedure Check_Project (P : Project_Id) is begin if P.Qualifier = Aggregate or else P.Qualifier = Aggregate_Library then declare List : Aggregated_Project_List := P.Aggregated_Projects; begin -- Look for a non aggregate project until one is found while Result = No_Project and then List /= null loop Check_Project (List.Project); List := List.Next; end loop; end; elsif P.Object_Directory.Name /= No_Path then if not Must_Be_Writable or else Is_Writable_File (Get_Name_String (P.Object_Directory.Display_Name)) then Result := P; end if; end if; end Check_Project; begin Check_Project (Project); return Result; end Object_Project; ---------- -- Open -- ---------- procedure Open (File : out Text_File; Name : String) is FD : File_Descriptor; File_Name : String (1 .. Name'Length + 1); begin File_Name (1 .. Name'Length) := Name; File_Name (File_Name'Last) := ASCII.NUL; FD := Open_Read (Name => File_Name'Address, Fmode => GNAT.OS_Lib.Text); if FD = Invalid_FD then File := null; else File := new Text_File_Data; File.FD := FD; File.Buffer_Len := Read (FD => FD, A => File.Buffer'Address, N => File.Buffer'Length); if File.Buffer_Len = 0 then File.End_Of_File_Reached := True; else File.Cursor := 1; end if; end if; end Open; --------- -- Put -- --------- procedure Put (Into_List : in out Name_List_Index; From_List : String_List_Id; In_Tree : Project_Tree_Ref; Lower_Case : Boolean := False) is Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; Current_Name : Name_List_Index; List : String_List_Id; Element : String_Element; Last : Name_List_Index := Name_List_Table.Last (Shared.Name_Lists); Value : Name_Id; begin Current_Name := Into_List; while Current_Name /= No_Name_List and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List loop Current_Name := Shared.Name_Lists.Table (Current_Name).Next; end loop; List := From_List; while List /= Nil_String loop Element := Shared.String_Elements.Table (List); Value := Element.Value; if Lower_Case then Get_Name_String (Value); To_Lower (Name_Buffer (1 .. Name_Len)); Value := Name_Find; end if; Name_List_Table.Append (Shared.Name_Lists, (Name => Value, Next => No_Name_List)); Last := Last + 1; if Current_Name = No_Name_List then Into_List := Last; else Shared.Name_Lists.Table (Current_Name).Next := Last; end if; Current_Name := Last; List := Element.Next; end loop; end Put; procedure Put (File : Text_File; S : String) is Len : Integer; begin if File = null then GPR.Com.Fail ("Attempted to write on an invalid Text_File"); elsif not File.Out_File then GPR.Com.Fail ("Attempted to write an in Text_File"); end if; if File.Buffer_Len + S'Length > File.Buffer'Last then -- Write buffer Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); if Len /= File.Buffer_Len then GPR.Com.Fail ("Failed to write to an out Text_File"); end if; File.Buffer_Len := 0; end if; File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; File.Buffer_Len := File.Buffer_Len + S'Length; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (File : Text_File; Line : String) is L : String (1 .. Line'Length + 1); begin L (1 .. Line'Length) := Line; L (L'Last) := ASCII.LF; Put (File, L); end Put_Line; --------------------------- -- Read_Source_Info_File -- --------------------------- procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is File : Text_File; Info : Source_Info_Iterator; Proj : Name_Id; procedure Report_Error; ------------------ -- Report_Error -- ------------------ procedure Report_Error is begin Write_Line ("errors in source info file """ & Tree.Source_Info_File_Name.all & '"'); Tree.Source_Info_File_Exists := False; end Report_Error; begin Source_Info_Project_HTable.Reset; Source_Info_Table.Init; if Tree.Source_Info_File_Name = null then Tree.Source_Info_File_Exists := False; return; end if; Open (File, Tree.Source_Info_File_Name.all); if not Is_Valid (File) then if Opt.Verbosity_Level > Opt.Low then Write_Line ("source info file " & Tree.Source_Info_File_Name.all & " does not exist"); end if; Tree.Source_Info_File_Exists := False; return; end if; Tree.Source_Info_File_Exists := True; if Opt.Verbosity_Level > Opt.Low then Write_Line ("Reading source info file " & Tree.Source_Info_File_Name.all); end if; Source_Loop : while not End_Of_File (File) loop Info := (new Source_Info_Data, 0); Source_Info_Table.Increment_Last; -- project name Get_Line (File, Name_Buffer, Name_Len); Proj := Name_Find; Info.Info.Project := Proj; Info.Next := Source_Info_Project_HTable.Get (Proj); Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- language name Get_Line (File, Name_Buffer, Name_Len); Info.Info.Language := Name_Find; if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- kind Get_Line (File, Name_Buffer, Name_Len); Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- display path name Get_Line (File, Name_Buffer, Name_Len); Info.Info.Display_Path_Name := Name_Find; Info.Info.Path_Name := Info.Info.Display_Path_Name; if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- optional fields Option_Loop : loop Get_Line (File, Name_Buffer, Name_Len); exit Option_Loop when Name_Len = 0; if Name_Len <= 2 then Report_Error; exit Source_Loop; else if Name_Buffer (1 .. 2) = "P=" then Name_Buffer (1 .. Name_Len - 2) := Name_Buffer (3 .. Name_Len); Name_Len := Name_Len - 2; Info.Info.Path_Name := Name_Find; elsif Name_Buffer (1 .. 2) = "U=" then Name_Buffer (1 .. Name_Len - 2) := Name_Buffer (3 .. Name_Len); Name_Len := Name_Len - 2; Info.Info.Unit_Name := Name_Find; elsif Name_Buffer (1 .. 2) = "I=" then Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); elsif Name_Buffer (1 .. Name_Len) = "N=Y" then Info.Info.Naming_Exception := Yes; elsif Name_Buffer (1 .. Name_Len) = "N=I" then Info.Info.Naming_Exception := Inherited; else Report_Error; exit Source_Loop; end if; end if; end loop Option_Loop; Source_Info_Table.Table (Source_Info_Table.Last) := Info; end loop Source_Loop; Close (File); exception when others => Close (File); Report_Error; end Read_Source_Info_File; ------------------- -- Relative_Path -- ------------------- function Relative_Path (Pathname : String; To : String; Directory : Boolean := True) return String is function Ensure_Directory (Path : String) return String; -- Returns Path with an added directory separator if needed ---------------------- -- Ensure_Directory -- ---------------------- function Ensure_Directory (Path : String) return String is begin if Path'Length = 0 then return "./"; elsif not Directory or else Is_Directory_Separator (Path (Path'Last)) then return Path; else return Path & Directory_Separator; end if; end Ensure_Directory; -- Local variables Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/"); P : String (1 .. Pathname'Length) := Pathname; T : String (1 .. To'Length) := To; Pi : Natural; -- common prefix ending N : Natural := 0; -- Start of processing for Relative_Path begin pragma Assert (Is_Absolute_Path (Pathname)); pragma Assert (Is_Absolute_Path (To)); -- Use canonical directory separator Translate (Source => P, Mapping => Dir_Sep_Map); Translate (Source => T, Mapping => Dir_Sep_Map); -- First check for common prefix Pi := 1; while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop Pi := Pi + 1; end loop; -- Cut common prefix at a directory separator while Pi > P'First and then P (Pi) /= '/' loop Pi := Pi - 1; end loop; -- Count directory under prefix in P, these will be replaced by the -- corresponding number of "..". N := Ada.Strings.Fixed.Count (T (Pi + 1 .. T'Last), "/"); if T (T'Last) /= '/' then N := N + 1; end if; return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last)); end Relative_Path; ---------------------- -- Set_Program_Name -- ---------------------- procedure Set_Program_Name (N : String) is begin Program_Name := new String'(N); end Set_Program_Name; ------------------- -- Source_Dir_Of -- ------------------- function Source_Dir_Of (Source : Source_Id) return String is Path : constant String := Get_Name_String (Source.Path.Name); begin return Path (Path'First .. Path'Last - Natural (Length_Of_Name (Source.File))); end Source_Dir_Of; -------------------- -- Source_Info_Of -- -------------------- function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is begin return Iter.Info; end Source_Info_Of; ----------- -- Split -- ----------- function Split (Source : String; Separator : String) return Name_Array_Type is Start : Positive := Source'First; Finish : Positive; package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id); List : Name_Ids.Vector; procedure Add_String (S : String); ---------------- -- Add_String -- ---------------- procedure Add_String (S : String) is begin if S'Length > 0 then List.Append (Get_Name_Id (S)); end if; end Add_String; begin if Separator'Length = 0 or else Index (Source, Separator) = 0 then -- List with one string = Argument Add_String (Source); else if Index (Source, Separator) = Start then Start := Start + Separator'Length; end if; loop if Index (Source (Start .. Source'Last), Separator) = 0 then Add_String (Source (Start .. Source'Last)); exit; else Finish := Index (Source (Start .. Source'Last), Separator) - 1; Add_String (Source (Start .. Finish)); Start := Finish + 1 + Separator'Length; exit when Start > Source'Last; end if; end loop; end if; return Result : Name_Array_Type (1 .. Integer (List.Length)) do for J in Result'Range loop Result (J) := List.Element (J); end loop; end return; end Split; ------------------- -- To_Time_Stamp -- ------------------- function To_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type is begin return Time_Stamp_Type (Image (Time, "%Y%m%d%H%M%S")); end To_Time_Stamp; ---------------------- -- To_UTC_Timestamp -- ---------------------- function To_UTC_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type is use type Ada.Calendar.Time; begin return To_Time_Stamp (Time - Duration (UTC_Time_Offset (Time)) * 60); end To_UTC_Time_Stamp; -------------- -- UTC_Time -- -------------- function UTC_Time return Time_Stamp_Type is begin return To_UTC_Time_Stamp (Ada.Calendar.Clock); end UTC_Time; -------------- -- Value_Of -- -------------- function Value_Of (Variable : Variable_Value; Default : String) return String is begin if Variable.Kind /= Single or else Variable.Default or else Variable.Value = No_Name then return Default; else return Get_Name_String (Variable.Value); end if; end Value_Of; function Value_Of (Index : Name_Id; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id is Current : Array_Element_Id; Element : Array_Element; Real_Index : Name_Id := Index; begin Current := In_Array; if Current = No_Array_Element then return No_Name; end if; Element := Shared.Array_Elements.Table (Current); if not Element.Index_Case_Sensitive then Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index := Name_Find; end if; while Current /= No_Array_Element loop Element := Shared.Array_Elements.Table (Current); if Real_Index = Element.Index then exit when Element.Value.Kind /= Single; exit when Element.Value.Value = Empty_String; return Element.Value.Value; else Current := Element.Next; end if; end loop; return No_Name; end Value_Of; function Value_Of (Index : Name_Id; Src_Index : Int := 0; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value is Current : Array_Element_Id; Element : Array_Element; Real_Index_1 : Name_Id; Real_Index_2 : Name_Id; begin Current := In_Array; if Current = No_Array_Element then return Nil_Variable_Value; end if; Element := Shared.Array_Elements.Table (Current); Real_Index_1 := Index; if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index) and then Index /= All_Other_Names then Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index_1 := Name_Find; end if; while Current /= No_Array_Element loop Element := Shared.Array_Elements.Table (Current); Real_Index_2 := Element.Index; if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index) and then Element.Index /= All_Other_Names then Get_Name_String (Element.Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index_2 := Name_Find; end if; if Src_Index = Element.Src_Index and then (Real_Index_1 = Real_Index_2 or else (Real_Index_2 /= All_Other_Names and then Allow_Wildcards and then Match (Get_Name_String (Real_Index_1), Compile (Get_Name_String (Real_Index_2), Glob => True)))) then return Element.Value; else Current := Element.Next; end if; end loop; return Nil_Variable_Value; end Value_Of; function Value_Of (Name : Name_Id; Index : Int := 0; Attribute_Or_Array_Name : Name_Id; In_Package : Package_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value is The_Array : Array_Element_Id; The_Attribute : Variable_Value := Nil_Variable_Value; begin if In_Package /= No_Package then -- First, look if there is an array element that fits The_Array := Value_Of (Name => Attribute_Or_Array_Name, In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays, Shared => Shared); The_Attribute := Value_Of (Index => Name, Src_Index => Index, In_Array => The_Array, Shared => Shared, Force_Lower_Case_Index => Force_Lower_Case_Index, Allow_Wildcards => Allow_Wildcards); -- If there is no array element, look for a variable if The_Attribute = Nil_Variable_Value then The_Attribute := Value_Of (Variable_Name => Attribute_Or_Array_Name, In_Variables => Shared.Packages.Table (In_Package).Decl.Attributes, Shared => Shared); end if; end if; return The_Attribute; end Value_Of; function Value_Of (Index : Name_Id; In_Array : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id is Current : Array_Id; The_Array : Array_Data; begin Current := In_Arrays; while Current /= No_Array loop The_Array := Shared.Arrays.Table (Current); if The_Array.Name = In_Array then return Value_Of (Index, In_Array => The_Array.Value, Shared => Shared); else Current := The_Array.Next; end if; end loop; return No_Name; end Value_Of; function Value_Of (Name : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id is Current : Array_Id; The_Array : Array_Data; begin Current := In_Arrays; while Current /= No_Array loop The_Array := Shared.Arrays.Table (Current); if The_Array.Name = Name then return The_Array.Value; else Current := The_Array.Next; end if; end loop; return No_Array_Element; end Value_Of; function Value_Of (Name : Name_Id; In_Packages : Package_Id; Shared : Shared_Project_Tree_Data_Access) return Package_Id is Current : Package_Id; The_Package : Package_Element; begin Current := In_Packages; while Current /= No_Package loop The_Package := Shared.Packages.Table (Current); exit when The_Package.Name /= No_Name and then The_Package.Name = Name; Current := The_Package.Next; end loop; return Current; end Value_Of; function Value_Of (Variable_Name : Name_Id; In_Variables : Variable_Id; Shared : Shared_Project_Tree_Data_Access) return Variable_Value is Current : Variable_Id; The_Variable : Variable; begin Current := In_Variables; while Current /= No_Variable loop The_Variable := Shared.Variable_Elements.Table (Current); if Variable_Name = The_Variable.Name then return The_Variable.Value; else Current := The_Variable.Next; end if; end loop; return Nil_Variable_Value; end Value_Of; ------------------------ -- Write_Program_Name -- ------------------------ procedure Write_Program_Name is begin if Program_Name /= null then Write_Str (Program_Name.all & ": "); end if; end Write_Program_Name; ---------------------------- -- Write_Source_Info_File -- ---------------------------- procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is Iter : Source_Iterator := For_Each_Source (Tree); Source : GPR.Source_Id; File : Text_File; begin if Opt.Verbosity_Level > Opt.Low then Write_Line ("Writing new source info file " & Tree.Source_Info_File_Name.all); end if; Create (File, Tree.Source_Info_File_Name.all); if not Is_Valid (File) then Write_Line ("warning: unable to create source info file """ & Tree.Source_Info_File_Name.all & '"'); return; end if; loop Source := Element (Iter); exit when Source = No_Source; if not Source.Locally_Removed and then Source.Replaced_By = No_Source then -- Project name Put_Line (File, Get_Name_String (Source.Project.Name)); -- Language name Put_Line (File, Get_Name_String (Source.Language.Name)); -- Kind Put_Line (File, Source.Kind'Img); -- Display path name Put_Line (File, Get_Name_String (Source.Path.Display_Name)); -- Optional lines: -- Path name (P=) if Source.Path.Name /= Source.Path.Display_Name then Put (File, "P="); Put_Line (File, Get_Name_String (Source.Path.Name)); end if; -- Unit name (U=) if Source.Unit /= No_Unit_Index then Put (File, "U="); Put_Line (File, Get_Name_String (Source.Unit.Name)); end if; -- Multi-source index (I=) if Source.Index /= 0 then Put (File, "I="); Put_Line (File, Source.Index'Img); end if; -- Naming exception ("N=T"); if Source.Naming_Exception = Yes then Put_Line (File, "N=Y"); elsif Source.Naming_Exception = Inherited then Put_Line (File, "N=I"); end if; -- Empty line to indicate end of info on this source Put_Line (File, ""); end if; Next (Iter); end loop; Close (File); end Write_Source_Info_File; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String; Max_Length : Positive; Separator : Character) is First : Positive := S'First; Last : Natural := S'Last; begin -- Nothing to do for empty strings if S'Length > 0 then -- Start on a new line if current line is already longer than -- Max_Length. if Positive (Column) >= Max_Length then Write_Eol; end if; -- If length of remainder is longer than Max_Length, we need to -- cut the remainder in several lines. while Positive (Column) + S'Last - First > Max_Length loop -- Try the maximum length possible Last := First + Max_Length - Positive (Column); -- Look for last Separator in the line while Last >= First and then S (Last) /= Separator loop Last := Last - 1; end loop; -- If we do not find a separator, we output the maximum length -- possible. if Last < First then Last := First + Max_Length - Positive (Column); end if; Write_Line (S (First .. Last)); -- Set the beginning of the new remainder First := Last + 1; end loop; -- What is left goes to the buffer, without EOL Write_Str (S (First .. S'Last)); end if; end Write_Str; Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr; pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir"); -- Pointer to string indicating the installation subdirectory where a -- default shared libgcc might be found. package Project_Name_Boolean_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => Hash, Equal => "="); Project_Failure : Project_Name_Boolean_Htable.Instance := Project_Name_Boolean_Htable.Nil; -- Record a boolean for project having failed to compile cleanly ------------------------------- -- Binder_Exchange_File_Name -- ------------------------------- function Binder_Exchange_File_Name (Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access is File_Name : constant String := Get_Name_String (Main_Base_Name); begin Get_Name_String (Prefix); Add_Str_To_Name_Buffer (File_Name); Add_Str_To_Name_Buffer (Binder_Exchange_Suffix); return new String'(Name_Buffer (1 .. Name_Len)); end Binder_Exchange_File_Name; ------------------------------ -- Check_Version_And_Help_G -- ------------------------------ -- Common switches for GNU tools Version_Switch : constant String := "--version"; Help_Switch : constant String := "--help"; procedure Check_Version_And_Help_G (Tool_Name : String; Initial_Year : String) is Version_Switch_Present : Boolean := False; Help_Switch_Present : Boolean := False; Next_Arg : Natural; begin -- First check for --version or --help Next_Arg := 1; while Next_Arg <= Argument_Count loop declare Next_Argv : constant String := Argument (Next_Arg); begin if Next_Argv = Version_Switch then Version_Switch_Present := True; elsif Next_Argv = Help_Switch then Help_Switch_Present := True; end if; Next_Arg := Next_Arg + 1; end; end loop; -- If --version was used, display version and exit if Version_Switch_Present then Display_Version (Tool_Name, Initial_Year); Put_Line (Free_Software); New_Line; OS_Exit (0); end if; -- If --help was used, display help and exit if Help_Switch_Present then Usage; New_Line; Put_Line ("Report bugs to report@adacore.com"); OS_Exit (0); end if; end Check_Version_And_Help_G; --------------------- -- Create_Sym_Link -- --------------------- procedure Create_Sym_Link (From, To : String) is function Symlink (Oldpath : System.Address; Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); C_From : constant String := From & ASCII.NUL; C_To : constant String := Relative_Path (Containing_Directory (To), Containing_Directory (From)) & Ada.Directories.Simple_Name (To) & ASCII.NUL; Result : Integer; Success : Boolean; pragma Unreferenced (Result); begin Delete_File (From, Success); Result := Symlink (C_To'Address, C_From'Address); end Create_Sym_Link; ---------------------- -- Create_Sym_Links -- ---------------------- procedure Create_Sym_Links (Lib_Path : String; Lib_Version : String; Lib_Dir : String; Maj_Version : String) is function Symlink (Oldpath : System.Address; Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); Version_Path : String_Access; Success : Boolean; Result : Integer; pragma Unreferenced (Result); begin Version_Path := new String (1 .. Lib_Version'Length + 1); Version_Path (1 .. Lib_Version'Length) := Lib_Version; Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare Newpath : String (1 .. Lib_Path'Length + 1); begin Newpath (1 .. Lib_Path'Length) := Lib_Path; Newpath (Newpath'Last) := ASCII.NUL; Delete_File (Lib_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath'Address); end; else declare Newpath1 : String (1 .. Lib_Path'Length + 1); Maj_Path : constant String := Lib_Dir & Directory_Separator & Maj_Version; Newpath2 : String (1 .. Maj_Path'Length + 1); Maj_Ver : String (1 .. Maj_Version'Length + 1); begin Newpath1 (1 .. Lib_Path'Length) := Lib_Path; Newpath1 (Newpath1'Last) := ASCII.NUL; Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; Maj_Ver (Maj_Ver'Last) := ASCII.NUL; Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); Result := Symlink (Maj_Ver'Address, Newpath1'Address); end; end if; end Create_Sym_Links; ------------------------------------ -- Display_Usage_Version_And_Help -- ------------------------------------ procedure Display_Usage_Version_And_Help is begin Put_Line (" --version Display version and exit"); Put_Line (" --help Display usage and exit"); New_Line; end Display_Usage_Version_And_Help; --------------------- -- Display_Version -- --------------------- procedure Display_Version (Tool_Name : String; Initial_Year : String) is begin Put_Line (Tool_Name & " " & Gpr_Version_String); Put ("Copyright (C) "); Put (Initial_Year); Put ('-'); Put (Current_Year); Put (", "); Put (Copyright_Holder); New_Line; end Display_Version; ---------------------- -- Ensure_Directory -- ---------------------- function Ensure_Directory (Path : String) return String is begin if Path'Length = 0 or else Is_Directory_Separator (Path (Path'Last)) then return Path; else return Path & Directory_Separator; end if; end Ensure_Directory; ---------------------- -- Ensure_Extension -- ---------------------- function Ensure_Extension (Filename : String; Ext : String) return String is begin for Char of reverse Filename loop if Char = '.' then return Filename; elsif Is_Directory_Separator (Char) then exit; end if; end loop; return Filename & Ext; end Ensure_Extension; ------------------- -- Ensure_Suffix -- ------------------- function Ensure_Suffix (Item : String; Suffix : String) return String is begin if Item'Length >= Suffix'Length and then Item (Item'Last - Suffix'Length + 1 .. Item'Last) = Suffix then return Item; else return Item & Suffix; end if; end Ensure_Suffix; -- --------------- -- -- Error_Msg -- -- --------------- -- -- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is -- pragma Warnings (Off, Msg); -- pragma Warnings (Off, Flag_Location); -- begin -- null; -- end Error_Msg; -- -- ----------------- -- -- Error_Msg_S -- -- ----------------- -- -- procedure Error_Msg_S (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_S; -- -- ------------------ -- -- Error_Msg_SC -- -- ------------------ -- -- procedure Error_Msg_SC (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_SC; -- -- ------------------ -- -- Error_Msg_SP -- -- ------------------ -- -- procedure Error_Msg_SP (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_SP; -------------- -- File_MD5 -- -------------- function File_MD5 (Pathname : String) return Message_Digest is use Stream_IO; C : Context; S : Stream_IO.File_Type; B : Stream_Element_Array (1 .. 100 * 1024); -- Buffer to read chunk of data L : Stream_Element_Offset; begin Open (S, In_File, Pathname); while not End_Of_File (S) loop Read (S, B, L); Update (C, B (1 .. L)); end loop; Close (S); return Digest (C); end File_MD5; -------------- -- As_RPath -- -------------- function As_RPath (Path : String; Case_Sensitive : Boolean) return String is Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/"); begin return Translate (Normalize_Pathname (Path, Resolve_Links => Opt.Follow_Links_For_Dirs, Case_Sensitive => Case_Sensitive), Mapping => Dir_Sep_Map); end As_RPath; -------------------- -- Relative_RPath -- -------------------- function Relative_RPath (Dest, Src, Origin : String) return String is -- Rpaths are always considered case sensitive, as it's a runtime -- property of dynamic objects, so in case of cross compilation is -- independent of the host's way of handling case sensitivity. RP_Src : constant String := As_RPath (Src, False); RP_Dest : constant String := As_RPath (Dest, True); RP_Dest_Insensitive : constant String := As_RPath (Dest, False); begin declare Len : constant Natural := Common_Path_Prefix_Length (RP_Src, RP_Dest_Insensitive); begin if Len = 0 then -- No common prefix: return an absolute path return RP_Dest; else declare Sep_Mode : Boolean := True; Subdir_Count : Natural := 0; begin -- Compute the relative path from Src to Dest. For this we -- need to find the number of subdirectories from the common -- prefix to Src. for I in RP_Src'First + Len .. RP_Src'Last loop if RP_Src (I) = '/' then Sep_Mode := True; elsif Sep_Mode then -- If the previous characters were separators, we are now -- reading a new subdir. Sep_Mode is initialy True so -- that we get here if the first character we see is not -- a separator. Subdir_Count := Subdir_Count + 1; Sep_Mode := False; end if; end loop; return Origin & "/" & Subdir_Count * "../" & RP_Dest (RP_Dest'First + Len .. RP_Dest'Last); end; end if; end; end Relative_RPath; ------------------ -- Concat_Paths -- ------------------ function Concat_Paths (List : String_Vectors.Vector; Separator : String) return String is Length : Natural := Natural (List.Length - 1) * Separator'Length; begin for Path of List loop Length := Length + Path'Length; end loop; declare Ret : String (1 .. Length); Idx : Integer := 1; begin for Path of List loop Ret (Idx .. Idx + Path'Length - 1) := Path; Idx := Idx + Path'Length; if Idx < Ret'Last then Ret (Idx .. Idx + Separator'Length - 1) := Separator; Idx := Idx + Separator'Length; end if; end loop; return Ret; end; end Concat_Paths; ---------------------- -- To_Argument_List -- ---------------------- function To_Argument_List (List : String_Vectors.Vector) return Argument_List is Ret : Argument_List (1 .. Natural (List.Length)); begin for J in 1 .. List.Last_Index loop Ret (J) := new String'(List (J)); end loop; return Ret; end To_Argument_List; ----------- -- Slice -- ----------- function Slice (List : String_Vectors.Vector; From, To : Positive) return String_Vectors.Vector is Ret : String_Vectors.Vector; begin for J in From .. To loop Ret.Append (List (J)); end loop; return Ret; end Slice; ------------------------------ -- Get_Compiler_Driver_Path -- ------------------------------ function Get_Compiler_Driver_Path (Project : Project_Id; Lang : Language_Ptr) return String_Access is begin if Lang.Config.Compiler_Driver_Path = null then declare CL : constant Language_Maps.Cursor := Compiler_Subst_HTable.Find (Lang.Name); Compiler : constant Name_Id := (if Language_Maps.Has_Element (CL) then Language_Maps.Element (CL) else Name_Id (Lang.Config.Compiler_Driver)); -- If --compiler-subst was used to specify an alternate compiler, -- then Language_Maps.Has_Element (CL). In other case set Compiler -- to the Compiler_Driver from the config file. begin -- No compiler found, return now if Compiler = No_Name then return null; end if; declare Compiler_Name : constant String := (if CodePeer_Mode then "codepeer-gcc" elsif GnatProve_Mode and then Lang.Name = Name_Ada then "gnat2why" else Get_Name_String (Compiler)); begin if Compiler_Name = "" then return null; end if; Lang.Config.Compiler_Driver_Path := Locate_Exec_On_Path (Compiler_Name); if Lang.Config.Compiler_Driver_Path = null then Err.Error_Msg (Gprbuild_Flags, "unable to locate """ & Compiler_Name & '"', Project => Project); return null; end if; end; end; end if; return Lang.Config.Compiler_Driver_Path; end Get_Compiler_Driver_Path; ---------------------------- -- Find_Binding_Languages -- ---------------------------- procedure Find_Binding_Languages (Tree : Project_Tree_Ref; Root_Project : Project_Id) is Data : constant Builder_Data_Access := Builder_Data (Tree); B_Index : Binding_Data; Language_Name : Name_Id; Binder_Driver_Name : File_Name_Type := No_File; Binder_Driver_Path : String_Access; Binder_Prefix : Name_Id; Language : Language_Ptr; Config : Language_Config; Project : Project_List; begin -- Have we already processed this tree ? if Data.There_Are_Binder_Drivers and then Data.Binding /= null then return; end if; if Current_Verbosity = High then Debug_Output ("Find_Binding_Languages for", Debug_Name (Tree)); end if; Data.There_Are_Binder_Drivers := False; Project := Tree.Projects; while Project /= null loop Language := Project.Project.Languages; while Language /= No_Language_Index loop Config := Language.Config; Binder_Driver_Name := Config.Binder_Driver; if Language.First_Source /= No_Source and then Binder_Driver_Name /= No_File then Data.There_Are_Binder_Drivers := True; Language_Name := Language.Name; B_Index := Data.Binding; while B_Index /= null and then B_Index.Language_Name /= Language_Name loop B_Index := B_Index.Next; end loop; if B_Index = null then Get_Name_String (Binder_Driver_Name); Binder_Driver_Path := Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len)); if Binder_Driver_Path = null then Fail_Program (Tree, "unable to find binder driver " & Name_Buffer (1 .. Name_Len)); end if; if Current_Verbosity = High then Debug_Output ("Binder_Driver=" & Binder_Driver_Path.all & " for Lang", Language_Name); end if; if Config.Binder_Prefix = No_Name then Binder_Prefix := Empty_String; else Binder_Prefix := Config.Binder_Prefix; end if; B_Index := Data.Binding; while B_Index /= null loop if Binder_Prefix = B_Index.Binder_Prefix then Fail_Program (Tree, "binding prefix cannot be the same for" & " two languages", Exit_Code => E_General); end if; B_Index := B_Index.Next; end loop; Data.Binding := new Binding_Data_Record' (Language => Language, Language_Name => Language_Name, Binder_Driver_Name => Binder_Driver_Name, Binder_Driver_Path => Binder_Driver_Path, Binder_Prefix => Binder_Prefix, Next => Data.Binding); end if; end if; Language := Language.Next; end loop; Project := Project.Next; end loop; if Root_Project.Qualifier = Aggregate then declare Agg : Aggregated_Project_List := Root_Project.Aggregated_Projects; begin while Agg /= null loop Find_Binding_Languages (Agg.Tree, Agg.Project); Agg := Agg.Next; end loop; end; end if; end Find_Binding_Languages; ---------------- -- Get_Target -- ---------------- function Get_Target return String is begin if Target_Name = null or else Target_Name.all = "" then return Sdefault.Hostname; else return Target_Name.all; end if; end Get_Target; -------------------- -- Locate_Runtime -- -------------------- procedure Locate_Runtime (Project_Tree : Project_Tree_Ref; Language : Name_Id) is function Is_RTS_Directory (Path : String) return Boolean; -- Returns True if Path is a directory for a runtime. This simply check -- that Path has a "adalib" subdirectoy, which is a property for -- runtimes on the project path. function Is_Base_Name (Path : String) return Boolean; -- Returns True if Path has no directory separator ---------------------- -- Is_RTS_Directory -- ---------------------- function Is_RTS_Directory (Path : String) return Boolean is begin return Is_Directory (Path & Directory_Separator & "adalib"); end Is_RTS_Directory; -- Local declarations function Find_Rts_In_Path is new GPR.Env.Find_Name_In_Path (Check_Filename => Is_RTS_Directory); ------------------ -- Is_Base_Name -- ------------------ function Is_Base_Name (Path : String) return Boolean is begin for I in Path'Range loop if Is_Directory_Separator (Path (I)) then return False; end if; end loop; return True; end Is_Base_Name; RTS_Name : constant String := GPR.Conf.Runtime_Name_For (Language); Full_Path : String_Access; begin Full_Path := Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name); if Full_Path /= null then GPR.Conf.Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all)); Free (Full_Path); elsif not Is_Base_Name (RTS_Name) then Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name, Exit_Code => E_General); end if; end Locate_Runtime; ------------------------------ -- Look_For_Default_Project -- ------------------------------ procedure Look_For_Default_Project (Never_Fail : Boolean := False) is begin if No_Project_File then No_Project_File_Found := True; else No_Project_File_Found := False; if Is_Regular_File (Default_Project_File_Name) then Project_File_Name := new String'(Default_Project_File_Name); else -- Check if there is a single project file in the current -- directory. If there is one and only one, use it. declare Dir : Dir_Type; Str : String (1 .. 255); Last : Natural; Single : String_Access := null; begin No_Project_File_Found := True; Open (Dir, "."); loop Read (Dir, Str, Last); exit when Last = 0; if Last > Project_File_Extension'Length and then Is_Regular_File (Str (1 .. Last)) then Canonical_Case_File_Name (Str (1 .. Last)); if Str (Last - Project_File_Extension'Length + 1 .. Last) = Project_File_Extension then No_Project_File_Found := False; if Single = null then Single := new String'(Str (1 .. Last)); else -- There are several project files in the current -- directory. Reset Single to null and exit. Single := null; exit; end if; end if; end if; end loop; Close (Dir); Project_File_Name := Single; end; end if; end if; if No_Project_File_Found or else (Never_Fail and then Project_File_Name = null) then Project_File_Name := new String'(Executable_Prefix_Path & Implicit_Project_File_Path); if not Is_Regular_File (Project_File_Name.all) then Project_File_Name := null; end if; end if; if not Quiet_Output and then Project_File_Name /= null then Put ("using project file "); Put_Line (Project_File_Name.all); end if; end Look_For_Default_Project; ------------------- -- Major_Id_Name -- ------------------- function Major_Id_Name (Lib_Filename : String; Lib_Version : String) return String is Maj_Version : constant String := Lib_Version; Last_Maj : Positive; Last : Positive; Ok_Maj : Boolean := False; begin Last_Maj := Maj_Version'Last; while Last_Maj > Maj_Version'First loop if Maj_Version (Last_Maj) in '0' .. '9' then Last_Maj := Last_Maj - 1; else Ok_Maj := Last_Maj /= Maj_Version'Last and then Maj_Version (Last_Maj) = '.'; if Ok_Maj then Last_Maj := Last_Maj - 1; end if; exit; end if; end loop; if Ok_Maj then Last := Last_Maj; while Last > Maj_Version'First loop if Maj_Version (Last) in '0' .. '9' then Last := Last - 1; else Ok_Maj := Last /= Last_Maj and then Maj_Version (Last) = '.'; if Ok_Maj then Last := Last - 1; Ok_Maj := Maj_Version (Maj_Version'First .. Last) = Lib_Filename; end if; exit; end if; end loop; end if; if Ok_Maj then return Maj_Version (Maj_Version'First .. Last_Maj); else return ""; end if; end Major_Id_Name; ------------------ -- Partial_Name -- ------------------ function Partial_Name (Lib_Name : String; Number : Natural; Object_Suffix : String) return String is Img : constant String := Number'Img; begin return Partial_Prefix & Lib_Name & '_' & Img (Img'First + 1 .. Img'Last) & Object_Suffix; end Partial_Name; ------------------------ -- Put_Resource_Usage -- ------------------------ procedure Put_Resource_Usage (Filename : String) is separate; -------------------------------- -- Project_Compilation_Failed -- -------------------------------- function Project_Compilation_Failed (Prj : Project_Id; Recursive : Boolean := True) return Boolean is use Project_Name_Boolean_Htable; begin if Get (Project_Failure, Prj.Name) then return True; elsif not Recursive then return False; else -- Check all imported projects directly or indirectly declare Plist : Project_List := Prj.All_Imported_Projects; begin while Plist /= null loop if Get (Project_Failure, Plist.Project.Name) then return True; else Plist := Plist.Next; end if; end loop; return False; end; end if; end Project_Compilation_Failed; ----------------------------------- -- Set_Failed_Compilation_Status -- ----------------------------------- procedure Set_Failed_Compilation_Status (Prj : Project_Id) is begin Project_Name_Boolean_Htable.Set (Project_Failure, Prj.Name, True); end Set_Failed_Compilation_Status; ----------------------- -- Shared_Libgcc_Dir -- ----------------------- function Shared_Libgcc_Dir (Run_Time_Dir : String) return String is Path : String (1 .. Run_Time_Dir'Length + 15); Path_Last : constant Natural := Run_Time_Dir'Length; GCC_Index : Natural := 0; begin Path (1 .. Path_Last) := Run_Time_Dir; GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib"); if GCC_Index /= 0 then -- This is gcc 2.8.2: the shared version of libgcc is -- located in the parent directory of "gcc-lib". GCC_Index := GCC_Index - 1; else GCC_Index := Index (Path (1 .. Path_Last), "/lib/"); if GCC_Index = 0 then GCC_Index := Index (Path (1 .. Path_Last), Directory_Separator & "lib" & Directory_Separator); end if; if GCC_Index /= 0 then -- We have found "lib" as a subdirectory in the runtime dir path. -- The declare Subdir : constant String := Interfaces.C.Strings.Value (Libgcc_Subdir_Ptr); begin Path (GCC_Index + 1 .. GCC_Index + Subdir'Length) := Subdir; GCC_Index := GCC_Index + Subdir'Length; end; end if; end if; return Path (1 .. GCC_Index); end Shared_Libgcc_Dir; --------------------- -- Need_To_Compile -- --------------------- procedure Need_To_Compile (Source : GPR.Source_Id; Tree : Project_Tree_Ref; In_Project : Project_Id; Conf_Paths : Config_Paths; Must_Compile : out Boolean; The_ALI : out ALI.ALI_Id; Object_Check : Boolean; Always_Compile : Boolean) is Source_Path : constant String := Get_Name_String (Source.Path.Display_Name); C_Source_Path : constant String := Get_Name_String (Source.Path.Name); Runtime_Source_Dirs : constant Name_List_Index := Source.Language.Config.Runtime_Source_Dirs; Stamp : Time_Stamp_Type; Source_In_Dependencies : Boolean := False; -- Set True if source was found in dependency file of its object file C_Object_Name : String_Access := null; -- The canonical file name for the object file Switches_Name : String_Access := null; -- The file name of the file that contains the switches that were used -- in the last compilation. Num_Ext : Natural; -- Number of extending projects ALI_Project : Project_Id; -- If the ALI file is in the object directory of a project, this is -- the project id. Externally_Built : constant Boolean := In_Project.Externally_Built; -- True if the project of the source is externally built Processed : Name_Id_Set.Set; -- Source files processed for ALI_Closure mode function Process_Makefile_Deps (Dep_Name, Obj_Dir : String) return Boolean; function Process_ALI_Deps (Source : Source_Id; Closure : Boolean) return Boolean; -- Process the dependencies for the current source file for the various -- dependency modes. -- They return True if the file needs to be recompiled. procedure Cleanup; -- Cleanup local variables function Check_Object_File (Source : Source_Id) return Boolean; -- Check object file exists and consistent with source file function Check_Time_Stamps (Path : String; Stamp : Time_Stamp_Type) return Boolean; ----------------------- -- Check_Object_File -- ----------------------- function Check_Object_File (Source : Source_Id) return Boolean is function Obj_Path return String is (Get_Name_String (Source.Object_Path)); begin -- If object file does not exist, of course source needs to be -- compiled. if Source.Object_TS = Empty_Time_Stamp then Source.Object_TS := File_Stamp (Obj_Path); end if; if Source.Object_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Obj_Path); Put_Line (" does not exist"); end if; return False; end if; -- If the object file has been created before the last modification -- of the source, the source needs to be recompiled. if not Opt.Minimal_Recompilation and then Source.Object_TS < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Obj_Path); Put_Line (" has time stamp earlier than source"); end if; return False; end if; if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_T then Put (" object file "); Put (Obj_Path); Put (": "); Put_Line (String (Source.Object_TS)); Put (" source file: "); Put_Line (String (Source.Source_TS)); end if; return True; end Check_Object_File; ----------------------- -- Check_Time_Stamps -- ----------------------- function Check_Time_Stamps (Path : String; Stamp : Time_Stamp_Type) return Boolean is TS : constant Time_Stamp_Type := File_Stamp (Get_Path_Name_Id (Path)); begin if TS /= Empty_Time_Stamp and then TS /= Stamp then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> different time stamp for " & Path); if Debug.Debug_Flag_T then Put_Line (" in ALI file: " & String (Stamp)); Put_Line (" actual file: " & String (TS)); end if; end if; return True; end if; return False; end Check_Time_Stamps; --------------------------- -- Process_Makefile_Deps -- --------------------------- function Process_Makefile_Deps (Dep_Name, Obj_Dir : String) return Boolean is Dep_File : GPR.Util.Text_File; Last_Source : String_Access; Last_TS : Time_Stamp_Type := Empty_Time_Stamp; Last_Obj : Natural; Start : Natural; Finish : Natural; Looping : Boolean := False; -- Set to True at the end of the first Big_Loop for Makefile -- fragments function Is_Time_Stamp (S : String) return Boolean; -- Return True iff S has the format of a Time_Stamp_Type OK : Boolean; ------------------- -- Is_Time_Stamp -- ------------------- function Is_Time_Stamp (S : String) return Boolean is Result : Boolean := False; begin if S'Length = Time_Stamp_Length then Result := True; for J in S'Range loop if S (J) not in '0' .. '9' then Result := False; exit; end if; end loop; end if; return Result; end Is_Time_Stamp; begin Open (Dep_File, Dep_Name); -- If dependency file cannot be open, we need to recompile -- the source. if not Is_Valid (Dep_File) then if Opt.Verbosity_Level > Opt.Low then Put (" -> could not open dependency file "); Put_Line (Dep_Name); end if; return True; end if; -- Loop Big_Loop is executed several times only when the -- dependency file contains several times -- : ... -- When there is only one of such occurence, Big_Loop is exited -- successfully at the beginning of the second loop. Big_Loop : loop declare End_Of_File_Reached : Boolean := False; begin Skip_Loop : loop if End_Of_File (Dep_File) then End_Of_File_Reached := True; exit Skip_Loop; end if; 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; -- If dependency file contains only empty lines or comments, -- then dependencies are unknown, and the source needs to be -- recompiled. if End_Of_File_Reached then -- If we have reached the end of file after the first -- loop, there is nothing else to do. exit Big_Loop when Looping; if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" is empty"); end if; Close (Dep_File); return True; end if; end; Start := 1; Finish := Index (Name_Buffer (1 .. Name_Len), ": "); if Finish = 0 then Finish := Index (Name_Buffer (1 .. Name_Len), (1 => ':', 2 => ASCII.HT)); end if; if Finish /= 0 then 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; Canonical_Case_File_Name (Name_Buffer (Start .. Last_Obj)); end if; -- First line must start with simple name or path name of object -- file, followed by colon. if Finish = 0 then OK := False; else OK := C_Object_Name = null or else Name_Buffer (Start .. Last_Obj) = C_Object_Name.all; if not OK then declare Path : String := Name_Buffer (Start .. Last_Obj); begin Canonical_Case_File_Name (Path); OK := Path = Get_Name_String (Source.Object_Path); end; end if; end if; if not OK then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); if Finish = 0 then Put_Line (" no colon"); else Put (" expected object file name "); Put (C_Object_Name.all); Put (", got "); Put_Line (Name_Buffer (Start .. Last_Obj)); end if; end if; Close (Dep_File); return True; else Start := Finish + 2; -- Process each line Line_Loop : loop declare Line : String := Name_Buffer (1 .. Name_Len); Last : 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; exit Line_Loop when Start > Last; -- 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 \. if Start = Last then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); end if; Close (Dep_File); return True; end if; -- 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 if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); end if; Close (Dep_File); return True; end if; elsif On_Windows and then Line (Finish + 1) not in '\' | ' ' then Finish := Finish + 1; else Line (Finish .. Last - 1) := Line (Finish + 1 .. Last); Last := Last - 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; if Last_Source /= null and then Is_Time_Stamp (Line (Start .. Finish)) then -- If we have a time stamp, check if it is the -- same as the source time stamp. if String (Last_TS) = Line (Start .. Finish) then Free (Last_Source); else if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Last_Source.all); Put_Line (" has modified time stamp"); end if; Free (Last_Source); Close (Dep_File); return True; end if; else -- Check this source declare Src_Name : constant String := Normalize_Pathname (Unescape (Line (Start .. Finish)), Directory => Obj_Dir, Resolve_Links => False); C_Src_Name : String := Src_Name; Src_TS : Time_Stamp_Type; Source_2 : GPR.Source_Id; begin Canonical_Case_File_Name (C_Src_Name); -- If it is original source, set -- Source_In_Dependencies. if C_Src_Name = C_Source_Path then Source_In_Dependencies := True; end if; -- Get the time stamp of the source, which is -- not necessarily a source of any project. Src_TS := File_Stamp (Get_Path_Name_Id (Src_Name)); -- If the source does not exist, we need to -- recompile. if Src_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" does not exist"); end if; Close (Dep_File); return True; -- If the source has been modified after the -- object file, we need to recompile. elsif Object_Check and then Source.Language.Config.Object_Generated and then Src_TS > Source.Object_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" more recent than object file"); end if; Close (Dep_File); return True; else Source_2 := Source_Paths_Htable.Get (Tree.Source_Paths_HT, Get_Path_Name_Id (C_Src_Name)); if Source_2 /= No_Source and then Source_2.Replaced_By /= No_Source then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" has been replaced"); end if; Close (Dep_File); return True; else Last_Source := new String'(Src_Name); Last_TS := Src_TS; end if; end if; end; end if; -- If the source path name ends the line, we are -- done. 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 if; -- Set Looping at the end of the first loop Looping := True; end loop Big_Loop; Close (Dep_File); -- If the original sources were not in the dependency file, then -- we need to recompile. It may mean that we are using a different -- source (different variant) for this object file. if not Source_In_Dependencies then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Source_Path); Put_Line (" is not in the dependencies"); end if; return True; end if; return False; end Process_Makefile_Deps; type Config_Paths_Found is array (Positive range <>) of Boolean; -- Type to record what config files are included in the ALI file ---------------------- -- Process_ALI_Deps -- ---------------------- function Process_ALI_Deps (Source : Source_Id; Closure : Boolean) return Boolean is Text : Text_Buffer_Ptr := Read_Library_Info_From_Full (File_Name_Type (Source.Dep_Path), Source.Dep_TS'Access); Proj : Project_Id; Found : Boolean := False; Preps : String_Sets.Set; -- Preprocessor data files to detect config pragma files by exclusion -- method. If file in D line is absolute filename then it is either -- config pragma file or preprocessor data file. We can detect that -- the file is preprocessor data files by the existence of the A line -- with -- -gnatep= prefix. Config pragma files in D line does not -- have any additional references. Conf_Paths_Found : Config_Paths_Found := (Conf_Paths'Range => False); The_ALI : ALI_Id; begin if Text = null then if Opt.Verbosity_Level > Opt.Low then Put (" -> cannot read "); Put_Line (Get_Name_String (Source.Dep_Path)); end if; return True; end if; -- Read only the necessary lines of the ALI file The_ALI := ALI.Scan_ALI (File_Name_Type (Source.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "APDW"); Free (Text); if Source = Need_To_Compile.Source then Need_To_Compile.The_ALI := The_ALI; elsif Need_To_Compile.Stamp < File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access) then -- We can be here only in Closure mode because -- Source /= Need_To_Compile.Source -- see if condition. if Opt.Verbosity_Level > Opt.Low then Put (" -> ALI file from dependencies "); Put (Get_Name_String (Source.Dep_Name)); Put (" later than "); Put_Line (Get_Name_String (Need_To_Compile.Source.Dep_Name)); end if; return True; elsif Object_Check then Initialize_Source_Record (Source); if not Check_Object_File (Source) then return True; end if; end if; if The_ALI = ALI.No_ALI_Id then if Opt.Verbosity_Level > Opt.Low then Put (" -> "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" is incorrectly formatted"); end if; return True; end if; declare U : Unit_Record renames Units.Table (ALIs.Table (The_ALI).First_Unit); A : String_Access; Gnatep : constant String := "-gnatep="; File : Text_File; procedure Prep_Append (Filename : String); ----------------- -- Prep_Append -- ----------------- procedure Prep_Append (Filename : String) is begin Preps.Include (Normalize_Pathname (Filename, Case_Sensitive => False)); end Prep_Append; begin for J in U.First_Arg .. U.Last_Arg loop A := Args.Table (J); if Starts_With (A.all, Gnatep) then Prep_Append (A (A'First + Gnatep'Length .. A'Last)); -- Extract all definition filenames from preprocessor data -- file. Put it into the Preps too. Open (File, A (A'First + Gnatep'Length .. A'Last)); while Is_Valid (File) and then not End_Of_File (File) loop declare Line : constant String := Get_Line (File); Str : String (Line'Range); Last : Natural; Scan : Positive := Line'First; procedure Scan_String_Literal; -- Scan string literal from Line starting from Scan -- index. ------------------------- -- Scan_String_Literal -- ------------------------- procedure Scan_String_Literal is Was_DQ : Boolean := False; Inside : Boolean := False; begin Last := Str'First - 1; for Idx in Scan .. Line'Last loop if Line (Idx) = '"' then if Inside then if Was_DQ then Last := Last + 1; Str (Last) := '"'; end if; Was_DQ := not Was_DQ; else Inside := True; end if; else if Was_DQ then Scan := Idx; exit; end if; if Inside then Last := Last + 1; Str (Last) := Line (Idx); end if; end if; end loop; end Scan_String_Literal; begin if Line /= "" then case Line (Line'First) is when '*' => Scan_String_Literal; Prep_Append (Str (Str'First .. Last)); when '"' => Scan_String_Literal; Scan_String_Literal; Prep_Append (Str (Str'First .. Last)); when others => null; end case; end if; end; end loop; if Is_Valid (File) then Close (File); end if; end if; end loop; end; -- Check if the ALI's GNAT version matches -- Tree.Shared.Ada_Runtime_Library_Version declare GNAT_Version : constant Name_Id := ALI.ALIs.Table (The_ALI).GNAT_Version; begin if GNAT_Version /= Tree.Shared.Ada_Runtime_Library_Version then if Opt.Verbosity_Level > Opt.Low then Put (" -> GNAT version changed: "); Put ("ALI version = "); Put (Get_Name_String (GNAT_Version)); Put ("; expected version = "); if Tree.Shared.Ada_Runtime_Library_Version /= No_Name then Put_Line (Get_Name_String (Tree.Shared.Ada_Runtime_Library_Version)); else Put_Line ("unknown"); end if; end if; return True; end if; end; if ALI.ALIs.Table (The_ALI).Compile_Errors then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> last compilation had errors"); end if; return True; end if; if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no object generated during last compilation"); end if; return True; end if; if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then return True; end if; -- We need to check that the ALI file is in the correct object -- directory. If it is in the object directory of a project -- that is extended and it depends on a source that is in one -- of its extending projects, then the ALI file is not in the -- correct object directory. ALI_Project := Source.Object_Project; -- Count the extending projects Num_Ext := 0; Proj := ALI_Project; loop Proj := Proj.Extended_By; exit when Proj = No_Project; Num_Ext := Num_Ext + 1; end loop; declare Projects : array (1 .. Num_Ext) of Project_Id; Sfile : File_Name_Type; Dep_Src : GPR.Source_Id; Position : Name_Id_Set.Cursor; Inserted : Boolean; ALI_Rec : ALIs_Record renames ALI.ALIs.Table (The_ALI); begin Proj := ALI_Project; for J in Projects'Range loop Proj := Proj.Extended_By; Projects (J) := Proj; end loop; for D in ALI_Rec.First_Sdep .. ALI_Rec.Last_Sdep loop Sfile := ALI.Sdep.Table (D).Sfile; Dep_Src := Source_Files_Htable.Get (Tree.Source_Files_HT, Sfile); if Closure and then Dep_Src /= No_Source then Processed.Insert (Name_Id (Sfile), Position, Inserted); else Inserted := True; end if; if Inserted and then ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then Found := False; if Dep_Src = No_Source and then ALI.Sdep.Table (D).Checksum = 0 then -- Probably preprocessing dependencies. Look for the -- file in the directory of the source, then the other -- source directories of the project. declare Path : Path_Name_Type := No_Path; File : constant String := Get_Name_String (Sfile); Stamp : Time_Stamp_Type := Empty_Time_Stamp; List : String_List_Id := In_Project.Source_Dirs; Absp : constant Boolean := Is_Absolute_Path (File); -- Config pragma file or preprocessor data file Elem : String_Element; procedure Get_Path (Dir : String); -- If File is in the absolute directory Dir then -- set Path to the absolute path of the file and -- Stamp to its timestamp. Otherwise Path is -- No_Path. -------------- -- Get_Path -- -------------- procedure Get_Path (Dir : String) is begin Set_Name_Buffer (Dir); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (File); Path := Name_Find; Stamp := File_Stamp (Path); if Stamp = Empty_Time_Stamp then Path := No_Path; end if; end Get_Path; begin if Conf_Paths'Length > 0 or else Absp then Path := Path_Name_Type (Sfile); Stamp := File_Stamp (Path); declare Found : Boolean := False; Norm_Path : constant String := Normalize_Pathname (File, Case_Sensitive => False); begin for J in Conf_Paths'Range loop if Conf_Paths (J).Name = Get_Path_Name_Id (Norm_Path) then Found := True; Conf_Paths_Found (J) := True; end if; end loop; if Absp and then not Found and then not Preps.Contains (Norm_Path) then -- Config pragma file is in D line but was -- not referenced from project and -- -gnatec = command line option. if Opt.Verbosity_Level > Opt.Low then Put (" -> """); Put (File); Put_Line (""" not defined in project and " & "-gnatec= command line option"); if Opt.Verbosity_Level > Opt.Medium then Put ("Warning: Dependency file """); Put (Get_Name_String (Source.Dep_Path)); Put_Line (""" contains outdated information " & "about configuration file. "); Put_Line ("Warning: Consider using the " & "-gnateb switch if supported by " & "the compiler."); end if; end if; return True; end if; end; end if; -- Look in the directory of the source if Path = No_Path then Get_Path (Source_Dir_Of (Source)); end if; while Path = No_Path and then List /= Nil_String loop Elem := Tree.Shared.String_Elements.Table (List); Get_Path (Get_Name_String (Elem.Display_Value)); List := Elem.Next; end loop; if Stamp /= ALI.Sdep.Table (D).Stamp then if Opt.Verbosity_Level > Opt.Low then if Stamp = Empty_Time_Stamp then Put (" -> """); Put (Get_Name_String (Sfile)); Put_Line (""" missing"); else Put (" -> different time stamp for "); Put_Line (Get_Name_String (Path)); if Debug.Debug_Flag_T then Put (" in ALI file: "); Put_Line (String (ALI.Sdep.Table (D).Stamp)); Put (" actual file: "); Put_Line (String (Stamp)); end if; end if; end if; return True; end if; end; else if Dep_Src = No_Source and then not Is_Ada_Predefined_File_Name (Sfile) and then not Is_Pragmas_Config_File (Sfile) then if Opt.Verbosity_Level > Opt.Low then Put (" -> """); Put (Get_Name_String (Sfile)); Put_Line (""" missing"); end if; return True; end if; if Dep_Src = No_Source and then Is_Pragmas_Config_File (Sfile) then declare F_And_Cksum_Found : Boolean := False; Timestamp_Found : Boolean := False; begin for J in Conf_Paths'Range loop declare File : constant File_Name_Type := Get_File_Name_Id (Ada.Directories.Simple_Name (Get_Name_String (Conf_Paths (J).Name))); Cksum : Word; SCksum : constant Word := ALI.Sdep.Table (D).Checksum; begin Cksum := Calculate_Checksum (Conf_Paths (J).Name); if File = Sfile and then Cksum = SCksum and then not Conf_Paths_Found (J) then F_And_Cksum_Found := True; if File_Stamp (Conf_Paths (J).Name) = ALI.Sdep.Table (D).Stamp then Conf_Paths_Found (J) := True; Timestamp_Found := True; exit; end if; end if; end; end loop; -- If the file is missing from our internal config -- file list, recompute the config file checksum -- from the * .ali file and compare it. -- This prevents total project recompilation if -- --gnatec is declared at Compiler package -- switches level. if not F_And_Cksum_Found then if Calculate_Checksum (File => Path_Name_Type (Sfile)) = ALI.Sdep.Table (D).Checksum then F_And_Cksum_Found := True; if File_Stamp (Path_Name_Type (Sfile)) = ALI.Sdep.Table (D).Stamp then Timestamp_Found := True; end if; end if; end if; if not F_And_Cksum_Found then -- Config pragma file is in D line but was -- not referenced from project and -- -gnatec= command line option. if Opt.Verbosity_Level > Opt.Low then Put (" -> """); Put (Get_Name_String (Sfile)); Put_Line (""" not defined in project and " & "-gnatec= command line option"); end if; return True; end if; if not Timestamp_Found then if Opt.Verbosity_Level > Opt.Low then Put (" -> different time stamp from the " & "ALI file for the config file "); Put_Line (Get_Name_String (Sfile)); end if; return True; end if; end; end if; while Dep_Src /= No_Source loop if not Dep_Src.Locally_Removed and then Dep_Src.Unit /= No_Unit_Index then Found := True; Initialize_Source_Record (Dep_Src); if Dep_Src.Checksum /= ALI.Sdep.Table (D).Checksum then -- Checksum saved in source file differ from -- ALI D line checksum. case Dep_Src.Checksum_Src is when No_File => -- Checksum was not saved. Save it. Dep_Src.Checksum_Src := Source.File; Dep_Src.Checksum := ALI.Sdep.Table (D).Checksum; when True_Checksum => -- Checksum calculated from file and D -- record from ALI does not fit it. We -- have to rebuild source. return True; when others => if Dep_Src.File = Dep_Src.Checksum_Src then -- The checksum saved from the D record -- of the source itself. It is more -- reliable than the D line of the -- other sources. Rebuild the source. return True; end if; -- If we have 2 different sources with D -- lines referenced to the Dep_Src with -- different checksum, we should calculate -- checksum from source file. declare Prev_Src : constant File_Name_Type := Dep_Src.Checksum_Src; Prev_Chs : constant Word := Dep_Src.Checksum; Prev_Sid : Source_Id; Success : Boolean; begin if Calculate_Checksum (Dep_Src) then if Dep_Src.Checksum /= Prev_Chs then -- Saved D line checksum from -- previos source was wrond. We -- have to rebuild previous -- source file. Prev_Sid := Source_Files_Htable.Get (Tree.Source_Files_HT, Prev_Src); -- Delete obsolete ALI file if -- exists. Delete_File (Get_Name_String (Prev_Sid.Dep_Path), Success); -- Insert the source into the -- queue again. Queue.Insert (Source => (Tree, Prev_Sid, Closure => True), With_Roots => True, Repeat => True); end if; if Dep_Src.Checksum /= ALI.Sdep.Table (D).Checksum then -- If calculated checksum differ -- from D line checksum, we have -- to compile this Source. return True; end if; end if; end; end case; end if; if (Opt.Minimal_Recompilation and then ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS) or else (ALI.Sdep.Table (D).Stamp = Dep_Src.Source_TS and then Opt.Checksum_Recompilation) then -- If minimal recompilation is in action, -- replace the stamp of the source file in -- the table if checksums match. if Calculate_Checksum (Dep_Src) then if Dep_Src.Checksum = ALI.Sdep.Table (D).Checksum then if Opt.Verbosity_Level > Opt.Low then Put (" "); Put (Get_Name_String (ALI.Sdep.Table (D).Sfile)); Put (": up to date, " & "different timestamps " & "but same checksum"); New_Line; end if; ALI.Sdep.Table (D).Stamp := Dep_Src.Source_TS; elsif Opt.Checksum_Recompilation then if Opt.Verbosity_Level > Opt.Low then Put (" "); Put (Get_Name_String (ALI.Sdep.Table (D).Sfile)); Put_Line (": changed, same timestamp but" & " different checksums"); end if; return True; end if; end if; end if; if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> different time stamp for "); Put_Line (Get_Name_String (Sfile)); if Debug.Debug_Flag_T then Put (" in ALI file: "); Put_Line (String (ALI.Sdep.Table (D).Stamp)); Put (" actual file: "); Put_Line (String (Dep_Src.Source_TS)); end if; end if; return True; end if; for J in Projects'Range loop if Dep_Src.Project = Projects (J) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> dependency file not in " & "object directory of project """ & Get_Name_String (Projects (Projects'Last).Display_Name) & """"); end if; return True; end if; end loop; if Closure and then Dep_Src /= Source and then Dep_Src.Kind /= Sep and then not Dep_Src.Project.Externally_Built and then Process_ALI_Deps (Dep_Src, True) then return True; end if; exit; end if; Dep_Src := Dep_Src.Next_With_File_Name; end loop; -- If the source was not found and the runtime source -- directory is defined, check if the file exists there, -- and if it does, check its timestamp. if not Found and then (Runtime_Source_Dirs /= No_Name_List or else Is_Absolute_Path (Get_Name_String (Sfile))) then if Is_Absolute_Path (Get_Name_String (Sfile)) then if Check_Time_Stamps (Get_Name_String (Sfile), ALI.Sdep.Table (D).Stamp) then return True; end if; else declare R_Dirs : Name_List_Index := Runtime_Source_Dirs; begin while R_Dirs /= No_Name_List loop declare Nam_Nod : constant Name_Node := Tree.Shared.Name_Lists.Table (R_Dirs); begin if Check_Time_Stamps (Get_Name_String (Nam_Nod.Name) & Directory_Separator & Get_Name_String (Sfile), ALI.Sdep.Table (D).Stamp) then return True; end if; R_Dirs := Nam_Nod.Next; end; end loop; end; end if; end if; end if; end if; end loop; -- Check that all the config files have been found in the ALI file if Source.Language.Config.Config_File_Dependency_Support then for J in Conf_Paths_Found'Range loop if not Conf_Paths_Found (J) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> new config file " & Get_Name_String (Conf_Paths (J).Display_Name)); end if; return True; end if; end loop; end if; end; return False; end Process_ALI_Deps; ------------- -- Cleanup -- ------------- procedure Cleanup is begin Free (C_Object_Name); Free (Switches_Name); end Cleanup; begin The_ALI := ALI.No_ALI_Id; -- Never attempt to compile header files if Source.Language.Config.Kind = File_Based and then Source.Kind = Spec then Must_Compile := False; return; end if; if Force_Compilations then Must_Compile := Always_Compile or else not Externally_Built; return; end if; -- Fail if no compiler if Source.Language.Config.Compiler_Driver = No_File then Fail_Program (Tree, "no compiler for """ & Get_Name_String (Source.File) & '"'); end if; -- No need to compile if there is no "compiler" if Source.Language.Config.Compiler_Driver = Empty_File then Must_Compile := False; return; end if; if Source.Language.Config.Object_Generated and then Object_Check then C_Object_Name := new String'(Get_Name_String (Source.Object)); Canonical_Case_File_Name (C_Object_Name.all); if Source.Switches_Path /= No_Path then Switches_Name := new String'(Get_Name_String (Source.Switches_Path)); end if; end if; if Opt.Verbosity_Level > Opt.Low then Put (" Checking "); Put (Source_Path); if Source.Index /= 0 then Put (" at"); Put (Source.Index'Img); end if; Put_Line (" ... "); end if; -- No need to compile if project is externally built if Externally_Built then if Opt.Verbosity_Level > Opt.Low then Put_Line (" project is externally built"); end if; Must_Compile := False; Cleanup; return; end if; if not Source.Language.Config.Object_Generated then -- If no object file is generated, the "compiler" need to be invoked -- if there is no dependency file. if Source.Language.Config.Dependency_Kind = None then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no object file generated"); end if; Must_Compile := True; Cleanup; return; end if; elsif Object_Check and then not Check_Object_File (Source) then Must_Compile := True; Cleanup; return; end if; if Source.Language.Config.Dependency_Kind /= None then -- If there is no dependency file, then the source needs to be -- recompiled and the dependency file need to be created. Stamp := File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access); if Stamp = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" does not exist"); end if; Must_Compile := True; Cleanup; return; end if; if In_Project.Library and then Source.Unit /= No_Unit_Index and then Source.In_Interfaces then declare Dep_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Dep_Name), Get_Name_String (In_Project.Library_ALI_Dir.Name), Resolve_Links => Opt.Follow_Links_For_Files); Lib_Stamp : constant Time_Stamp_Type := File_Stamp (Dep_Path); begin if Lib_Stamp = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> file "); Put (Dep_Path); Put_Line (" does not exist"); end if; In_Project.Need_Build := True; elsif Lib_Stamp < Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> file "); Put (Dep_Path); Put (" has timestamp earlier than "); Put_Line (Get_Name_String (Source.Dep_Path)); end if; In_Project.Need_Build := True; end if; end; end if; -- If the ALI file has been created after the object file, we need -- to recompile. if Object_Check and then Source.Language.Config.Dependency_Kind in ALI_Dependency and then Source.Object_TS < Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> ALI file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" has timestamp later than object file"); end if; Must_Compile := True; Cleanup; return; end if; -- The source needs to be recompiled if the source has been modified -- after the dependency file has been created. if not Opt.Minimal_Recompilation and then Stamp < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" has time stamp earlier than source"); end if; Must_Compile := True; Cleanup; return; end if; end if; -- If we are checking the switches and there is no switches file, then -- the source needs to be recompiled and the switches file need to be -- created. if Check_Switches and then Switches_Name /= null then if Source.Switches_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> switches file "); Put (Switches_Name.all); Put_Line (" does not exist"); end if; Must_Compile := True; Cleanup; return; end if; -- The source needs to be recompiled if the source has been modified -- after the switches file has been created. if not Opt.Minimal_Recompilation and then Source.Switches_TS < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> switches file "); Put (Switches_Name.all); Put_Line (" has time stamp earlier than source"); end if; Must_Compile := True; Cleanup; return; end if; end if; case Source.Language.Config.Dependency_Kind is when None => null; when Makefile => if Process_Makefile_Deps (Get_Name_String (Source.Dep_Path), Get_Name_String (Source.Project.Object_Directory.Display_Name)) then Must_Compile := True; Cleanup; return; end if; when ALI_File => if Process_ALI_Deps (Source, Closure => False) then Must_Compile := True; Cleanup; return; end if; when ALI_Closure => if Process_ALI_Deps (Source, Closure => True) then Must_Compile := True; Cleanup; return; end if; end case; -- If we are here, then everything is OK, and we don't need -- to recompile. if not Object_Check and then Opt.Verbosity_Level > Opt.Low then Put_Line (" -> up to date"); end if; Must_Compile := False; Cleanup; end Need_To_Compile; --------------------------- -- Set_Default_Verbosity -- --------------------------- procedure Set_Default_Verbosity is Gpr_Verbosity : String_Access := Getenv ("GPR_VERBOSITY"); begin if Gpr_Verbosity /= null and then Gpr_Verbosity'Length > 0 then declare Verbosity : String := Gpr_Verbosity.all; begin To_Lower (Verbosity); if Verbosity = "quiet" then Quiet_Output := True; Verbose_Mode := False; Verbosity_Level := Opt.None; elsif Verbosity = "default" then Quiet_Output := False; Verbose_Mode := False; Verbosity_Level := Opt.None; elsif Verbosity = "verbose" or else Verbosity = "verbose_low" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.Low; elsif Verbosity = "verbose_medium" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.Medium; elsif Verbosity = "verbose_high" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.High; end if; end; end if; Free (Gpr_Verbosity); end Set_Default_Verbosity; -------------------- -- Set_Gprls_Mode -- -------------------- procedure Set_Gprls_Mode is begin Gprls_Mode := True; end Set_Gprls_Mode; --------------- -- Knowledge -- --------------- package body Knowledge is separate; ---------------- -- Check_Diff -- ---------------- function Check_Diff (Ts1, Ts2 : Time_Stamp_Type; Max_Drift : Duration := 5.0) return Boolean is use Ada.Calendar; function Get (T : String) return Time is (Time_Of (Year => Year_Number'Value (T (T'First .. T'First + 3)), Month => Month_Number'Value (T (T'First + 4 .. T'First + 5)), Day => Day_Number'Value (T (T'First + 6 .. T'First + 7)), Hour => Hour_Number'Value (T (T'First + 8 .. T'First + 9)), Minute => Minute_Number'Value (T (T'First + 10 .. T'First + 11)), Second => Second_Number'Value (T (T'First + 12 .. T'First + 13)))); T1 : constant Time := Get (String (Ts1)); T2 : constant Time := Get (String (Ts2)); begin return abs (T1 - T2) <= Max_Drift; end Check_Diff; ----------------------------- -- Check_Maximum_Processes -- ----------------------------- procedure Check_Maximum_Processes is Already_Reported : Boolean := False; procedure Check_It (Value : in out Positive); -------------- -- Check_It -- -------------- procedure Check_It (Value : in out Positive) is Max_Proc : constant := 63; begin if Value > Max_Proc then Value := Max_Proc; if not Already_Reported then Already_Reported := True; Put_Line ("On Windows the maximum number of simultaneous processes is" & Max_Proc'Img); end if; end if; end Check_It; begin if On_Windows then Check_It (Opt.Maximum_Compilers); Check_It (Opt.Maximum_Binders); Check_It (Opt.Maximum_Linkers); end if; end Check_Maximum_Processes; -------------------- -- Project_Output -- -------------------- package body Project_Output is ---------------- -- Write_Char -- ---------------- procedure Write_A_Char (C : Character) is begin Write_A_String ((1 => C)); end Write_A_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin Write_A_String ((1 => ASCII.LF)); end Write_Eol; -------------------- -- Write_A_String -- -------------------- procedure Write_A_String (S : String) is Str : String (1 .. S'Length); begin if S'Length > 0 then Str := S; if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then GPR.Com.Fail ("disk full"); end if; end if; end Write_A_String; end Project_Output; ---------------------------- -- Command Line Arguments -- ---------------------------- package Command_Line_Arguments is new GNAT.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); ----------------------------------- -- Delete_Command_Line_Arguments -- ----------------------------------- procedure Delete_Command_Line_Arguments is begin Command_Line_Arguments.Set_Last (0); end Delete_Command_Line_Arguments; -------------------------------- -- Get_Command_Line_Arguments -- -------------------------------- procedure Get_Command_Line_Arguments is File : File_Type; procedure Read_File (Name : String); -- Read argument file with name Name and put the arguments into table -- Command_Line_Arguments. --------------- -- Read_File -- --------------- procedure Read_File (Name : String) is begin begin Open (File, In_File, Name); exception when others => Fail_Program (null, "could not open argument file """ & Name & '"', Exit_Code => E_General); end; while not End_Of_File (File) loop Get_Line (File, Name_Buffer, Name_Len); if Name_Len /= 0 and then (Name_Len = 1 or else Name_Buffer (1 .. 2) /= "--") then if Name_Buffer (1) = '@' then Fail_Program (null, "invalid argument """ & Name_Buffer (1 .. Name_Len) & """ in argument file", Exit_Code => E_General); else Command_Line_Arguments.Append (Name_Find); end if; end if; end loop; Close (File); end Read_File; begin for J in 1 .. Argument_Count loop declare Arg : constant String := Argument (J); begin if Arg'Length /= 0 then if Arg (Arg'First) = '@' then if Arg'Length = 1 then Fail_Program (null, "invalid argument '@' on the command line", Exit_Code => E_General); else Read_File (Arg (Arg'First + 1 .. Arg'Last)); end if; else Name_Len := Arg'Length; Name_Buffer (1 .. Name_Len) := Arg; Command_Line_Arguments.Append (Name_Find); end if; end if; end; end loop; end Get_Command_Line_Arguments; -------------------------------- -- Last_Command_Line_Argument -- -------------------------------- function Last_Command_Line_Argument return Natural is begin return Command_Line_Arguments.Last; end Last_Command_Line_Argument; --------------------------- -- Command_Line_Argument -- --------------------------- function Command_Line_Argument (Rank : Positive) return String is begin if Rank > Command_Line_Arguments.Last then return ""; else return Get_Name_String (Command_Line_Arguments.Table (Rank)); end if; end Command_Line_Argument; begin declare Ext : String_Access := GNAT.OS_Lib.Get_Target_Executable_Suffix; begin Set_Name_Buffer (Ext.all); Executable_Extension_On_Target := Name_Enter; Free (Ext); end; end GPR.Util;