-- -- Copyright (C) 2024, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception -- with Ada.Characters.Handling; with Ada.Assertions; with GNATCOLL.OS.FS; pragma Warnings (Off, ".* is not referenced"); with GPR2.Build.Source.Sets; pragma Warnings (On, ".* is not referenced"); with GPR2.Build.Tree_Db; with GPR2.Project.Attribute; with GPR2.Project.View.Set; package body GPR2.Build.Actions.Compile is function Lang_Img (Lang : Language_Id) return Filename_Type is (Filename_Type (Ada.Characters.Handling.To_Lower (GPR2.Image (Lang)))); ------------- -- Command -- ------------- overriding procedure Compute_Command (Self : in out Object; Args : out GNATCOLL.OS.Process.Argument_List; Env : out GNATCOLL.OS.Process.Environment_Dict) is procedure Add_Attr (Id : Q_Attribute_Id; Idx : PAI.Object; Is_List : Boolean); procedure Add_Options_With_Arg (Attr : Project.Attribute.Object; Arg : String); procedure Add_Config_File; procedure Add_Include_Path; procedure Add_Mapping_File; Lang_Idx : constant PAI.Object := PAI.Create (Self.Lang); Src_Idx : constant PAI.Object := PAI.Create (Value_Type (Self.Src_Name.Simple_Name), GPR2.File_Names_Case_Sensitive, Object'Class (Self).Src_Index); -------------- -- Add_Attr -- -------------- procedure Add_Attr (Id : Q_Attribute_Id; Idx : PAI.Object; Is_List : Boolean) is Attr : constant GPR2.Project.Attribute.Object := Self.View.Attribute (Id, Idx); begin if not Attr.Is_Defined then return; end if; if Is_List then for Val of Attr.Values loop Args.Append (Val.Text); end loop; else Args.Append (Attr.Value.Text); end if; end Add_Attr; --------------------- -- Add_Config_File -- --------------------- procedure Add_Config_File is use GNATCOLL.OS.FS; procedure Check_Exceptions_For (View : GPR2.Project.View.Object; FD : GNATCOLL.OS.FS.File_Descriptor); procedure Write_Exception (FD : GNATCOLL.OS.FS.File_Descriptor; Is_Spec : Boolean; Unit_Name : String; Src : String; Index : Unit_Index); procedure Write_Tmpl (FD : GNATCOLL.OS.FS.File_Descriptor; Attr_Id : Q_Attribute_Id); Cfg_File_Opt : constant GPR2.Project.Attribute.Object := Self.View.Attribute (PRA.Compiler.Config_File_Switches, Lang_Idx); Spec_Ext : constant Project.Attribute.Object := Self.View.Attribute (PRA.Naming.Spec_Suffix, Lang_Idx); Body_Ext : constant Project.Attribute.Object := Self.View.Attribute (PRA.Naming.Body_Suffix, Lang_Idx); Dot_Repl : constant Project.Attribute.Object := Self.View.Attribute (PRA.Naming.Dot_Replacement); Casing : constant Project.Attribute.Object := Self.View.Attribute (PRA.Naming.Casing); Done_Except : Containers.Name_Set; -------------------------- -- Check_Exceptions_For -- -------------------------- procedure Check_Exceptions_For (View : GPR2.Project.View.Object; FD : GNATCOLL.OS.FS.File_Descriptor) is begin for Attr of View.Attributes (PRA.Naming.Spec) loop declare Unit : constant String := Attr.Index.Value; Src : constant String := Attr.Value.Text; Idx : constant Unit_Index := (if Attr.Value.Has_At_Pos then Attr.Value.At_Pos else No_Index); begin if not Done_Except.Contains (Name_Type (Unit & "%s")) then Write_Exception (FD => FD, Is_Spec => True, Unit_Name => Unit, Src => Src, Index => Idx); Done_Except.Include (Name_Type (Unit & "%s")); end if; end; end loop; for Attr of View.Attributes (PRA.Naming.Body_N) loop declare Unit : constant String := Attr.Index.Value; Src : constant String := Attr.Value.Text; Idx : constant Unit_Index := (if Attr.Value.Has_At_Pos then Attr.Value.At_Pos else No_Index); begin if not Done_Except.Contains (Name_Type (Unit & "%b")) then Write_Exception (FD => FD, Is_Spec => False, Unit_Name => Unit, Src => Src, Index => Idx); Done_Except.Include (Name_Type (Unit & "%b")); end if; end; end loop; end Check_Exceptions_For; --------------------- -- Write_Exception -- --------------------- procedure Write_Exception (FD : GNATCOLL.OS.FS.File_Descriptor; Is_Spec : Boolean; Unit_Name : String; Src : String; Index : Unit_Index) is Attr : Project.Attribute.Object; Last : Natural; begin if Is_Spec then if Index = No_Index then Attr := Self.View.Attribute (PRA.Compiler.Config_Spec_File_Name, Lang_Idx); else Attr := Self.View.Attribute (PRA.Compiler.Config_Spec_File_Name_Index, Lang_Idx); end if; else if Index = No_Index then Attr := Self.View.Attribute (PRA.Compiler.Config_Body_File_Name, Lang_Idx); else Attr := Self.View.Attribute (PRA.Compiler.Config_Body_File_Name_Index, Lang_Idx); end if; end if; if not Attr.Is_Defined then return; end if; declare Cnt : constant String := Attr.Value.Text; Idx : constant String := (if Index = No_Index then "" else Index'Image); begin Last := Cnt'First; for J in Cnt'First .. Cnt'Last - 1 loop if Cnt (J) = '%' then Write (FD, Cnt (Last .. J - 1)); Last := J + 2; case Cnt (J + 1) is when 'u' => Write (FD, Unit_Name); when 'f' => Write (FD, Src); when 'i' => Write (FD, Idx (Idx'First + 1 .. Idx'Last)); when others => Write (FD, "%" & Cnt (J + 1)); end case; end if; end loop; Write (FD, Cnt (Last .. Cnt'Last)); end; end Write_Exception; ---------------- -- Write_Tmpl -- ---------------- procedure Write_Tmpl (FD : GNATCOLL.OS.FS.File_Descriptor; Attr_Id : Q_Attribute_Id) is Attr : constant Project.Attribute.Object := Self.View.Attribute (Attr_Id, Lang_Idx); Last : Natural; begin if not Attr.Is_Defined then return; end if; declare Cnt : String renames Attr.Value.Text; begin Last := Cnt'First; for J in Cnt'First .. Cnt'Last - 1 loop if Cnt (J) = '%' then Write (FD, Cnt (Last .. J - 1)); Last := J + 2; case Cnt (J + 1) is when 'b' => Write (FD, Body_Ext.Value.Text); when 's' => Write (FD, Spec_Ext.Value.Text); when 'c' => Write (FD, Casing.Value.Text); when 'd' => Write (FD, Dot_Repl.Value.Text); when others => Write (FD, "%" & Cnt (J + 1)); end case; end if; end loop; Write (FD, Cnt (Last .. Cnt'Last) & ASCII.LF); end; end Write_Tmpl; begin if not Cfg_File_Opt.Is_Defined then return; end if; declare File : constant Tree_Db.Temp_File := Self.Get_Or_Create_Temp_File (Lang_Img (Self.Lang) & "_config", Global); begin if File.FD /= Null_FD then Write_Tmpl (File.FD, PRA.Compiler.Config_Spec_File_Name_Pattern); Write_Tmpl (File.FD, PRA.Compiler.Config_Body_File_Name_Pattern); Check_Exceptions_For (Self.View, File.FD); if Self.View.Is_Extending then for V of Self.View.Extended loop Check_Exceptions_For (V, File.FD); end loop; end if; Close (File.FD); end if; Add_Options_With_Arg (Cfg_File_Opt, String (File.Path)); end; end Add_Config_File; ---------------------- -- Add_Include_Path -- ---------------------- procedure Add_Include_Path is Attr : GPR2.Project.Attribute.Object; function Inc_Path_File return Filename_Type; -- Get or create a temporary include path file for the view ------------------- -- Inc_Path_File -- ------------------- function Inc_Path_File return Filename_Type is use GNATCOLL.OS.FS; Tmp : constant Tree_Db.Temp_File := Self.Get_Or_Create_Temp_File (Lang_Img (Self.Lang) & "_inc_path", Actions.Global); begin if Tmp.FD /= Null_FD then for P of Self.View.Include_Path (Ada_Language) loop Write (Tmp.FD, P.String_Value & ASCII.LF); end loop; Close (Tmp.FD); end if; return Tmp.Path; end Inc_Path_File; begin Attr := Self.View.Attribute (PRA.Compiler.Include_Path_File, Lang_Idx); if Attr.Is_Defined then declare Inc_File : constant Filename_Type := Inc_Path_File; Full_Path : constant GPR2.Path_Name.Object := Self.View.Object_Directory.Compose (Inc_File); begin Env.Include (String (Attr.Value.Text), Full_Path.String_Value); end; return; end if; Attr := Self.View.Attribute (PRA.Compiler.Include_Switches_Via_Spec, Lang_Idx); if Attr.Is_Defined then -- need to create a temp file with the -- path, and then another temp file used as gcc spec in the form: -- -- * cc1 : -- + @-I -- -- Where 'cc1' is the first value in the list, and '-I' the second -- one. -- -- Finally (and it's hardcoded in gpr1) add switch -- "-spec= declare Inc_File : constant Filename_Type := Inc_Path_File; Full_Path : constant GPR2.Path_Name.Object := Self.View.Object_Directory.Compose (Inc_File); Spec_File : constant Tree_Db.Temp_File := Self.Get_Or_Create_Temp_File (Lang_Img (Self.Lang) & "_spec_inc_path", Global); use GNATCOLL.OS.FS; begin if Spec_File.FD /= Null_FD then Write (Spec_File.FD, "* " & Attr.Values.First_Element.Text & " :" & ASCII.LF); Write (Spec_File.FD, "+@-I " & Full_Path.String_Value & ASCII.LF); Close (Spec_File.FD); end if; Args.Append ("-specs=" & String (Spec_File.Path)); end; return; end if; Attr := Self.View.Attribute (PRA.Compiler.Include_Switches, Lang_Idx); if Attr.Is_Defined then for Path of Self.View.Include_Path (Ada_Language) loop Add_Options_With_Arg (Attr, Path.String_Value); end loop; end if; raise Standard.Ada.Assertions.Assertion_Error with "Cannot determine ways to transmit include path to the toolchain"; end Add_Include_Path; ---------------------- -- Add_Mapping_File -- ---------------------- procedure Add_Mapping_File is use GNATCOLL.OS.FS; Attr : constant Project.Attribute.Object := Self.View.Attribute (PRA.Compiler.Mapping_File_Switches, Lang_Idx); begin if not Attr.Is_Defined then -- Nothing to do return; end if; declare Map_File : constant Tree_Db.Temp_File := Self.Get_Or_Create_Temp_File ("ada_mapping", Global); S_Suffix : constant String := Self.View.Attribute (PRA.Compiler.Mapping_Spec_Suffix, Lang_Idx).Value.Text; B_Suffix : constant String := Self.View.Attribute (PRA.Compiler.Mapping_Body_Suffix, Lang_Idx).Value.Text; use Standard.Ada.Characters.Handling; begin if Map_File.FD /= Null_FD then for S of Self.View.Visible_Sources loop if S.Has_Naming_Exception and then S.Language = Ada_Language then for U of S.Units loop declare Key : constant String := To_Lower (String (U.Full_Name)) & (if U.Kind = S_Spec then S_Suffix else B_Suffix); begin Write (Map_File.FD, Key & ASCII.LF); Write (Map_File.FD, String (S.Path_Name.Simple_Name) & ASCII.LF); Write (Map_File.FD, S.Path_Name.String_Value & ASCII.LF); end; end loop; end if; end loop; -- ??? Missing the list of excluded sources Close (Map_File.FD); end if; Add_Options_With_Arg (Attr, String (Map_File.Path)); end; end Add_Mapping_File; -------------------------- -- Add_Options_With_Arg -- -------------------------- procedure Add_Options_With_Arg (Attr : Project.Attribute.Object; Arg : String) is begin if not Attr.Is_Defined then return; end if; for J in Attr.Values.First_Index .. Attr.Values.Last_Index - 1 loop Args.Append (Attr.Values.Element (J).Text); end loop; Args.Append (Attr.Values.Last_Element.Text & Arg); end Add_Options_With_Arg; begin Add_Attr (PRA.Compiler.Driver, Lang_Idx, False); Add_Attr (PRA.Compiler.Leading_Required_Switches, Lang_Idx, True); -- ??? need to filter out builder switches from command line -- Add_Attr (PRA.Builder.Switches, Lang_Idx, True); Add_Attr (PRA.Compiler.Required_Switches, Lang_Idx, True); Add_Attr (PRA.Compiler.Switches, Src_Idx, True); -- ??? TODO: command line -cargs options -- ??? TODO: command line -cargs:ada options if Self.View.Is_Library and then Self.View.Library_Kind /= "static" then Add_Attr (PRA.Compiler.Pic_Option, Lang_Idx, True); end if; declare Attr : constant Project.Attribute.Object := Self.View.Attribute (PRA.Compiler.Dependency_Switches, Lang_Idx); begin if Attr.Is_Defined then Add_Options_With_Arg (Attr, String (Object'Class (Self).Dependency_File)); end if; end; Add_Include_Path; Add_Mapping_File; Add_Config_File; declare Input : constant Path_Name.Object := Self.Src_Name; Rel : constant Filename_Type := Input.Relative_Path (Self.Working_Directory); Index : constant Unit_Index := Object'Class (Self).Src_Index; Idx : constant String := (if Index = No_Index then "" else Index'Image); begin if Rel'Length < Input.Value'Length then Args.Append (String (Rel)); else Args.Append (Input.String_Value); end if; if Index /= No_Index then declare Sw : constant GPR2.Project.Attribute.Object := Self.View.Attribute (PRA.Compiler.Multi_Unit_Switches, Lang_Idx); begin pragma Assert (Sw.Is_Defined, "Compiler'Multi_Unit_Switches is not defined in the " & "config project"); Add_Options_With_Arg (Sw, Idx (Idx'First + 1 .. Idx'Last)); end; end if; end; declare Sw : constant GPR2.Project.Attribute.Object := Self.View.Attribute (PRA.Compiler.Object_File_Switches, Lang_Idx); begin if Sw.Is_Defined then Add_Options_With_Arg (Sw, String (Self.Object_File.Path.Simple_Name)); else -- ??? TODO modify the KB to have a proper default here Args.Append ("-o"); Args.Append (String (Self.Object_File.Path.Simple_Name)); end if; end; Add_Attr (PRA.Compiler.Trailing_Required_Switches, Lang_Idx, True); end Compute_Command; ----------------------- -- Compute_Signature -- ----------------------- overriding procedure Compute_Signature (Self : in out Object) is use GPR2.Build.Signature; Art : Artifacts.Files.Object; begin Self.Signature.Clear; -- ??? Need to process deps units Art := Artifacts.Files.Create (Self.Input.Path_Name); Self.Signature.Add_Artifact (Art); Art := Self.Obj_File; Self.Signature.Add_Artifact (Art); Self.Signature.Store (Self.Tree.Db_Filename_Path (Object'Class (Self).UID)); end Compute_Signature; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : in out Object; Src : GPR2.Build.Source.Object) is BN : constant Simple_Name := Src.Path_Name.Base_Filename; O_Suff : constant Simple_Name := Simple_Name (Src.Owning_View.Attribute (PRA.Compiler.Object_File_Suffix, PAI.Create (Src.Language)).Value.Text); Obj_Path : GPR2.Path_Name.Object; begin Self.Ctxt := Src.Owning_View; Self.Src_Name := Src.Path_Name; Self.Lang := Src.Language; Self.Traces := Create ("ACTION_COMPILE"); Obj_Path := Lookup (Self.Ctxt, BN & O_Suff, False, True); if not Obj_Path.Is_Defined then Obj_Path := Self.Ctxt.Object_Directory.Compose (BN & O_Suff); end if; Self.Obj_File := Artifacts.Files.Create (Obj_Path); end Initialize; ------------ -- Lookup -- ------------ ------------ -- Lookup -- ------------ function Lookup (V : GPR2.Project.View.Object; BN : Simple_Name; In_Lib_Dir : Boolean; Must_Exist : Boolean) return GPR2.Path_Name.Object is Todo : GPR2.Project.View.Set.Object; Done : GPR2.Project.View.Set.Object; Current : GPR2.Project.View.Object := V; Candidate : GPR2.Path_Name.Object; begin loop if In_Lib_Dir and then Current.Is_Library then Candidate := Current.Library_Ali_Directory.Compose (BN); exit when not Must_Exist or else Candidate.Exists; end if; if Current.Kind in With_Object_Dir_Kind then Candidate := Current.Object_Directory.Compose (BN); exit when not Must_Exist or else Candidate.Exists; end if; if Current.Is_Extending then Todo.Union (Current.Extended); Todo.Difference (Done); end if; if Todo.Is_Empty then return GPR2.Path_Name.Undefined; else Done.Include (Current); Current := Todo.First_Element; Todo.Delete_First; end if; end loop; return Candidate; end Lookup; ----------------------- -- On_Tree_Insertion -- ----------------------- overriding procedure On_Tree_Insertion (Self : Object; Db : in out GPR2.Build.Tree_Db.Object; Messages : in out GPR2.Log.Object) is UID : constant Actions.Action_Id'Class := Object'Class (Self).UID; begin Db.Add_Output (UID, Self.Obj_File, Messages); if Messages.Has_Error then return; end if; end On_Tree_Insertion; --------- -- UID -- --------- overriding function UID (Self : Object) return Actions.Action_Id'Class is Result : constant Compile_Id := (Name_Len => Self.Src_Name.Simple_Name'Length, Lang => Self.Lang, Ctxt => Self.Ctxt, Src_Name => Self.Src_Name.Simple_Name); begin return Result; end UID; end GPR2.Build.Actions.Compile;