URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [mlib-prj.adb] - Rev 729
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- M L I B . P R J -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with ALI; use ALI; with Gnatvsn; use Gnatvsn; with Makeutl; use Makeutl; with MLib.Fil; use MLib.Fil; with MLib.Tgt; use MLib.Tgt; with MLib.Utl; use MLib.Utl; with Opt; with Output; use Output; with Prj.Com; use Prj.Com; with Prj.Env; use Prj.Env; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; with Switch; use Switch; with Table; with Targparm; use Targparm; with Tempdir; with Types; use Types; with Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.HTable; with Interfaces.C_Streams; use Interfaces.C_Streams; with System; use System; with System.Case_Util; use System.Case_Util; package body MLib.Prj is Prj_Add_Obj_Files : Types.Int; pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files"); Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0; -- Indicates if object files in pragmas Linker_Options (found in the -- binder generated file) should be taken when linking a stand-alone -- library. False for Windows, True for other platforms. ALI_Suffix : constant String := ".ali"; B_Start : String_Ptr := new String'("b~"); -- Prefix of bind file, changed to b__ for VMS S_Osinte_Ads : File_Name_Type := No_File; -- Name_Id for "s-osinte.ads" S_Dec_Ads : File_Name_Type := No_File; -- Name_Id for "dec.ads" Arguments : String_List_Access := No_Argument; -- Used to accumulate arguments for the invocation of gnatbind and of the -- compiler. Also used to collect the interface ALI when copying the ALI -- files to the library directory. Argument_Number : Natural := 0; -- Index of the last argument in Arguments Initial_Argument_Max : constant := 10; -- Where does the magic constant 10 come from??? No_Main_String : aliased String := "-n"; No_Main : constant String_Access := No_Main_String'Access; Output_Switch_String : aliased String := "-o"; Output_Switch : constant String_Access := Output_Switch_String'Access; Compile_Switch_String : aliased String := "-c"; Compile_Switch : constant String_Access := Compile_Switch_String'Access; No_Warning_String : aliased String := "-gnatws"; No_Warning : constant String_Access := No_Warning_String'Access; Auto_Initialize : constant String := "-a"; -- List of objects to put inside the library Object_Files : Argument_List_Access; package Objects is new Table.Table (Table_Name => "Mlib.Prj.Objects", Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 50, Table_Increment => 100); package Objects_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => Hash, Equal => "="); -- List of ALI files Ali_Files : Argument_List_Access; package ALIs is new Table.Table (Table_Name => "Mlib.Prj.Alis", Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 50, Table_Increment => 100); -- List of options set in the command line Options : Argument_List_Access; package Opts is new Table.Table (Table_Name => "Mlib.Prj.Opts", Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 5, Table_Increment => 100); -- All the ALI file in the library package Library_ALIs is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => Hash, Equal => "="); -- The ALI files in the interface sets package Interface_ALIs is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => Hash, Equal => "="); -- The ALI files that have been processed to check if the corresponding -- library unit is in the interface set. package Processed_ALIs is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => Hash, Equal => "="); -- The projects imported directly or indirectly package Processed_Projects is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => Hash, Equal => "="); -- The library projects imported directly or indirectly package Library_Projs is new Table.Table ( Table_Component_Type => Project_Id, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 10, Table_Name => "Make.Library_Projs"); type Build_Mode_State is (None, Static, Dynamic, Relocatable); procedure Add_Argument (S : String); -- Add one argument to Arguments array, if array is full, double its size function ALI_File_Name (Source : String) return String; -- Return the ALI file name corresponding to a source procedure Check (Filename : String); -- Check if filename is a regular file. Fail if it is not procedure Check_Context; -- Check each object files in table Object_Files -- Fail if any of them is not a regular file procedure Copy_Interface_Sources (For_Project : Project_Id; In_Tree : Project_Tree_Ref; Interfaces : Argument_List; To_Dir : Path_Name_Type); -- Copy the interface sources of a SAL to directory To_Dir procedure Display (Executable : String); -- Display invocation of gnatbind and of the compiler with the arguments -- in Arguments, except when Quiet_Output is True. function Index (S, Pattern : String) return Natural; -- Return the last occurrence of Pattern in S, or 0 if none procedure Process_Binder_File (Name : String); -- For Stand-Alone libraries, get the Linker Options in the binder -- generated file. procedure Reset_Tables; -- Make sure that all the above tables are empty -- (Objects, Ali_Files, Options). function SALs_Use_Constructors return Boolean; -- Indicate if Stand-Alone Libraries are automatically initialized using -- the constructor mechanism. ------------------ -- Add_Argument -- ------------------ procedure Add_Argument (S : String) is begin if Argument_Number = Arguments'Last then declare New_Args : constant String_List_Access := new String_List (1 .. 2 * Arguments'Last); begin -- Copy the String_Accesses and set them to null in Arguments -- so that they will not be deallocated by the call to -- Free (Arguments). New_Args (Arguments'Range) := Arguments.all; Arguments.all := (others => null); Free (Arguments); Arguments := New_Args; end; end if; Argument_Number := Argument_Number + 1; Arguments (Argument_Number) := new String'(S); end Add_Argument; ------------------- -- ALI_File_Name -- ------------------- function ALI_File_Name (Source : String) return String is begin -- If the source name has an extension, then replace it with -- the ALI suffix. for Index in reverse Source'First + 1 .. Source'Last loop if Source (Index) = '.' then return Source (Source'First .. Index - 1) & ALI_Suffix; end if; end loop; -- If there is no dot, or if it is the first character, just add the -- ALI suffix. return Source & ALI_Suffix; end ALI_File_Name; ------------------- -- Build_Library -- ------------------- procedure Build_Library (For_Project : Project_Id; In_Tree : Project_Tree_Ref; Gnatbind : String; Gnatbind_Path : String_Access; Gcc : String; Gcc_Path : String_Access; Bind : Boolean := True; Link : Boolean := True) is Maximum_Size : Integer; pragma Import (C, Maximum_Size, "__gnat_link_max"); -- Maximum number of bytes to put in an invocation of gnatbind Size : Integer; -- The number of bytes for the invocation of gnatbind Warning_For_Library : Boolean := False; -- Set True for first warning for a unit missing from the interface set Current_Proj : Project_Id; Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed; -- Set True if library needs to be linked with libgnarl Libdecgnat_Needed : Boolean := False; -- On OpenVMS, set True if library needs to be linked with libdecgnat Object_Directory_Path : constant String := Get_Name_String (For_Project.Object_Directory.Display_Name); Standalone : constant Boolean := For_Project.Standalone_Library /= No; Project_Name : constant String := Get_Name_String (For_Project.Name); Current_Dir : constant String := Get_Current_Dir; Lib_Filename : String_Access; Lib_Dirpath : String_Access; Lib_Version : String_Access := new String'(""); The_Build_Mode : Build_Mode_State := None; Success : Boolean := False; Library_Options : Variable_Value := Nil_Variable_Value; Driver_Name : Name_Id := No_Name; In_Main_Object_Directory : Boolean := True; Foreign_Sources : Boolean; Rpath : String_Access := null; -- Allocated only if Path Option is supported Rpath_Last : Natural := 0; -- Index of last valid character of Rpath Initial_Rpath_Length : constant := 200; -- Initial size of Rpath, when first allocated Path_Option : String_Access := Linker_Library_Path_Option; -- If null, Path Option is not supported. Not a constant so that it can -- be deallocated. First_ALI : File_Name_Type := No_File; -- Store the ALI file name of a source of the library (the first found) procedure Add_ALI_For (Source : File_Name_Type); -- Add name of the ALI file corresponding to Source to the Arguments procedure Add_Rpath (Path : String); -- Add a path name to Rpath function Check_Project (P : Project_Id) return Boolean; -- Returns True if P is For_Project or a project extended by For_Project procedure Check_Libs (ALI_File : String; Main_Project : Boolean); -- Set Libgnarl_Needed if the ALI_File indicates that there is a need -- to link with -lgnarl (this is the case when there is a dependency -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file -- indicates that there is a need to link with -ldecgnat (this is the -- case when there is a dependency on dec.ads). procedure Process (The_ALI : File_Name_Type); -- Check if the closure of a library unit which is or should be in the -- interface set is also in the interface set. Issue a warning for each -- missing library unit. procedure Process_Imported_Libraries; -- Add the -L and -l switches for the imported Library Project Files, -- and, if Path Option is supported, the library directory path names -- to Rpath. ----------------- -- Add_ALI_For -- ----------------- procedure Add_ALI_For (Source : File_Name_Type) is ALI : constant String := ALI_File_Name (Get_Name_String (Source)); ALI_Id : File_Name_Type; begin if Bind then Add_Argument (ALI); end if; Name_Len := 0; Add_Str_To_Name_Buffer (S => ALI); ALI_Id := Name_Find; -- Add the ALI file name to the library ALIs if Bind then Library_ALIs.Set (ALI_Id, True); end if; -- Set First_ALI, if not already done if First_ALI = No_File then First_ALI := ALI_Id; end if; end Add_ALI_For; --------------- -- Add_Rpath -- --------------- procedure Add_Rpath (Path : String) is procedure Double; -- Double Rpath size ------------ -- Double -- ------------ procedure Double is New_Rpath : constant String_Access := new String (1 .. 2 * Rpath'Length); begin New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last); Free (Rpath); Rpath := New_Rpath; end Double; -- Start of processing for Add_Rpath begin -- If first path, allocate initial Rpath if Rpath = null then Rpath := new String (1 .. Initial_Rpath_Length); Rpath_Last := 0; else -- Otherwise, add a path separator between two path names if Rpath_Last = Rpath'Last then Double; end if; Rpath_Last := Rpath_Last + 1; Rpath (Rpath_Last) := Path_Separator; end if; -- Increase Rpath size until it is large enough while Rpath_Last + Path'Length > Rpath'Last loop Double; end loop; -- Add the path name Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path; Rpath_Last := Rpath_Last + Path'Length; end Add_Rpath; ------------------- -- Check_Project -- ------------------- function Check_Project (P : Project_Id) return Boolean is begin if P = For_Project then return True; elsif P /= No_Project then declare Proj : Project_Id; begin Proj := For_Project; while Proj.Extends /= No_Project loop if P = Proj.Extends then return True; end if; Proj := Proj.Extends; end loop; end; end if; return False; end Check_Project; ---------------- -- Check_Libs -- ---------------- procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is Lib_File : File_Name_Type; Text : Text_Buffer_Ptr; Id : ALI.ALI_Id; begin if Libgnarl_Needed /= Yes or else (Main_Project and then OpenVMS_On_Target) then -- Scan the ALI file Name_Len := ALI_File'Length; Name_Buffer (1 .. Name_Len) := ALI_File; Lib_File := Name_Find; Text := Read_Library_Info (Lib_File, True); Id := ALI.Scan_ALI (F => Lib_File, T => Text, Ignore_ED => False, Err => True, Read_Lines => "D"); Free (Text); -- Look for s-osinte.ads in the dependencies for Index in ALI.ALIs.Table (Id).First_Sdep .. ALI.ALIs.Table (Id).Last_Sdep loop if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then Libgnarl_Needed := Yes; if Main_Project then For_Project.Libgnarl_Needed := Yes; else exit; end if; elsif OpenVMS_On_Target then if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then Libdecgnat_Needed := True; end if; end if; end loop; end if; end Check_Libs; ------------- -- Process -- ------------- procedure Process (The_ALI : File_Name_Type) is Text : Text_Buffer_Ptr; Idread : ALI_Id; First_Unit : ALI.Unit_Id; Last_Unit : ALI.Unit_Id; Unit_Data : Unit_Record; Afile : File_Name_Type; begin -- Nothing to do if the ALI file has already been processed. -- This happens if an interface imports another interface. if not Processed_ALIs.Get (The_ALI) then Processed_ALIs.Set (The_ALI, True); Text := Read_Library_Info (The_ALI); if Text /= null then Idread := Scan_ALI (F => The_ALI, T => Text, Ignore_ED => False, Err => True); Free (Text); if Idread /= No_ALI_Id then First_Unit := ALI.ALIs.Table (Idread).First_Unit; Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; -- Process both unit (spec and body) if the body is needed -- by the spec (inline or generic). Otherwise, just process -- the spec. if First_Unit /= Last_Unit and then not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL then First_Unit := Last_Unit; end if; for Unit in First_Unit .. Last_Unit loop Unit_Data := ALI.Units.Table (Unit); -- Check if each withed unit which is in the library is -- also in the interface set, if it has not yet been -- processed. for W in Unit_Data.First_With .. Unit_Data.Last_With loop Afile := Withs.Table (W).Afile; if Afile /= No_File and then Library_ALIs.Get (Afile) and then not Processed_ALIs.Get (Afile) then if not Interface_ALIs.Get (Afile) then if not Warning_For_Library then Write_Str ("Warning: In library project """); Get_Name_String (Current_Proj.Name); To_Mixed (Name_Buffer (1 .. Name_Len)); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Line (""""); Warning_For_Library := True; end if; Write_Str (" Unit """); Get_Name_String (Withs.Table (W).Uname); To_Mixed (Name_Buffer (1 .. Name_Len - 2)); Write_Str (Name_Buffer (1 .. Name_Len - 2)); Write_Line (""" is not in the interface set"); Write_Str (" but it is needed by "); case Unit_Data.Utype is when Is_Spec => Write_Str ("the spec of "); when Is_Body => Write_Str ("the body of "); when others => null; end case; Write_Str (""""); Get_Name_String (Unit_Data.Uname); To_Mixed (Name_Buffer (1 .. Name_Len - 2)); Write_Str (Name_Buffer (1 .. Name_Len - 2)); Write_Line (""""); end if; -- Now, process this unit Process (Afile); end if; end loop; end loop; end if; end if; end if; end Process; -------------------------------- -- Process_Imported_Libraries -- -------------------------------- procedure Process_Imported_Libraries is Current : Project_Id; procedure Process_Project (Project : Project_Id); -- Process Project and its imported projects recursively. -- Add any library projects to table Library_Projs. --------------------- -- Process_Project -- --------------------- procedure Process_Project (Project : Project_Id) is Imported : Project_List; begin -- Nothing to do if process has already been processed if not Processed_Projects.Get (Project.Name) then Processed_Projects.Set (Project.Name, True); -- Call Process_Project recursively for any imported project. -- We first process the imported projects to guarantee that -- we have a proper reverse order for the libraries. Imported := Project.Imported_Projects; while Imported /= null loop if Imported.Project /= No_Project then Process_Project (Imported.Project); end if; Imported := Imported.Next; end loop; -- If it is a library project, add it to Library_Projs if Project /= For_Project and then Project.Library then Library_Projs.Increment_Last; Library_Projs.Table (Library_Projs.Last) := Project; -- Check if because of this library we need to use libgnarl if Libgnarl_Needed = Unknown then if Project.Libgnarl_Needed = Unknown and then Project.Object_Directory /= No_Path_Information then -- Check if libgnarl is needed for this library declare Object_Dir_Path : constant String := Get_Name_String (Project.Object_Directory. Display_Name); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; begin Open (Object_Dir, Object_Dir_Path); -- For all entries in the object directory loop Read (Object_Dir, Filename, Last); exit when Last = 0; -- Check if it is an object file if Is_Obj (Filename (1 .. Last)) then declare Object_Path : constant String := Normalize_Pathname (Object_Dir_Path & Directory_Separator & Filename (1 .. Last)); ALI_File : constant String := Ext_To (Object_Path, "ali"); begin if Is_Regular_File (ALI_File) then -- Find out if for this ALI file, -- libgnarl is necessary. Check_Libs (ALI_File, Main_Project => False); if Libgnarl_Needed = Yes then Project.Libgnarl_Needed := Yes; For_Project.Libgnarl_Needed := Yes; exit; end if; end if; end; end if; end loop; Close (Object_Dir); end; end if; if Project.Libgnarl_Needed = Yes then Libgnarl_Needed := Yes; For_Project.Libgnarl_Needed := Yes; end if; end if; end if; end if; end Process_Project; -- Start of processing for Process_Imported_Libraries begin -- Build list of library projects imported directly or indirectly, -- in the reverse order. Process_Project (For_Project); -- Add the -L and -l switches and, if the Rpath option is supported, -- add the directory to the Rpath. As the library projects are in the -- wrong order, process from the last to the first. for Index in reverse 1 .. Library_Projs.Last loop Current := Library_Projs.Table (Index); Get_Name_String (Current.Library_Dir.Display_Name); Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Name_Buffer (1 .. Name_Len)); if Path_Option /= null then Add_Rpath (Name_Buffer (1 .. Name_Len)); end if; Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-l" & Get_Name_String (Current.Library_Name)); end loop; end Process_Imported_Libraries; Path_FD : File_Descriptor := Invalid_FD; -- Used for setting the source and object paths -- Start of processing for Build_Library begin Reset_Tables; -- Fail if project is not a library project if not For_Project.Library then Com.Fail ("project """ & Project_Name & """ has no library"); end if; -- Do not attempt to build the library if it is externally built if For_Project.Externally_Built then return; end if; -- If this is the first time Build_Library is called, get the Name_Id -- of "s-osinte.ads". if S_Osinte_Ads = No_File then Name_Len := 0; Add_Str_To_Name_Buffer ("s-osinte.ads"); S_Osinte_Ads := Name_Find; end if; if S_Dec_Ads = No_File then Name_Len := 0; Add_Str_To_Name_Buffer ("dec.ads"); S_Dec_Ads := Name_Find; end if; -- We work in the object directory Change_Dir (Object_Directory_Path); if Standalone then -- Call gnatbind only if Bind is True if Bind then if Gnatbind_Path = null then Com.Fail ("unable to locate " & Gnatbind); end if; if Gcc_Path = null then Com.Fail ("unable to locate " & Gcc); end if; -- Allocate Arguments, if it is the first time we see a standalone -- library. if Arguments = No_Argument then Arguments := new String_List (1 .. Initial_Argument_Max); end if; -- Add "-n -o b~<lib>.adb (b__<lib>.adb on VMS) -L<lib>_" Argument_Number := 2; Arguments (1) := No_Main; Arguments (2) := Output_Switch; if OpenVMS_On_Target then B_Start := new String'("b__"); end if; Add_Argument (B_Start.all & Get_Name_String (For_Project.Library_Name) & ".adb"); -- Make sure that the init procedure is never "adainit" Get_Name_String (For_Project.Library_Name); if Name_Buffer (1 .. Name_Len) = "ada" then Add_Argument ("-Lada_"); else Add_Argument ("-L" & Get_Name_String (For_Project.Library_Name)); end if; if For_Project.Lib_Auto_Init and then SALs_Use_Constructors then Add_Argument (Auto_Initialize); end if; -- Check if Binder'Default_Switches ("Ada") is defined. If it is, -- add these switches to call gnatbind. declare Binder_Package : constant Package_Id := Value_Of (Name => Name_Binder, In_Packages => For_Project.Decl.Packages, Shared => In_Tree.Shared); begin if Binder_Package /= No_Package then declare Defaults : constant Array_Element_Id := Value_Of (Name => Name_Default_Switches, In_Arrays => In_Tree.Shared.Packages.Table (Binder_Package).Decl.Arrays, Shared => In_Tree.Shared); Switches : Variable_Value := Nil_Variable_Value; Switch : String_List_Id := Nil_String; begin if Defaults /= No_Array_Element then Switches := Value_Of (Index => Name_Ada, Src_Index => 0, In_Array => Defaults, Shared => In_Tree.Shared); if not Switches.Default then Switch := Switches.Values; while Switch /= Nil_String loop Add_Argument (Get_Name_String (In_Tree.Shared.String_Elements.Table (Switch).Value)); Switch := In_Tree.Shared.String_Elements. Table (Switch).Next; end loop; end if; end if; end; end if; end; end if; -- Get all the ALI files of the project file. We do that even if -- Bind is False, so that First_ALI is set. declare Unit : Unit_Index; begin Library_ALIs.Reset; Interface_ALIs.Reset; Processed_ALIs.Reset; Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= No_Unit_Index loop if Unit.File_Names (Impl) /= null and then not Unit.File_Names (Impl).Locally_Removed then if Check_Project (Unit.File_Names (Impl).Project) then if Unit.File_Names (Spec) = null then -- Add the ALI file only if it is not a subunit declare Src_Ind : constant Source_File_Index := Sinput.P.Load_Project_File (Get_Name_String (Unit.File_Names (Impl).Path.Name)); begin if not Sinput.P.Source_File_Is_Subunit (Src_Ind) then Add_ALI_For (Unit.File_Names (Impl).File); exit when not Bind; end if; end; else Add_ALI_For (Unit.File_Names (Impl).File); exit when not Bind; end if; end if; elsif Unit.File_Names (Spec) /= null and then not Unit.File_Names (Spec).Locally_Removed and then Check_Project (Unit.File_Names (Spec).Project) then Add_ALI_For (Unit.File_Names (Spec).File); exit when not Bind; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; end; -- Continue setup and call gnatbind if Bind is True if Bind then -- Get an eventual --RTS from the ALI file if First_ALI /= No_File then declare T : Text_Buffer_Ptr; A : ALI_Id; begin -- Load the ALI file T := Read_Library_Info (First_ALI, True); -- Read it A := Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False); if A /= No_ALI_Id then for Index in ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).First_Arg .. ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).Last_Arg loop -- If --RTS found, add switch to call gnatbind declare Arg : String_Ptr renames Args.Table (Index); begin if Arg'Length >= 6 and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" then Add_Argument (Arg.all); exit; end if; end; end loop; end if; end; end if; -- Set the paths -- First the source path if For_Project.Include_Path_File = No_Path then Get_Directories (Project_Tree => In_Tree, For_Project => For_Project, Activity => Compilation, Languages => Ada_Only); Create_New_Path_File (In_Tree.Shared, Path_FD, For_Project.Include_Path_File); Write_Path_File (Path_FD); Path_FD := Invalid_FD; end if; if Current_Source_Path_File_Of (In_Tree.Shared) /= For_Project.Include_Path_File then Set_Current_Source_Path_File_Of (In_Tree.Shared, For_Project.Include_Path_File); Set_Path_File_Var (Project_Include_Path_File, Get_Name_String (For_Project.Include_Path_File)); end if; -- Then, the object path Get_Directories (Project_Tree => In_Tree, For_Project => For_Project, Activity => SAL_Binding, Languages => Ada_Only); declare Path_File_Name : Path_Name_Type; begin Create_New_Path_File (In_Tree.Shared, Path_FD, Path_File_Name); Write_Path_File (Path_FD); Path_FD := Invalid_FD; Set_Path_File_Var (Project_Objects_Path_File, Get_Name_String (Path_File_Name)); Set_Current_Source_Path_File_Of (In_Tree.Shared, Path_File_Name); end; -- Display the gnatbind command, if not in quiet output Display (Gnatbind); Size := 0; for J in 1 .. Argument_Number loop Size := Size + Arguments (J)'Length + 1; end loop; -- Invoke gnatbind with the arguments if the size is not too large if Size <= Maximum_Size then Spawn (Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success); -- Otherwise create a temporary response file else declare FD : File_Descriptor; Path : Path_Name_Type; Args : Argument_List (1 .. 1); EOL : constant String (1 .. 1) := (1 => ASCII.LF); Status : Integer; Succ : Boolean; Quotes_Needed : Boolean; Last_Char : Natural; Ch : Character; begin Tempdir.Create_Temp_File (FD, Path); Args (1) := new String'("@" & Get_Name_String (Path)); for J in 1 .. Argument_Number loop -- Check if the argument should be quoted Quotes_Needed := False; Last_Char := Arguments (J)'Length; for K in Arguments (J)'Range loop Ch := Arguments (J) (K); if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then Quotes_Needed := True; exit; end if; end loop; if Quotes_Needed then -- Quote the argument, doubling '"' declare Arg : String (1 .. Arguments (J)'Length * 2 + 2); begin Arg (1) := '"'; Last_Char := 1; for K in Arguments (J)'Range loop Ch := Arguments (J) (K); Last_Char := Last_Char + 1; Arg (Last_Char) := Ch; if Ch = '"' then Last_Char := Last_Char + 1; Arg (Last_Char) := '"'; end if; end loop; Last_Char := Last_Char + 1; Arg (Last_Char) := '"'; Status := Write (FD, Arg'Address, Last_Char); end; else Status := Write (FD, Arguments (J) (Arguments (J)'First)'Address, Last_Char); end if; if Status /= Last_Char then Fail ("disk full"); end if; Status := Write (FD, EOL (1)'Address, 1); if Status /= 1 then Fail ("disk full"); end if; end loop; Close (FD); -- And invoke gnatbind with this response file Spawn (Gnatbind_Path.all, Args, Success); Delete_File (Get_Name_String (Path), Succ); if not Succ then null; end if; end; end if; if not Success then Com.Fail ("could not bind standalone library " & Get_Name_String (For_Project.Library_Name)); end if; end if; -- Compile the binder generated file only if Link is true if Link then -- Set the paths Set_Ada_Paths (Project => For_Project, In_Tree => In_Tree, Including_Libraries => True); -- Invoke <gcc> -c b__<lib>.adb -- Allocate Arguments, if first time we see a standalone library if Arguments = No_Argument then Arguments := new String_List (1 .. Initial_Argument_Max); end if; Argument_Number := 2; Arguments (1) := Compile_Switch; Arguments (2) := No_Warning; if OpenVMS_On_Target then B_Start := new String'("b__"); end if; Add_Argument (B_Start.all & Get_Name_String (For_Project.Library_Name) & ".adb"); -- If necessary, add the PIC option if PIC_Option /= "" then Add_Argument (PIC_Option); end if; -- Get the back-end switches and --RTS from the ALI file if First_ALI /= No_File then declare T : Text_Buffer_Ptr; A : ALI_Id; begin -- Load the ALI file T := Read_Library_Info (First_ALI, True); -- Read it A := Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False); if A /= No_ALI_Id then for Index in ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).First_Arg .. ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).Last_Arg loop -- Do not compile with the front end switches except -- for --RTS. declare Arg : String_Ptr renames Args.Table (Index); begin if not Is_Front_End_Switch (Arg.all) or else Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" then Add_Argument (Arg.all); end if; end; end loop; end if; end; end if; -- Now all the arguments are set, compile binder generated file Display (Gcc); Spawn (Gcc_Path.all, Arguments (1 .. Argument_Number), Success); if not Success then Com.Fail ("could not compile binder generated file for library " & Get_Name_String (For_Project.Library_Name)); end if; -- Process binder generated file for pragmas Linker_Options Process_Binder_File (Arguments (3).all & ASCII.NUL); end if; end if; -- Build the library only if Link is True if Link then -- If attributes Library_GCC or Linker'Driver were specified, get the -- driver name. if For_Project.Config.Shared_Lib_Driver /= No_File then Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver); end if; -- If attribute Library_Options was specified, add these options Library_Options := Value_Of (Name_Library_Options, For_Project.Decl.Attributes, In_Tree.Shared); if not Library_Options.Default then declare Current : String_List_Id; Element : String_Element; begin Current := Library_Options.Values; while Current /= Nil_String loop Element := In_Tree.Shared.String_Elements.Table (Current); Get_Name_String (Element.Value); if Name_Len /= 0 then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(Name_Buffer (1 .. Name_Len)); end if; Current := Element.Next; end loop; end; end if; Lib_Dirpath := new String'(Get_Name_String (For_Project.Library_Dir.Display_Name)); Lib_Filename := new String'(Get_Name_String (For_Project.Library_Name)); case For_Project.Library_Kind is when Static => The_Build_Mode := Static; when Dynamic => The_Build_Mode := Dynamic; when Relocatable => The_Build_Mode := Relocatable; if PIC_Option /= "" then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(PIC_Option); end if; end case; -- Get the library version, if any if For_Project.Lib_Internal_Name /= No_Name then Lib_Version := new String'(Get_Name_String (For_Project.Lib_Internal_Name)); end if; -- Add the objects found in the object directory and the object -- directories of the extended files, if any, except for generated -- object files (b~.. or B__..) from extended projects. -- When there are one or more extended files, only add an object file -- if no object file with the same name have already been added. In_Main_Object_Directory := True; -- For gnatmake, when the project specifies more than just Ada as a -- language (even if course we could not find any source file for -- the other languages), we will take all object files found in the -- object directories. Since we know the project supports at least -- Ada, we just have to test whether it has at least two languages, -- and not care about the sources. Foreign_Sources := For_Project.Languages.Next /= null; Current_Proj := For_Project; loop if Current_Proj.Object_Directory /= No_Path_Information then -- The following code gets far too indented ... suggest some -- procedural abstraction here. How about making this declare -- block a named procedure??? declare Object_Dir_Path : constant String := Get_Name_String (Current_Proj.Object_Directory .Display_Name); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; Id : Name_Id; begin Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); -- For all entries in the object directory loop Read (Object_Dir, Filename, Last); exit when Last = 0; -- Check if it is an object file if Is_Obj (Filename (1 .. Last)) then declare Object_Path : constant String := Normalize_Pathname (Object_Dir_Path & Directory_Separator & Filename (1 .. Last)); Object_File : constant String := Filename (1 .. Last); C_Filename : String := Object_File; begin Canonical_Case_File_Name (C_Filename); -- If in the object directory of an extended -- project, do not consider generated object files. if In_Main_Object_Directory or else Last < 5 or else C_Filename (1 .. B_Start'Length) /= B_Start.all then Name_Len := 0; Add_Str_To_Name_Buffer (C_Filename); Id := Name_Find; if not Objects_Htable.Get (Id) then declare ALI_File : constant String := Ext_To (C_Filename, "ali"); ALI_Path : constant String := Ext_To (Object_Path, "ali"); Add_It : Boolean; Fname : File_Name_Type; Proj : Project_Id; Index : Unit_Index; begin -- The following assignment could use -- a comment ??? Add_It := Foreign_Sources or else (Last >= 5 and then C_Filename (1 .. B_Start'Length) = B_Start.all); if Is_Regular_File (ALI_Path) then -- If there is an ALI file, check if -- the object file should be added to -- the library. If there are foreign -- sources we put all object files in -- the library. if not Add_It then Index := Units_Htable.Get_First (In_Tree.Units_HT); while Index /= null loop if Index.File_Names (Impl) /= null then Proj := Index.File_Names (Impl) .Project; Fname := Index.File_Names (Impl).File; elsif Index.File_Names (Spec) /= null then Proj := Index.File_Names (Spec) .Project; Fname := Index.File_Names (Spec).File; else Proj := No_Project; end if; Add_It := Proj /= No_Project; -- If the source is in the -- project or a project it -- extends, we may put it in -- the library. if Add_It then Add_It := Check_Project (Proj); end if; -- But we don't, if the ALI file -- does not correspond to the -- unit. if Add_It then declare F : constant String := Ext_To (Get_Name_String (Fname), "ali"); begin Add_It := F = ALI_File; end; end if; exit when Add_It; Index := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; end if; if Add_It then Objects_Htable.Set (Id, True); Objects.Append (new String'(Object_Path)); -- Record the ALI file ALIs.Append (new String'(ALI_Path)); -- Find out if for this ALI file, -- libgnarl or libdecgnat is -- necessary. Check_Libs (ALI_Path, True); end if; elsif Foreign_Sources then Objects.Append (new String'(Object_Path)); end if; end; end if; end if; end; end if; end loop; Close (Dir => Object_Dir); exception when Directory_Error => Com.Fail ("cannot find object directory """ & Get_Name_String (Current_Proj.Object_Directory.Display_Name) & """"); end; end if; exit when Current_Proj.Extends = No_Project; In_Main_Object_Directory := False; Current_Proj := Current_Proj.Extends; end loop; -- Add the -L and -l switches for the imported Library Project Files, -- and, if Path Option is supported, the library directory path names -- to Rpath. Process_Imported_Libraries; -- Link with libgnat and possibly libgnarl Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory); -- If Path Option supported, add libgnat directory path name to Rpath if Path_Option /= null then declare Libdir : constant String := Lib_Directory; GCC_Index : Natural := 0; begin Add_Rpath (Libdir); -- For shared libraries, add to the Path Option the directory -- of the shared version of libgcc. if The_Build_Mode /= Static then GCC_Index := Index (Libdir, "/lib/"); if GCC_Index = 0 then GCC_Index := Index (Libdir, Directory_Separator & "lib" & Directory_Separator); end if; if GCC_Index /= 0 then Add_Rpath (Libdir (Libdir'First .. GCC_Index + 3)); end if; end if; end; end if; if Libgnarl_Needed = Yes then Opts.Increment_Last; if The_Build_Mode = Static then Opts.Table (Opts.Last) := new String'("-lgnarl"); else Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl")); end if; end if; if Libdecgnat_Needed then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory & "/../declib"); Opts.Increment_Last; if The_Build_Mode = Static then Opts.Table (Opts.Last) := new String'("-ldecgnat"); else Opts.Table (Opts.Last) := new String'(Shared_Lib ("decgnat")); end if; end if; Opts.Increment_Last; if The_Build_Mode = Static then Opts.Table (Opts.Last) := new String'("-lgnat"); else Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat")); end if; -- If Path Option is supported, add the necessary switch with the -- content of Rpath. As Rpath contains at least libgnat directory -- path name, it is guaranteed that it is not null. if Path_Option /= null then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(Path_Option.all & Rpath (1 .. Rpath_Last)); Free (Path_Option); Free (Rpath); end if; Object_Files := new Argument_List' (Argument_List (Objects.Table (1 .. Objects.Last))); Ali_Files := new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last))); Options := new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last))); -- We fail if there are no object to put in the library -- (Ada or foreign objects). if Object_Files'Length = 0 then Com.Fail ("no object files for library """ & Lib_Filename.all & '"'); end if; if not Opt.Quiet_Output then Write_Eol; Write_Str ("building "); Write_Str (Ada.Characters.Handling.To_Lower (Build_Mode_State'Image (The_Build_Mode))); Write_Str (" library for project "); Write_Line (Project_Name); -- Only output list of object files and ALI files in verbose mode if Opt.Verbose_Mode then Write_Eol; Write_Line ("object files:"); for Index in Object_Files'Range loop Write_Str (" "); Write_Line (Object_Files (Index).all); end loop; Write_Eol; if Ali_Files'Length = 0 then Write_Line ("NO ALI files"); else Write_Line ("ALI files:"); for Index in Ali_Files'Range loop Write_Str (" "); Write_Line (Ali_Files (Index).all); end loop; end if; Write_Eol; end if; end if; -- We check that all object files are regular files Check_Context; -- Delete the existing library file, if it exists. Fail if the -- library file is not writable, or if it is not possible to delete -- the file. declare DLL_Name : aliased String := Lib_Dirpath.all & Directory_Separator & DLL_Prefix & Lib_Filename.all & "." & DLL_Ext; Archive_Name : aliased String := Lib_Dirpath.all & Directory_Separator & "lib" & Lib_Filename.all & "." & Archive_Ext; type Str_Ptr is access all String; -- This type is necessary to meet the accessibility rules of Ada. -- It is not possible to use String_Access here. Full_Lib_Name : Str_Ptr; -- Designates the full library path name. Either DLL_Name or -- Archive_Name, depending on the library kind. Success : Boolean; pragma Warnings (Off, Success); -- Used to call Delete_File begin if The_Build_Mode = Static then Full_Lib_Name := Archive_Name'Access; else Full_Lib_Name := DLL_Name'Access; end if; if Is_Regular_File (Full_Lib_Name.all) then if Is_Writable_File (Full_Lib_Name.all) then Delete_File (Full_Lib_Name.all, Success); end if; if Is_Regular_File (Full_Lib_Name.all) then Com.Fail ("could not delete """ & Full_Lib_Name.all & """"); end if; end if; end; Argument_Number := 0; -- If we have a standalone library, gather all the interface ALI. -- They are passed to Build_Dynamic_Library, where they are used by -- some platforms (VMS, for example) to decide what symbols should be -- exported. They are also flagged as Interface when we copy them to -- the library directory (by Copy_ALI_Files, below). if Standalone then Current_Proj := For_Project; declare Iface : String_List_Id := For_Project.Lib_Interface_ALIs; ALI : File_Name_Type; begin while Iface /= Nil_String loop ALI := File_Name_Type (In_Tree.Shared.String_Elements.Table (Iface).Value); Interface_ALIs.Set (ALI, True); Get_Name_String (In_Tree.Shared.String_Elements.Table (Iface).Value); Add_Argument (Name_Buffer (1 .. Name_Len)); Iface := In_Tree.Shared.String_Elements.Table (Iface).Next; end loop; Iface := For_Project.Lib_Interface_ALIs; if not Opt.Quiet_Output then -- Check that the interface set is complete: any unit in the -- library that is needed by an interface should also be an -- interface. If it is not the case, output a warning. while Iface /= Nil_String loop ALI := File_Name_Type (In_Tree.Shared.String_Elements.Table (Iface).Value); Process (ALI); Iface := In_Tree.Shared.String_Elements.Table (Iface).Next; end loop; end if; end; end if; declare Current_Dir : constant String := Get_Current_Dir; Dir : Dir_Type; Name : String (1 .. 200); Last : Natural; Disregard : Boolean; pragma Warnings (Off, Disregard); DLL_Name : aliased constant String := Lib_Filename.all & "." & DLL_Ext; Archive_Name : aliased constant String := Lib_Filename.all & "." & Archive_Ext; Delete : Boolean := False; begin -- Clean the library directory: remove any file with the name of -- the library file and any ALI file of a source of the project. begin Get_Name_String (For_Project.Library_Dir.Display_Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception when others => Com.Fail ("unable to access library directory """ & Name_Buffer (1 .. Name_Len) & """"); end; Open (Dir, "."); loop Read (Dir, Name, Last); exit when Last = 0; declare Filename : constant String := Name (1 .. Last); begin if Is_Regular_File (Filename) then Canonical_Case_File_Name (Name (1 .. Last)); Delete := False; if (The_Build_Mode = Static and then Name (1 .. Last) = Archive_Name) or else ((The_Build_Mode = Dynamic or else The_Build_Mode = Relocatable) and then Name (1 .. Last) = DLL_Name) then Delete := True; elsif Last > 4 and then Name (Last - 3 .. Last) = ".ali" then declare Unit : Unit_Index; begin -- Compare with ALI file names of the project Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= No_Unit_Index loop if Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).Project /= No_Project then if Ultimate_Extending_Project_Of (Unit.File_Names (Impl).Project) = For_Project then Get_Name_String (Unit.File_Names (Impl).File); Name_Len := Name_Len - File_Extension (Name (1 .. Name_Len))'Length; if Name_Buffer (1 .. Name_Len) = Name (1 .. Last - 4) then Delete := True; exit; end if; end if; elsif Unit.File_Names (Spec) /= null and then Ultimate_Extending_Project_Of (Unit.File_Names (Spec).Project) = For_Project then Get_Name_String (Unit.File_Names (Spec).File); Name_Len := Name_Len - File_Extension (Name (1 .. Last))'Length; if Name_Buffer (1 .. Name_Len) = Name (1 .. Last - 4) then Delete := True; exit; end if; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; end; end if; if Delete then Set_Writable (Filename); Delete_File (Filename, Disregard); end if; end if; end; end loop; Close (Dir); Change_Dir (Current_Dir); end; -- Call procedure to build the library, depending on the build mode case The_Build_Mode is when Dynamic | Relocatable => Build_Dynamic_Library (Ofiles => Object_Files.all, Options => Options.all, Interfaces => Arguments (1 .. Argument_Number), Lib_Filename => Lib_Filename.all, Lib_Dir => Lib_Dirpath.all, Symbol_Data => Current_Proj.Symbol_Data, Driver_Name => Driver_Name, Lib_Version => Lib_Version.all, Auto_Init => Current_Proj.Lib_Auto_Init); when Static => MLib.Build_Library (Object_Files.all, Lib_Filename.all, Lib_Dirpath.all); when None => null; end case; -- We need to copy the ALI files from the object directory to the -- library ALI directory, so that the linker find them there, and -- does not need to look in the object directory where it would also -- find the object files; and we don't want that: we want the linker -- to use the library. -- Copy the ALI files and make the copies read-only. For interfaces, -- mark the copies as interfaces. Copy_ALI_Files (Files => Ali_Files.all, To => For_Project.Library_ALI_Dir.Display_Name, Interfaces => Arguments (1 .. Argument_Number)); -- Copy interface sources if Library_Src_Dir specified if Standalone and then For_Project.Library_Src_Dir /= No_Path_Information then -- Clean the interface copy directory: remove any source that -- could be a source of the project. begin Get_Name_String (For_Project.Library_Src_Dir.Display_Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception when others => Com.Fail ("unable to access library source copy directory """ & Name_Buffer (1 .. Name_Len) & """"); end; declare Dir : Dir_Type; Delete : Boolean := False; Unit : Unit_Index; Name : String (1 .. 200); Last : Natural; Disregard : Boolean; pragma Warnings (Off, Disregard); begin Open (Dir, "."); loop Read (Dir, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) then Canonical_Case_File_Name (Name (1 .. Last)); Delete := False; -- Compare with source file names of the project Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= No_Unit_Index loop if Unit.File_Names (Impl) /= null and then Ultimate_Extending_Project_Of (Unit.File_Names (Impl).Project) = For_Project and then Get_Name_String (Unit.File_Names (Impl).File) = Name (1 .. Last) then Delete := True; exit; end if; if Unit.File_Names (Spec) /= null and then Ultimate_Extending_Project_Of (Unit.File_Names (Spec).Project) = For_Project and then Get_Name_String (Unit.File_Names (Spec).File) = Name (1 .. Last) then Delete := True; exit; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; end if; if Delete then Set_Writable (Name (1 .. Last)); Delete_File (Name (1 .. Last), Disregard); end if; end loop; Close (Dir); end; Copy_Interface_Sources (For_Project => For_Project, In_Tree => In_Tree, Interfaces => Arguments (1 .. Argument_Number), To_Dir => For_Project.Library_Src_Dir.Display_Name); end if; end if; -- Reset the current working directory to its previous value Change_Dir (Current_Dir); end Build_Library; ----------- -- Check -- ----------- procedure Check (Filename : String) is begin if not Is_Regular_File (Filename) then Com.Fail (Filename & " not found."); end if; end Check; ------------------- -- Check_Context -- ------------------- procedure Check_Context is begin -- Check that each object file exists for F in Object_Files'Range loop Check (Object_Files (F).all); end loop; end Check_Context; ------------------- -- Check_Library -- ------------------- procedure Check_Library (For_Project : Project_Id; In_Tree : Project_Tree_Ref) is Lib_TS : Time_Stamp_Type; Current : constant Dir_Name_Str := Get_Current_Dir; begin -- No need to build the library if there is no object directory, -- hence no object files to build the library. if For_Project.Library then declare Lib_Name : constant File_Name_Type := Library_File_Name_For (For_Project, In_Tree); begin Change_Dir (Get_Name_String (For_Project.Library_Dir.Display_Name)); Lib_TS := File_Stamp (Lib_Name); For_Project.Library_TS := Lib_TS; end; if not For_Project.Externally_Built and then not For_Project.Need_To_Build_Lib and then For_Project.Object_Directory /= No_Path_Information then declare Obj_TS : Time_Stamp_Type; Object_Dir : Dir_Type; begin if OpenVMS_On_Target then B_Start := new String'("b__"); end if; -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. Change_Dir (Get_Name_String (For_Project.Object_Directory.Display_Name)); Open (Dir => Object_Dir, Dir_Name => "."); -- For all entries in the object directory loop Read (Object_Dir, Name_Buffer, Name_Len); exit when Name_Len = 0; -- Check if it is an object file, but ignore any binder -- generated file. if Is_Obj (Name_Buffer (1 .. Name_Len)) and then Name_Buffer (1 .. B_Start'Length) /= B_Start.all then -- Get the object file time stamp Obj_TS := File_Stamp (File_Name_Type'(Name_Find)); -- If library file time stamp is earlier, set -- Need_To_Build_Lib and return. String comparison is -- used, otherwise time stamps may be too close and the -- comparison would return True, which would trigger -- an unnecessary rebuild of the library. if String (Lib_TS) < String (Obj_TS) then -- Library must be rebuilt For_Project.Need_To_Build_Lib := True; exit; end if; end if; end loop; Close (Object_Dir); end; end if; Change_Dir (Current); end if; end Check_Library; ---------------------------- -- Copy_Interface_Sources -- ---------------------------- procedure Copy_Interface_Sources (For_Project : Project_Id; In_Tree : Project_Tree_Ref; Interfaces : Argument_List; To_Dir : Path_Name_Type) is Current : constant Dir_Name_Str := Get_Current_Dir; -- The current directory, where to return to at the end Target : constant Dir_Name_Str := Get_Name_String (To_Dir); -- The directory where to copy sources Text : Text_Buffer_Ptr; The_ALI : ALI.ALI_Id; Lib_File : File_Name_Type; First_Unit : ALI.Unit_Id; Second_Unit : ALI.Unit_Id; Copy_Subunits : Boolean := False; -- When True, indicates that subunits, if any, need to be copied too procedure Copy (File_Name : File_Name_Type); -- Copy one source of the project to the target directory ---------- -- Copy -- ---------- procedure Copy (File_Name : File_Name_Type) is Success : Boolean; pragma Warnings (Off, Success); Source : Standard.Prj.Source_Id; begin Source := Find_Source (In_Tree, For_Project, In_Extended_Only => True, Base_Name => File_Name); if Source /= No_Source and then not Source.Locally_Removed and then Source.Replaced_By = No_Source then Copy_File (Get_Name_String (Source.Path.Name), Target, Success, Mode => Overwrite, Preserve => Preserve); end if; end Copy; -- Start of processing for Copy_Interface_Sources begin -- Change the working directory to the object directory Change_Dir (Get_Name_String (For_Project.Object_Directory.Display_Name)); for Index in Interfaces'Range loop -- First, load the ALI file Name_Len := 0; Add_Str_To_Name_Buffer (Interfaces (Index).all); Lib_File := Name_Find; Text := Read_Library_Info (Lib_File); The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); Free (Text); Second_Unit := No_Unit_Id; First_Unit := ALI.ALIs.Table (The_ALI).First_Unit; Copy_Subunits := True; -- If there is both a spec and a body, check if they are both needed if ALI.Units.Table (First_Unit).Utype = Is_Body then Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit; -- If the body is not needed, then reset First_Unit if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then First_Unit := No_Unit_Id; Copy_Subunits := False; end if; elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then Copy_Subunits := False; end if; -- Copy the file(s) that need to be copied if First_Unit /= No_Unit_Id then Copy (File_Name => ALI.Units.Table (First_Unit).Sfile); end if; if Second_Unit /= No_Unit_Id then Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile); end if; -- Copy all the separates, if any if Copy_Subunits then for Dep in ALI.ALIs.Table (The_ALI).First_Sdep .. ALI.ALIs.Table (The_ALI).Last_Sdep loop if Sdep.Table (Dep).Subunit_Name /= No_Name then Copy (File_Name => Sdep.Table (Dep).Sfile); end if; end loop; end if; end loop; -- Restore the initial working directory Change_Dir (Current); end Copy_Interface_Sources; ------------- -- Display -- ------------- procedure Display (Executable : String) is begin if not Opt.Quiet_Output then Write_Str (Executable); for Index in 1 .. Argument_Number loop Write_Char (' '); Write_Str (Arguments (Index).all); if not Opt.Verbose_Mode and then Index > 4 then Write_Str (" ..."); exit; end if; end loop; Write_Eol; end if; end Display; ----------- -- Index -- ----------- function Index (S, Pattern : String) return Natural is Len : constant Natural := Pattern'Length; begin for J in reverse S'First .. S'Last - Len + 1 loop if Pattern = S (J .. J + Len - 1) then return J; end if; end loop; return 0; end Index; ------------------------- -- Process_Binder_File -- ------------------------- procedure Process_Binder_File (Name : String) is Fd : FILEs; -- Binder file's descriptor Read_Mode : constant String := "r" & ASCII.NUL; -- For fopen Status : Interfaces.C_Streams.int; pragma Unreferenced (Status); -- For fclose Begin_Info : constant String := "-- BEGIN Object file/option list"; End_Info : constant String := "-- END Object file/option list "; Next_Line : String (1 .. 1000); -- Current line value -- Where does this odd constant 1000 come from, looks suspicious ??? Nlast : Integer; -- End of line slice (the slice does not contain the line terminator) procedure Get_Next_Line; -- Read the next line from the binder file without the line terminator ------------------- -- Get_Next_Line -- ------------------- procedure Get_Next_Line is Fchars : chars; begin Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); if Fchars = System.Null_Address then Fail ("Error reading binder output"); end if; Nlast := 1; while Nlast <= Next_Line'Last and then Next_Line (Nlast) /= ASCII.LF and then Next_Line (Nlast) /= ASCII.CR loop Nlast := Nlast + 1; end loop; Nlast := Nlast - 1; end Get_Next_Line; -- Start of processing for Process_Binder_File begin Fd := fopen (Name'Address, Read_Mode'Address); if Fd = NULL_Stream then Fail ("Failed to open binder output"); end if; -- Skip up to the Begin Info line loop Get_Next_Line; exit when Next_Line (1 .. Nlast) = Begin_Info; end loop; -- Find the first switch loop Get_Next_Line; exit when Next_Line (1 .. Nlast) = End_Info; -- As the binder generated file is in Ada, remove the first eight -- characters " -- ". Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); Nlast := Nlast - 8; -- Stop when the first switch is found exit when Next_Line (1) = '-'; end loop; if Next_Line (1 .. Nlast) /= End_Info then loop -- Ignore -static and -shared, since -shared will be used -- in any case. -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added -- later, because they are also needed for non Stand-Alone shared -- libraries. -- Also ignore the shared libraries which are : -- UNIX / Windows VMS -- -lgnat-<version> -lgnat_<version> (7 + version'length chars) -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars) if Next_Line (1 .. Nlast) /= "-static" and then Next_Line (1 .. Nlast) /= "-shared" and then Next_Line (1 .. Nlast) /= "-ldecgnat" and then Next_Line (1 .. Nlast) /= "-lgnarl" and then Next_Line (1 .. Nlast) /= "-lgnat" and then Next_Line (1 .. Natural'Min (Nlast, 10 + Library_Version'Length)) /= Shared_Lib ("decgnat") and then Next_Line (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= Shared_Lib ("gnarl") and then Next_Line (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= Shared_Lib ("gnat") then if Next_Line (1) /= '-' then -- This is not an option, should we add it? if Add_Object_Files then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(Next_Line (1 .. Nlast)); end if; else -- Add all other options Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(Next_Line (1 .. Nlast)); end if; end if; -- Next option, if any Get_Next_Line; exit when Next_Line (1 .. Nlast) = End_Info; -- Remove first eight characters " -- " Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); Nlast := Nlast - 8; end loop; end if; Status := fclose (Fd); -- Is it really right to ignore any close error ??? end Process_Binder_File; ------------------ -- Reset_Tables -- ------------------ procedure Reset_Tables is begin Objects.Init; Objects_Htable.Reset; ALIs.Init; Opts.Init; Processed_Projects.Reset; Library_Projs.Init; end Reset_Tables; --------------------------- -- SALs_Use_Constructors -- --------------------------- function SALs_Use_Constructors return Boolean is function C_SALs_Init_Using_Constructors return Integer; pragma Import (C, C_SALs_Init_Using_Constructors, "__gnat_sals_init_using_constructors"); begin return C_SALs_Init_Using_Constructors /= 0; end SALs_Use_Constructors; end MLib.Prj;
Go to most recent revision | Compare with Previous | Blame | View Log