1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Gnatvsn
; use Gnatvsn
;
28 with MLib
.Fil
; use MLib
.Fil
;
29 with MLib
.Tgt
; use MLib
.Tgt
;
30 with MLib
.Utl
; use MLib
.Utl
;
32 with Output
; use Output
;
33 with Prj
.Com
; use Prj
.Com
;
34 with Prj
.Env
; use Prj
.Env
;
35 with Prj
.Util
; use Prj
.Util
;
37 with Snames
; use Snames
;
38 with Switch
; use Switch
;
40 with Targparm
; use Targparm
;
42 with Types
; use Types
;
44 with Ada
.Characters
.Handling
;
46 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
48 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
49 with System
; use System
;
50 with System
.Case_Util
; use System
.Case_Util
;
52 package body MLib
.Prj
is
54 Prj_Add_Obj_Files
: Types
.Int
;
55 pragma Import
(C
, Prj_Add_Obj_Files
, "__gnat_prj_add_obj_files");
56 Add_Object_Files
: constant Boolean := Prj_Add_Obj_Files
/= 0;
57 -- Indicates if object files in pragmas Linker_Options (found in the
58 -- binder generated file) should be taken when linking a stand-alone
59 -- library. False for Windows, True for other platforms.
61 ALI_Suffix
: constant String := ".ali";
63 B_Start
: String_Ptr
:= new String'("b~");
64 -- Prefix of bind file, changed to b__ for VMS
66 S_Osinte_Ads : File_Name_Type := No_File;
67 -- Name_Id for "s-osinte.ads"
69 S_Dec_Ads : File_Name_Type := No_File;
70 -- Name_Id for "dec.ads"
72 G_Trasym_Ads : File_Name_Type := No_File;
73 -- Name_Id for "g-trasym.ads"
75 Arguments : String_List_Access := No_Argument;
76 -- Used to accumulate arguments for the invocation of gnatbind and of
77 -- the compiler. Also used to collect the interface ALI when copying
78 -- the ALI files to the library directory.
80 Argument_Number : Natural := 0;
81 -- Index of the last argument in Arguments
83 Initial_Argument_Max : constant := 10;
85 No_Main_String : aliased String := "-n";
86 No_Main : constant String_Access := No_Main_String'Access;
88 Output_Switch_String : aliased String := "-o";
89 Output_Switch : constant String_Access := Output_Switch_String'Access;
91 Compile_Switch_String : aliased String := "-c";
92 Compile_Switch : constant String_Access := Compile_Switch_String'Access;
94 Auto_Initialize : constant String := "-a";
96 -- List of objects to put inside the library
98 Object_Files : Argument_List_Access;
100 package Objects is new Table.Table
101 (Table_Name => "Mlib.Prj.Objects",
102 Table_Component_Type => String_Access,
103 Table_Index_Type => Natural,
104 Table_Low_Bound => 1,
106 Table_Increment => 100);
108 package Objects_Htable is new GNAT.HTable.Simple_HTable
109 (Header_Num => Header_Num,
118 Ali_Files : Argument_List_Access;
120 package ALIs is new Table.Table
121 (Table_Name => "Mlib.Prj.Alis",
122 Table_Component_Type => String_Access,
123 Table_Index_Type => Natural,
124 Table_Low_Bound => 1,
126 Table_Increment => 100);
128 -- List of options set in the command line
130 Options : Argument_List_Access;
132 package Opts is new Table.Table
133 (Table_Name => "Mlib.Prj.Opts",
134 Table_Component_Type => String_Access,
135 Table_Index_Type => Natural,
136 Table_Low_Bound => 1,
138 Table_Increment => 100);
140 -- All the ALI file in the library
142 package Library_ALIs is new GNAT.HTable.Simple_HTable
143 (Header_Num => Header_Num,
146 Key => File_Name_Type,
150 -- The ALI files in the interface sets
152 package Interface_ALIs is new GNAT.HTable.Simple_HTable
153 (Header_Num => Header_Num,
156 Key => File_Name_Type,
160 -- The ALI files that have been processed to check if the corresponding
161 -- library unit is in the interface set.
163 package Processed_ALIs is new GNAT.HTable.Simple_HTable
164 (Header_Num => Header_Num,
167 Key => File_Name_Type,
171 -- The projects imported directly or indirectly
173 package Processed_Projects is new GNAT.HTable.Simple_HTable
174 (Header_Num => Header_Num,
181 -- The library projects imported directly or indirectly
183 package Library_Projs is new Table.Table (
184 Table_Component_Type => Project_Id,
185 Table_Index_Type => Integer,
186 Table_Low_Bound => 1,
188 Table_Increment => 10,
189 Table_Name => "Make.Library_Projs");
191 type Build_Mode_State is (None, Static, Dynamic, Relocatable);
193 procedure Add_Argument (S : String);
194 -- Add one argument to Arguments array, if array is full, double its size
196 function ALI_File_Name (Source : String) return String;
197 -- Return the ALI file name corresponding to a source
199 procedure Check (Filename : String);
200 -- Check if filename is a regular file. Fail if it is not
202 procedure Check_Context;
203 -- Check each object files in table Object_Files
204 -- Fail if any of them is not a regular file
206 procedure Copy_Interface_Sources
207 (For_Project : Project_Id;
208 In_Tree : Project_Tree_Ref;
209 Interfaces : Argument_List;
210 To_Dir : Path_Name_Type);
211 -- Copy the interface sources of a SAL to directory To_Dir
213 procedure Display (Executable : String);
214 -- Display invocation of gnatbind and of the compiler with the arguments
215 -- in Arguments, except when Quiet_Output is True.
217 function Index (S, Pattern : String) return Natural;
218 -- Return the last occurrence of Pattern in S, or 0 if none
220 procedure Process_Binder_File (Name : String);
221 -- For Stand-Alone libraries, get the Linker Options in the binder
224 procedure Reset_Tables;
225 -- Make sure that all the above tables are empty
226 -- (Objects, Ali_Files, Options).
228 function SALs_Use_Constructors return Boolean;
229 -- Indicate if Stand-Alone Libraries are automatically initialized using
230 -- the constructor mechanism.
236 procedure Add_Argument (S : String) is
238 if Argument_Number = Arguments'Last then
240 New_Args : constant String_List_Access :=
241 new String_List (1 .. 2 * Arguments'Last);
244 -- Copy the String_Accesses and set them to null in Arguments
245 -- so that they will not be deallocated by the call to
248 New_Args (Arguments'Range) := Arguments.all;
249 Arguments.all := (others => null);
251 Arguments := New_Args;
255 Argument_Number := Argument_Number + 1;
256 Arguments (Argument_Number) := new String'(S
);
263 function ALI_File_Name
(Source
: String) return String is
265 -- If the source name has an extension, then replace it with
268 for Index
in reverse Source
'First + 1 .. Source
'Last loop
269 if Source
(Index
) = '.' then
270 return Source
(Source
'First .. Index
- 1) & ALI_Suffix
;
274 -- If there is no dot, or if it is the first character, just add the
277 return Source
& ALI_Suffix
;
284 procedure Build_Library
285 (For_Project
: Project_Id
;
286 In_Tree
: Project_Tree_Ref
;
288 Gnatbind_Path
: String_Access
;
290 Gcc_Path
: String_Access
;
291 Bind
: Boolean := True;
292 Link
: Boolean := True)
294 Maximum_Size
: Integer;
295 pragma Import
(C
, Maximum_Size
, "__gnat_link_max");
296 -- Maximum number of bytes to put in an invocation of the
300 -- The number of bytes for the invocation of the gnatbind
302 Warning_For_Library
: Boolean := False;
303 -- Set to True for the first warning about a unit missing from the
306 Current_Proj
: Project_Id
;
308 Libgnarl_Needed
: Yes_No_Unknown
:= For_Project
.Libgnarl_Needed
;
309 -- Set to True if library needs to be linked with libgnarl
311 Libdecgnat_Needed
: Boolean := False;
312 -- On OpenVMS, set to True if library needs to be linked with libdecgnat
314 Gtrasymobj_Needed
: Boolean := False;
315 -- On OpenVMS, set to True if library needs to be linked with
318 Object_Directory_Path
: constant String :=
320 (For_Project
.Object_Directory
.Display_Name
);
322 Standalone
: constant Boolean := For_Project
.Standalone_Library
;
324 Project_Name
: constant String := Get_Name_String
(For_Project
.Name
);
326 Current_Dir
: constant String := Get_Current_Dir
;
328 Lib_Filename
: String_Access
;
329 Lib_Dirpath
: String_Access
;
330 Lib_Version
: String_Access
:= new String'("");
332 The_Build_Mode : Build_Mode_State := None;
334 Success : Boolean := False;
336 Library_Options : Variable_Value := Nil_Variable_Value;
338 Driver_Name : Name_Id := No_Name;
340 In_Main_Object_Directory : Boolean := True;
342 Foreign_Sources : Boolean;
344 Rpath : String_Access := null;
345 -- Allocated only if Path Option is supported
347 Rpath_Last : Natural := 0;
348 -- Index of last valid character of Rpath
350 Initial_Rpath_Length : constant := 200;
351 -- Initial size of Rpath, when first allocated
353 Path_Option : String_Access := Linker_Library_Path_Option;
354 -- If null, Path Option is not supported.
355 -- Not a constant so that it can be deallocated.
357 First_ALI : File_Name_Type := No_File;
358 -- Store the ALI file name of a source of the library (the first found)
360 procedure Add_ALI_For (Source : File_Name_Type);
361 -- Add the name of the ALI file corresponding to Source to the
364 procedure Add_Rpath (Path : String);
365 -- Add a path name to Rpath
367 function Check_Project (P : Project_Id) return Boolean;
368 -- Returns True if P is For_Project or a project extended by For_Project
370 procedure Check_Libs (ALI_File : String; Main_Project : Boolean);
371 -- Set Libgnarl_Needed if the ALI_File indicates that there is a need
372 -- to link with -lgnarl (this is the case when there is a dependency
373 -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
374 -- indicates that there is a need to link with -ldecgnat (this is the
375 -- case when there is a dependency on dec.ads), and set
376 -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads.
378 procedure Process (The_ALI : File_Name_Type);
379 -- Check if the closure of a library unit which is or should be in the
380 -- interface set is also in the interface set. Issue a warning for each
381 -- missing library unit.
383 procedure Process_Imported_Libraries;
384 -- Add the -L and -l switches for the imported Library Project Files,
385 -- and, if Path Option is supported, the library directory path names
392 procedure Add_ALI_For (Source : File_Name_Type) is
393 ALI : constant String := ALI_File_Name (Get_Name_String (Source));
394 ALI_Id : File_Name_Type;
402 Add_Str_To_Name_Buffer (S => ALI);
405 -- Add the ALI file name to the library ALIs
408 Library_ALIs.Set (ALI_Id, True);
411 -- Set First_ALI, if not already done
413 if First_ALI = No_File then
422 procedure Add_Rpath (Path : String) is
432 New_Rpath : constant String_Access :=
433 new String (1 .. 2 * Rpath'Length);
435 New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
440 -- Start of processing for Add_Rpath
443 -- If first path, allocate initial Rpath
446 Rpath := new String (1 .. Initial_Rpath_Length);
450 -- Otherwise, add a path separator between two path names
452 if Rpath_Last = Rpath'Last then
456 Rpath_Last := Rpath_Last + 1;
457 Rpath (Rpath_Last) := Path_Separator;
460 -- Increase Rpath size until it is large enough
462 while Rpath_Last + Path'Length > Rpath'Last loop
468 Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
469 Rpath_Last := Rpath_Last + Path'Length;
476 function Check_Project (P : Project_Id) return Boolean is
478 if P = For_Project then
481 elsif P /= No_Project then
487 while Proj.Extends /= No_Project loop
488 if P = Proj.Extends then
492 Proj := Proj.Extends;
504 procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is
505 Lib_File : File_Name_Type;
506 Text : Text_Buffer_Ptr;
510 if Libgnarl_Needed /= Yes
513 and then OpenVMS_On_Target
514 and then ((not Libdecgnat_Needed) or (not Gtrasymobj_Needed)))
518 Name_Len := ALI_File'Length;
519 Name_Buffer (1 .. Name_Len) := ALI_File;
520 Lib_File := Name_Find;
521 Text := Read_Library_Info (Lib_File, True);
531 -- Look for s-osinte.ads in the dependencies
533 for Index in ALI.ALIs.Table (Id).First_Sdep ..
534 ALI.ALIs.Table (Id).Last_Sdep
536 if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
537 Libgnarl_Needed := Yes;
540 For_Project.Libgnarl_Needed := Yes;
545 elsif OpenVMS_On_Target then
546 if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
547 Libdecgnat_Needed := True;
549 elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then
550 Gtrasymobj_Needed := True;
561 procedure Process (The_ALI : File_Name_Type) is
562 Text : Text_Buffer_Ptr;
564 First_Unit : ALI.Unit_Id;
565 Last_Unit : ALI.Unit_Id;
566 Unit_Data : Unit_Record;
567 Afile : File_Name_Type;
570 -- Nothing to do if the ALI file has already been processed.
571 -- This happens if an interface imports another interface.
573 if not Processed_ALIs.Get (The_ALI) then
574 Processed_ALIs.Set (The_ALI, True);
575 Text := Read_Library_Info (The_ALI);
586 if Idread /= No_ALI_Id then
587 First_Unit := ALI.ALIs.Table (Idread).First_Unit;
588 Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
590 -- Process both unit (spec and body) if the body is needed
591 -- by the spec (inline or generic). Otherwise, just process
594 if First_Unit /= Last_Unit and then
595 not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
597 First_Unit := Last_Unit;
600 for Unit in First_Unit .. Last_Unit loop
601 Unit_Data := ALI.Units.Table (Unit);
603 -- Check if each withed unit which is in the library is
604 -- also in the interface set, if it has not yet been
607 for W in Unit_Data.First_With .. Unit_Data.Last_With loop
608 Afile := Withs.Table (W).Afile;
610 if Afile /= No_File and then Library_ALIs.Get (Afile)
611 and then not Processed_ALIs.Get (Afile)
613 if not Interface_ALIs.Get (Afile) then
614 if not Warning_For_Library then
615 Write_Str ("Warning: In library project """);
616 Get_Name_String (Current_Proj.Name);
617 To_Mixed (Name_Buffer (1 .. Name_Len));
618 Write_Str (Name_Buffer (1 .. Name_Len));
620 Warning_For_Library := True;
623 Write_Str (" Unit """);
624 Get_Name_String (Withs.Table (W).Uname);
625 To_Mixed (Name_Buffer (1 .. Name_Len - 2));
626 Write_Str (Name_Buffer (1 .. Name_Len - 2));
627 Write_Line (""" is not in the interface set");
628 Write_Str (" but it is needed by ");
630 case Unit_Data.Utype is
632 Write_Str ("the spec of ");
635 Write_Str ("the body of ");
642 Get_Name_String (Unit_Data.Uname);
643 To_Mixed (Name_Buffer (1 .. Name_Len - 2));
644 Write_Str (Name_Buffer (1 .. Name_Len - 2));
648 -- Now, process this unit
659 --------------------------------
660 -- Process_Imported_Libraries --
661 --------------------------------
663 procedure Process_Imported_Libraries is
664 Current : Project_Id;
666 procedure Process_Project (Project : Project_Id);
667 -- Process Project and its imported projects recursively.
668 -- Add any library projects to table Library_Projs.
670 ---------------------
671 -- Process_Project --
672 ---------------------
674 procedure Process_Project (Project : Project_Id) is
675 Imported : Project_List;
678 -- Nothing to do if process has already been processed
680 if not Processed_Projects.Get (Project.Name) then
681 Processed_Projects.Set (Project.Name, True);
683 -- Call Process_Project recursively for any imported project.
684 -- We first process the imported projects to guarantee that
685 -- we have a proper reverse order for the libraries.
687 Imported := Project.Imported_Projects;
688 while Imported /= null loop
689 if Imported.Project /= No_Project then
690 Process_Project (Imported.Project);
693 Imported := Imported.Next;
696 -- If it is a library project, add it to Library_Projs
698 if Project /= For_Project and then Project.Library then
699 Library_Projs.Increment_Last;
700 Library_Projs.Table (Library_Projs.Last) := Project;
702 -- Check if because of this library we need to use libgnarl
704 if Libgnarl_Needed = Unknown then
705 if Project.Libgnarl_Needed = Unknown
706 and then Project.Object_Directory /= No_Path_Information
708 -- Check if libgnarl is needed for this library
711 Object_Dir_Path : constant String :=
713 (Project.Object_Directory.
715 Object_Dir : Dir_Type;
716 Filename : String (1 .. 255);
720 Open (Object_Dir, Object_Dir_Path);
722 -- For all entries in the object directory
725 Read (Object_Dir, Filename, Last);
728 -- Check if it is an object file
730 if Is_Obj (Filename (1 .. Last)) then
732 Object_Path : constant String :=
735 Directory_Separator &
736 Filename (1 .. Last));
737 ALI_File : constant String :=
739 (Object_Path, "ali");
742 if Is_Regular_File (ALI_File) then
744 -- Find out if for this ALI file,
745 -- libgnarl is necessary.
748 (ALI_File, Main_Project => False);
750 if Libgnarl_Needed = Yes then
751 Project.Libgnarl_Needed := Yes;
752 For_Project.Libgnarl_Needed := Yes;
764 if Project.Libgnarl_Needed = Yes then
765 Libgnarl_Needed := Yes;
766 For_Project.Libgnarl_Needed := Yes;
773 -- Start of processing for Process_Imported_Libraries
776 -- Build list of library projects imported directly or indirectly,
777 -- in the reverse order.
779 Process_Project (For_Project);
781 -- Add the -L and -l switches and, if the Rpath option is supported,
782 -- add the directory to the Rpath. As the library projects are in the
783 -- wrong order, process from the last to the first.
785 for Index in reverse 1 .. Library_Projs.Last loop
786 Current := Library_Projs.Table (Index);
788 Get_Name_String (Current.Library_Dir.Display_Name);
790 Opts.Table (Opts.Last) :=
791 new String'("-L" & Name_Buffer
(1 .. Name_Len
));
793 if Path_Option
/= null then
794 Add_Rpath
(Name_Buffer
(1 .. Name_Len
));
798 Opts
.Table
(Opts
.Last
) :=
799 new String'("-l" & Get_Name_String (Current.Library_Name));
801 end Process_Imported_Libraries;
803 -- Start of processing for Build_Library
808 -- Fail if project is not a library project
810 if not For_Project.Library then
811 Com.Fail ("project """ & Project_Name & """ has no library");
814 -- Do not attempt to build the library if it is externally built
816 if For_Project.Externally_Built then
820 -- If this is the first time Build_Library is called, get the Name_Id
821 -- of "s-osinte.ads".
823 if S_Osinte_Ads = No_File then
825 Add_Str_To_Name_Buffer ("s-osinte.ads");
826 S_Osinte_Ads := Name_Find;
829 if S_Dec_Ads = No_File then
831 Add_Str_To_Name_Buffer ("dec.ads");
832 S_Dec_Ads := Name_Find;
835 if G_Trasym_Ads = No_File then
837 Add_Str_To_Name_Buffer ("g-trasym.ads");
838 G_Trasym_Ads := Name_Find;
841 -- We work in the object directory
843 Change_Dir (Object_Directory_Path);
847 -- Call gnatbind only if Bind is True
850 if Gnatbind_Path = null then
851 Com.Fail ("unable to locate " & Gnatbind);
854 if Gcc_Path = null then
855 Com.Fail ("unable to locate " & Gcc);
858 -- Allocate Arguments, if it is the first time we see a standalone
861 if Arguments = No_Argument then
862 Arguments := new String_List (1 .. Initial_Argument_Max);
865 -- Add "-n -o b~<lib>.adb (b__<lib>.adb on VMS) -L<lib>"
867 Argument_Number := 2;
868 Arguments (1) := No_Main;
869 Arguments (2) := Output_Switch;
871 if OpenVMS_On_Target then
872 B_Start := new String'("b__");
877 & Get_Name_String
(For_Project
.Library_Name
) & ".adb");
878 Add_Argument
("-L" & Get_Name_String
(For_Project
.Library_Name
));
880 if For_Project
.Lib_Auto_Init
and then SALs_Use_Constructors
then
881 Add_Argument
(Auto_Initialize
);
884 -- Check if Binder'Default_Switches ("Ada") is defined. If it is,
885 -- add these switches to call gnatbind.
888 Binder_Package
: constant Package_Id
:=
890 (Name
=> Name_Binder
,
891 In_Packages
=> For_Project
.Decl
.Packages
,
895 if Binder_Package
/= No_Package
then
897 Defaults
: constant Array_Element_Id
:=
899 (Name
=> Name_Default_Switches
,
901 In_Tree
.Packages
.Table
902 (Binder_Package
).Decl
.Arrays
,
904 Switches
: Variable_Value
:= Nil_Variable_Value
;
906 Switch
: String_List_Id
:= Nil_String
;
909 if Defaults
/= No_Array_Element
then
914 In_Array
=> Defaults
,
917 if not Switches
.Default
then
918 Switch
:= Switches
.Values
;
920 while Switch
/= Nil_String
loop
923 (In_Tree
.String_Elements
.Table
925 Switch
:= In_Tree
.String_Elements
.
935 -- Get all the ALI files of the project file. We do that even if
936 -- Bind is False, so that First_ALI is set.
943 Interface_ALIs
.Reset
;
944 Processed_ALIs
.Reset
;
946 for Source
in Unit_Table
.First
..
947 Unit_Table
.Last
(In_Tree
.Units
)
949 Unit
:= In_Tree
.Units
.Table
(Source
);
951 if Unit
.File_Names
(Body_Part
).Name
/= No_File
952 and then Unit
.File_Names
(Body_Part
).Path
.Name
/= Slash
955 Check_Project
(Unit
.File_Names
(Body_Part
).Project
)
957 if Unit
.File_Names
(Specification
).Name
= No_File
then
959 Src_Ind
: Source_File_Index
;
962 Src_Ind
:= Sinput
.P
.Load_Project_File
965 (Body_Part
).Path
.Name
));
967 -- Add the ALI file only if it is not a subunit
970 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
)
973 (Unit
.File_Names
(Body_Part
).Name
);
979 Add_ALI_For
(Unit
.File_Names
(Body_Part
).Name
);
984 elsif Unit
.File_Names
(Specification
).Name
/= No_File
985 and then Unit
.File_Names
(Specification
).Path
.Name
/= Slash
986 and then Check_Project
987 (Unit
.File_Names
(Specification
).Project
)
989 Add_ALI_For
(Unit
.File_Names
(Specification
).Name
);
995 -- Continue setup and call gnatbind if Bind is True
999 -- Get an eventual --RTS from the ALI file
1001 if First_ALI
/= No_File
then
1003 T
: Text_Buffer_Ptr
;
1007 -- Load the ALI file
1009 T
:= Read_Library_Info
(First_ALI
, True);
1014 (First_ALI
, T
, Ignore_ED
=> False, Err
=> False);
1016 if A
/= No_ALI_Id
then
1019 (ALI
.ALIs
.Table
(A
).First_Unit
).First_Arg
..
1021 (ALI
.ALIs
.Table
(A
).First_Unit
).Last_Arg
1023 -- Look for --RTS. If found, add the switch to call
1027 Arg
: String_Ptr
renames Args
.Table
(Index
);
1029 if Arg
'Length >= 6 and then
1030 Arg
(Arg
'First + 2 .. Arg
'First + 5) = "RTS="
1032 Add_Argument
(Arg
.all);
1044 (Project
=> For_Project
,
1046 Including_Libraries
=> True);
1048 -- Display the gnatbind command, if not in quiet output
1053 for J
in 1 .. Argument_Number
loop
1054 Size
:= Size
+ Arguments
(J
)'Length + 1;
1057 -- Invoke gnatbind with the arguments if the size is not too large
1059 if Size
<= Maximum_Size
then
1062 Arguments
(1 .. Argument_Number
),
1066 -- Otherwise create a temporary response file
1069 FD
: File_Descriptor
;
1070 Path
: Path_Name_Type
;
1071 Args
: Argument_List
(1 .. 1);
1072 EOL
: constant String (1 .. 1) := (1 => ASCII
.LF
);
1075 Quotes_Needed
: Boolean;
1076 Last_Char
: Natural;
1080 Tempdir
.Create_Temp_File
(FD
, Path
);
1081 Args
(1) := new String'("@" & Get_Name_String (Path));
1083 for J in 1 .. Argument_Number loop
1085 -- Check if the argument should be quoted
1087 Quotes_Needed := False;
1088 Last_Char := Arguments (J)'Length;
1090 for K in Arguments (J)'Range loop
1091 Ch := Arguments (J) (K);
1093 if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then
1094 Quotes_Needed := True;
1099 if Quotes_Needed then
1101 -- Quote the argument, doubling '"'
1104 Arg : String (1 .. Arguments (J)'Length * 2 + 2);
1110 for K in Arguments (J)'Range loop
1111 Ch := Arguments (J) (K);
1112 Last_Char := Last_Char + 1;
1113 Arg (Last_Char) := Ch;
1116 Last_Char := Last_Char + 1;
1117 Arg (Last_Char) := '"';
1121 Last_Char := Last_Char + 1;
1122 Arg (Last_Char) := '"';
1124 Status := Write (FD, Arg'Address, Last_Char);
1130 Arguments (J) (Arguments (J)'First)'Address,
1134 if Status /= Last_Char then
1138 Status := Write (FD, EOL (1)'Address, 1);
1147 -- And invoke gnatbind with this response file
1149 Spawn (Gnatbind_Path.all, Args, Success);
1151 Delete_File (Get_Name_String (Path), Succ);
1160 Com.Fail ("could not bind standalone library "
1161 & Get_Name_String (For_Project.Library_Name));
1165 -- Compile the binder generated file only if Link is true
1172 (Project => For_Project,
1174 Including_Libraries => True);
1176 -- Invoke <gcc> -c b__<lib>.adb
1178 -- Allocate Arguments, if it is the first time we see a standalone
1181 if Arguments = No_Argument then
1182 Arguments := new String_List (1 .. Initial_Argument_Max);
1185 Argument_Number := 1;
1186 Arguments (1) := Compile_Switch;
1188 if OpenVMS_On_Target then
1189 B_Start := new String'("b__");
1194 & Get_Name_String
(For_Project
.Library_Name
) & ".adb");
1196 -- If necessary, add the PIC option
1198 if PIC_Option
/= "" then
1199 Add_Argument
(PIC_Option
);
1202 -- Get the back-end switches and --RTS from the ALI file
1204 if First_ALI
/= No_File
then
1206 T
: Text_Buffer_Ptr
;
1210 -- Load the ALI file
1212 T
:= Read_Library_Info
(First_ALI
, True);
1217 Scan_ALI
(First_ALI
, T
, Ignore_ED
=> False, Err
=> False);
1219 if A
/= No_ALI_Id
then
1222 (ALI
.ALIs
.Table
(A
).First_Unit
).First_Arg
..
1224 (ALI
.ALIs
.Table
(A
).First_Unit
).Last_Arg
1226 -- Do not compile with the front end switches except
1230 Arg
: String_Ptr
renames Args
.Table
(Index
);
1232 if not Is_Front_End_Switch
(Arg
.all)
1234 Arg
(Arg
'First + 2 .. Arg
'First + 5) = "RTS="
1236 Add_Argument
(Arg
.all);
1244 -- Now that all the arguments are set, compile the binder
1249 (Gcc_Path
.all, Arguments
(1 .. Argument_Number
), Success
);
1253 ("could not compile binder generated file for library "
1254 & Get_Name_String
(For_Project
.Library_Name
));
1257 -- Process binder generated file for pragmas Linker_Options
1259 Process_Binder_File
(Arguments
(2).all & ASCII
.NUL
);
1263 -- Build the library only if Link is True
1267 -- If attributes Library_GCC or Linker'Driver were specified, get the
1270 if For_Project
.Config
.Shared_Lib_Driver
/= No_File
then
1271 Driver_Name
:= Name_Id
(For_Project
.Config
.Shared_Lib_Driver
);
1274 -- If attribute Library_Options was specified, add these additional
1277 Library_Options
:= Value_Of
1278 (Name_Library_Options
, For_Project
.Decl
.Attributes
, In_Tree
);
1280 if not Library_Options
.Default
then
1282 Current
: String_List_Id
;
1283 Element
: String_Element
;
1286 Current
:= Library_Options
.Values
;
1287 while Current
/= Nil_String
loop
1288 Element
:= In_Tree
.String_Elements
.Table
(Current
);
1289 Get_Name_String
(Element
.Value
);
1291 if Name_Len
/= 0 then
1292 Opts
.Increment_Last
;
1293 Opts
.Table
(Opts
.Last
) :=
1294 new String'(Name_Buffer (1 .. Name_Len));
1297 Current := Element.Next;
1303 new String'(Get_Name_String
(For_Project
.Library_Dir
.Display_Name
));
1304 Lib_Filename
:= new String'
1305 (Get_Name_String (For_Project.Library_Name));
1307 case For_Project.Library_Kind is
1309 The_Build_Mode := Static;
1312 The_Build_Mode := Dynamic;
1315 The_Build_Mode := Relocatable;
1317 if PIC_Option /= "" then
1318 Opts.Increment_Last;
1319 Opts.Table (Opts.Last) := new String'(PIC_Option
);
1323 -- Get the library version, if any
1325 if For_Project
.Lib_Internal_Name
/= No_Name
then
1327 new String'(Get_Name_String (For_Project.Lib_Internal_Name));
1330 -- Add the objects found in the object directory and the object
1331 -- directories of the extended files, if any, except for generated
1332 -- object files (b~.. or B__..) from extended projects.
1333 -- When there are one or more extended files, only add an object file
1334 -- if no object file with the same name have already been added.
1336 In_Main_Object_Directory := True;
1338 Foreign_Sources := Has_Foreign_Sources (For_Project);
1339 Current_Proj := For_Project;
1342 if Current_Proj.Object_Directory /= No_Path_Information then
1344 Object_Dir_Path : constant String :=
1346 (Current_Proj.Object_Directory
1348 Object_Dir : Dir_Type;
1349 Filename : String (1 .. 255);
1354 Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
1356 -- For all entries in the object directory
1359 Read (Object_Dir, Filename, Last);
1363 -- Check if it is an object file
1365 if Is_Obj (Filename (1 .. Last)) then
1367 Object_Path : constant String :=
1370 Directory_Separator &
1371 Filename (1 .. Last));
1372 C_Object_Path : String := Object_Path;
1373 C_Filename : String := Filename (1 .. Last);
1376 Canonical_Case_File_Name (C_Object_Path);
1377 Canonical_Case_File_Name (C_Filename);
1379 -- If in the object directory of an extended
1380 -- project, do not consider generated object files.
1382 if In_Main_Object_Directory
1385 C_Filename (1 .. B_Start'Length) /= B_Start.all
1388 Name_Buffer (1 .. Name_Len) :=
1389 C_Filename (1 .. Last);
1392 if not Objects_Htable.Get (Id) then
1394 ALI_File : constant String :=
1397 (1 .. Last), "ali");
1398 ALI_Path : constant String :=
1399 Ext_To (C_Object_Path, "ali");
1406 (1 .. B_Start'Length) =
1408 Fname : File_Name_Type;
1412 if Is_Regular_File (ALI_Path) then
1414 -- If there is an ALI file, check if
1415 -- the object file should be added to
1416 -- the library. If there are foreign
1417 -- sources we put all object files in
1422 1 .. Unit_Table.Last
1425 if In_Tree.Units.Table
1427 (Body_Part).Name /= No_File
1430 In_Tree.Units.Table (Index).
1432 (Body_Part).Project;
1434 In_Tree.Units.Table (Index).
1435 File_Names (Body_Part).Name;
1440 (Specification).Name /=
1446 (Specification).Project;
1450 (Specification).Name;
1456 Add_It := Proj /= No_Project;
1458 -- If the source is in the
1459 -- project or a project it
1460 -- extends, we may put it in
1464 Add_It := Check_Project (Proj);
1467 -- But we don't, if the ALI file
1468 -- does not correspond to the
1473 F : constant String :=
1478 Add_It := F = ALI_File;
1487 Objects_Htable.Set (Id, True);
1489 (new String'(Object_Path
));
1491 -- Record the ALI file
1493 ALIs
.Append
(new String'(ALI_Path));
1495 -- Find out if for this ALI file,
1496 -- libgnarl or libdecgnat or
1497 -- g-trasym.obj (on OpenVMS) is
1500 Check_Libs (ALI_Path, True);
1503 elsif Foreign_Sources then
1505 (new String'(Object_Path
));
1514 Close
(Dir
=> Object_Dir
);
1517 when Directory_Error
=>
1518 Com
.Fail
("cannot find object directory """
1520 (Current_Proj
.Object_Directory
.Display_Name
)
1525 exit when Current_Proj
.Extends
= No_Project
;
1527 In_Main_Object_Directory
:= False;
1528 Current_Proj
:= Current_Proj
.Extends
;
1531 -- Add the -L and -l switches for the imported Library Project Files,
1532 -- and, if Path Option is supported, the library directory path names
1535 Process_Imported_Libraries
;
1537 -- Link with libgnat and possibly libgnarl
1539 Opts
.Increment_Last
;
1540 Opts
.Table
(Opts
.Last
) := new String'("-L" & Lib_Directory);
1542 -- If Path Option is supported, add libgnat directory path name to
1545 if Path_Option /= null then
1547 Libdir : constant String := Lib_Directory;
1548 GCC_Index : Natural := 0;
1553 -- For shared libraries, add to the Path Option the directory
1554 -- of the shared version of libgcc.
1556 if The_Build_Mode /= Static then
1557 GCC_Index := Index (Libdir, "/lib/");
1559 if GCC_Index = 0 then
1563 Directory_Separator & "lib" & Directory_Separator);
1566 if GCC_Index /= 0 then
1567 Add_Rpath (Libdir (Libdir'First .. GCC_Index + 3));
1573 if Libgnarl_Needed = Yes then
1574 Opts.Increment_Last;
1576 if The_Build_Mode = Static then
1577 Opts.Table (Opts.Last) := new String'("-lgnarl");
1579 Opts
.Table
(Opts
.Last
) := new String'(Shared_Lib ("gnarl"));
1583 if Gtrasymobj_Needed then
1584 Opts.Increment_Last;
1585 Opts.Table (Opts.Last) :=
1586 new String'(Lib_Directory
& "/g-trasym.obj");
1589 if Libdecgnat_Needed
then
1590 Opts
.Increment_Last
;
1592 Opts
.Table
(Opts
.Last
) :=
1593 new String'("-L" & Lib_Directory & "/../declib");
1595 Opts.Increment_Last;
1597 if The_Build_Mode = Static then
1598 Opts.Table (Opts.Last) := new String'("-ldecgnat");
1600 Opts
.Table
(Opts
.Last
) := new String'(Shared_Lib ("decgnat"));
1604 Opts.Increment_Last;
1606 if The_Build_Mode = Static then
1607 Opts.Table (Opts.Last) := new String'("-lgnat");
1609 Opts
.Table
(Opts
.Last
) := new String'(Shared_Lib ("gnat"));
1612 -- If Path Option is supported, add the necessary switch with the
1613 -- content of Rpath. As Rpath contains at least libgnat directory
1614 -- path name, it is guaranteed that it is not null.
1616 if Path_Option /= null then
1617 Opts.Increment_Last;
1618 Opts.Table (Opts.Last) :=
1619 new String'(Path_Option
.all & Rpath
(1 .. Rpath_Last
));
1626 (Argument_List (Objects.Table (1 .. Objects.Last)));
1629 new Argument_List'(Argument_List
(ALIs
.Table
(1 .. ALIs
.Last
)));
1632 new Argument_List
'(Argument_List (Opts.Table (1 .. Opts.Last)));
1634 -- We fail if there are no object to put in the library
1635 -- (Ada or foreign objects).
1637 if Object_Files'Length = 0 then
1638 Com.Fail ("no object files for library """ &
1639 Lib_Filename.all & '"');
1642 if not Opt.Quiet_Output then
1644 Write_Str ("building
");
1645 Write_Str (Ada.Characters.Handling.To_Lower
1646 (Build_Mode_State'Image (The_Build_Mode)));
1647 Write_Str (" library
for project
");
1648 Write_Line (Project_Name);
1650 -- Only output list of object files and ALI files in verbose mode
1652 if Opt.Verbose_Mode then
1655 Write_Line ("object files
:");
1657 for Index in Object_Files'Range loop
1659 Write_Line (Object_Files (Index).all);
1664 if Ali_Files'Length = 0 then
1665 Write_Line ("NO ALI files
");
1668 Write_Line ("ALI files
:");
1670 for Index in Ali_Files'Range loop
1672 Write_Line (Ali_Files (Index).all);
1680 -- We check that all object files are regular files
1684 -- Delete the existing library file, if it exists. Fail if the
1685 -- library file is not writable, or if it is not possible to delete
1689 DLL_Name : aliased String :=
1690 Lib_Dirpath.all & Directory_Separator & DLL_Prefix &
1691 Lib_Filename.all & "." & DLL_Ext;
1693 Archive_Name : aliased String :=
1694 Lib_Dirpath.all & Directory_Separator & "lib
" &
1695 Lib_Filename.all & "." & Archive_Ext;
1697 type Str_Ptr is access all String;
1698 -- This type is necessary to meet the accessibility rules of Ada.
1699 -- It is not possible to use String_Access here.
1701 Full_Lib_Name : Str_Ptr;
1702 -- Designates the full library path name. Either DLL_Name or
1703 -- Archive_Name, depending on the library kind.
1706 pragma Warnings (Off, Success);
1707 -- Used to call Delete_File
1710 if The_Build_Mode = Static then
1711 Full_Lib_Name := Archive_Name'Access;
1713 Full_Lib_Name := DLL_Name'Access;
1716 if Is_Regular_File (Full_Lib_Name.all) then
1717 if Is_Writable_File (Full_Lib_Name.all) then
1718 Delete_File (Full_Lib_Name.all, Success);
1721 if Is_Regular_File (Full_Lib_Name.all) then
1722 Com.Fail ("could
not delete
""" & Full_Lib_Name.all & """");
1727 Argument_Number := 0;
1729 -- If we have a standalone library, gather all the interface ALI.
1730 -- They are passed to Build_Dynamic_Library, where they are used by
1731 -- some platforms (VMS, for example) to decide what symbols should be
1732 -- exported. They are also flagged as Interface when we copy them to
1733 -- the library directory (by Copy_ALI_Files, below).
1736 Current_Proj := For_Project;
1739 Iface : String_List_Id := For_Project.Lib_Interface_ALIs;
1740 ALI : File_Name_Type;
1743 while Iface /= Nil_String loop
1746 (In_Tree.String_Elements.Table (Iface).Value);
1747 Interface_ALIs.Set (ALI, True);
1749 (In_Tree.String_Elements.Table (Iface).Value);
1750 Add_Argument (Name_Buffer (1 .. Name_Len));
1751 Iface := In_Tree.String_Elements.Table (Iface).Next;
1754 Iface := For_Project.Lib_Interface_ALIs;
1756 if not Opt.Quiet_Output then
1758 -- Check that the interface set is complete: any unit in the
1759 -- library that is needed by an interface should also be an
1760 -- interface. If it is not the case, output a warning.
1762 while Iface /= Nil_String loop
1765 (In_Tree.String_Elements.Table (Iface).Value);
1767 Iface := In_Tree.String_Elements.Table (Iface).Next;
1774 Current_Dir : constant String := Get_Current_Dir;
1777 Name : String (1 .. 200);
1780 Disregard : Boolean;
1781 pragma Warnings (Off, Disregard);
1783 DLL_Name : aliased constant String :=
1784 Lib_Filename.all & "." & DLL_Ext;
1786 Archive_Name : aliased constant String :=
1787 Lib_Filename.all & "." & Archive_Ext;
1789 Delete : Boolean := False;
1792 -- Clean the library directory: remove any file with the name of
1793 -- the library file and any ALI file of a source of the project.
1796 Get_Name_String (For_Project.Library_Dir.Name);
1797 Change_Dir (Name_Buffer (1 .. Name_Len));
1802 ("unable to
access library directory
"""
1803 & Name_Buffer (1 .. Name_Len)
1810 Read (Dir, Name, Last);
1814 Filename : constant String := Name (1 .. Last);
1817 if Is_Regular_File (Filename) then
1818 Canonical_Case_File_Name (Name (1 .. Last));
1821 if (The_Build_Mode = Static and then
1822 Name (1 .. Last) = Archive_Name)
1824 ((The_Build_Mode = Dynamic or else
1825 The_Build_Mode = Relocatable)
1827 Name (1 .. Last) = DLL_Name)
1832 and then Name (Last - 3 .. Last) = ".ali
"
1838 -- Compare with ALI file names of the project
1841 1 .. Unit_Table.Last (In_Tree.Units)
1843 Unit := In_Tree.Units.Table (Index);
1845 if Unit.File_Names (Body_Part).Project /=
1848 if Ultimate_Extending_Project_Of
1849 (Unit.File_Names (Body_Part).Project) =
1853 (Unit.File_Names (Body_Part).Name);
1854 Name_Len := Name_Len -
1856 (Name (1 .. Name_Len))'Length;
1857 if Name_Buffer (1 .. Name_Len) =
1858 Name (1 .. Last - 4)
1865 elsif Ultimate_Extending_Project_Of
1866 (Unit.File_Names (Specification).Project) =
1870 (Unit.File_Names (Specification).Name);
1874 (Name (1 .. Name_Len))'Length;
1876 if Name_Buffer (1 .. Name_Len) =
1877 Name (1 .. Last - 4)
1888 Set_Writable (Filename);
1889 Delete_File (Filename, Disregard);
1897 Change_Dir (Current_Dir);
1900 -- Call procedure to build the library, depending on the build mode
1902 case The_Build_Mode is
1903 when Dynamic | Relocatable =>
1904 Build_Dynamic_Library
1905 (Ofiles => Object_Files.all,
1906 Options => Options.all,
1907 Interfaces => Arguments (1 .. Argument_Number),
1908 Lib_Filename => Lib_Filename.all,
1909 Lib_Dir => Lib_Dirpath.all,
1910 Symbol_Data => Current_Proj.Symbol_Data,
1911 Driver_Name => Driver_Name,
1912 Lib_Version => Lib_Version.all,
1913 Auto_Init => Current_Proj.Lib_Auto_Init);
1925 -- We need to copy the ALI files from the object directory to the
1926 -- library ALI directory, so that the linker find them there, and
1927 -- does not need to look in the object directory where it would also
1928 -- find the object files; and we don't want that: we want the linker
1929 -- to use the library.
1931 -- Copy the ALI files and make the copies read-only. For interfaces,
1932 -- mark the copies as interfaces.
1935 (Files => Ali_Files.all,
1936 To => For_Project.Library_ALI_Dir.Name,
1937 Interfaces => Arguments (1 .. Argument_Number));
1939 -- Copy interface sources if Library_Src_Dir specified
1942 and then For_Project.Library_Src_Dir /= No_Path_Information
1944 -- Clean the interface copy directory: remove any source that
1945 -- could be a source of the project.
1948 Get_Name_String (For_Project.Library_Src_Dir.Name);
1949 Change_Dir (Name_Buffer (1 .. Name_Len));
1954 ("unable to
access library source copy directory
"""
1955 & Name_Buffer (1 .. Name_Len)
1961 Delete : Boolean := False;
1964 Name : String (1 .. 200);
1967 Disregard : Boolean;
1968 pragma Warnings (Off, Disregard);
1974 Read (Dir, Name, Last);
1977 if Is_Regular_File (Name (1 .. Last)) then
1978 Canonical_Case_File_Name (Name (1 .. Last));
1981 -- Compare with source file names of the project
1983 for Index in 1 .. Unit_Table.Last (In_Tree.Units) loop
1984 Unit := In_Tree.Units.Table (Index);
1986 if Ultimate_Extending_Project_Of
1987 (Unit.File_Names (Body_Part).Project) = For_Project
1990 (Unit.File_Names (Body_Part).Name) =
1997 if Ultimate_Extending_Project_Of
1998 (Unit.File_Names (Specification).Project) =
2002 (Unit.File_Names (Specification).Name) =
2012 Set_Writable (Name (1 .. Last));
2013 Delete_File (Name (1 .. Last), Disregard);
2020 Copy_Interface_Sources
2021 (For_Project => For_Project,
2023 Interfaces => Arguments (1 .. Argument_Number),
2024 To_Dir => For_Project.Library_Src_Dir.Display_Name);
2028 -- Reset the current working directory to its previous value
2030 Change_Dir (Current_Dir);
2037 procedure Check (Filename : String) is
2039 if not Is_Regular_File (Filename) then
2040 Com.Fail (Filename & " not found
.");
2048 procedure Check_Context is
2050 -- Check that each object file exists
2052 for F in Object_Files'Range loop
2053 Check (Object_Files (F).all);
2061 procedure Check_Library
2062 (For_Project : Project_Id; In_Tree : Project_Tree_Ref)
2064 Lib_TS : Time_Stamp_Type;
2065 Current : constant Dir_Name_Str := Get_Current_Dir;
2068 -- No need to build the library if there is no object directory,
2069 -- hence no object files to build the library.
2071 if For_Project.Library then
2073 Lib_Name : constant File_Name_Type :=
2074 Library_File_Name_For (For_Project, In_Tree);
2076 Change_Dir (Get_Name_String (For_Project.Library_Dir.Name));
2077 Lib_TS := File_Stamp (Lib_Name);
2078 For_Project.Library_TS := Lib_TS;
2081 if not For_Project.Externally_Built
2082 and then not For_Project.Need_To_Build_Lib
2083 and then For_Project.Object_Directory /= No_Path_Information
2086 Obj_TS : Time_Stamp_Type;
2087 Object_Dir : Dir_Type;
2090 if OpenVMS_On_Target then
2091 B_Start := new String'("b__
");
2094 -- If the library file does not exist, then the time stamp will
2095 -- be Empty_Time_Stamp, earlier than any other time stamp.
2098 (Get_Name_String (For_Project.Object_Directory.Name));
2099 Open (Dir => Object_Dir, Dir_Name => ".");
2101 -- For all entries in the object directory
2104 Read (Object_Dir, Name_Buffer, Name_Len);
2105 exit when Name_Len = 0;
2107 -- Check if it is an object file, but ignore any binder
2110 if Is_Obj (Name_Buffer (1 .. Name_Len))
2111 and then Name_Buffer (1 .. B_Start'Length) /= B_Start.all
2113 -- Get the object file time stamp
2115 Obj_TS := File_Stamp (File_Name_Type'(Name_Find));
2117 -- If library file time stamp is earlier, set
2118 -- Need_To_Build_Lib and return. String comparison is
2119 -- used, otherwise time stamps may be too close and the
2120 -- comparison would return True, which would trigger
2121 -- an unnecessary rebuild of the library.
2123 if String (Lib_TS) < String (Obj_TS) then
2125 -- Library must be rebuilt
2127 For_Project.Need_To_Build_Lib := True;
2137 Change_Dir (Current);
2141 ----------------------------
2142 -- Copy_Interface_Sources --
2143 ----------------------------
2145 procedure Copy_Interface_Sources
2146 (For_Project : Project_Id;
2147 In_Tree : Project_Tree_Ref;
2148 Interfaces : Argument_List;
2149 To_Dir : Path_Name_Type)
2151 Current : constant Dir_Name_Str := Get_Current_Dir;
2152 -- The current directory, where to return to at the end
2154 Target : constant Dir_Name_Str := Get_Name_String (To_Dir);
2155 -- The directory where to copy sources
2157 Text : Text_Buffer_Ptr;
2158 The_ALI : ALI.ALI_Id;
2159 Lib_File : File_Name_Type;
2161 First_Unit : ALI.Unit_Id;
2162 Second_Unit : ALI.Unit_Id;
2166 Copy_Subunits : Boolean := False;
2167 -- When True, indicates that subunits, if any, need to be copied too
2169 procedure Copy (File_Name : File_Name_Type);
2170 -- Copy one source of the project to the target directory
2172 function Is_Same_Or_Extension
2173 (Extending : Project_Id;
2174 Extended : Project_Id) return Boolean;
2175 -- Return True if project Extending is equal to or extends project
2182 procedure Copy (File_Name : File_Name_Type) is
2184 pragma Warnings (Off, Success);
2188 for Index in Unit_Table.First ..
2189 Unit_Table.Last (In_Tree.Units)
2191 Data := In_Tree.Units.Table (Index);
2193 -- Find and copy the immediate or inherited source
2195 for J in Data.File_Names'Range loop
2196 if Is_Same_Or_Extension
2197 (For_Project, Data.File_Names (J).Project)
2198 and then Data.File_Names (J).Name = File_Name
2201 (Get_Name_String (Data.File_Names (J).Path.Name),
2205 Preserve => Preserve);
2212 --------------------------
2213 -- Is_Same_Or_Extension --
2214 --------------------------
2216 function Is_Same_Or_Extension
2217 (Extending : Project_Id;
2218 Extended : Project_Id) return Boolean
2224 while Ext /= No_Project loop
2225 if Ext = Extended then
2233 end Is_Same_Or_Extension;
2235 -- Start of processing for Copy_Interface_Sources
2238 -- Change the working directory to the object directory
2240 Change_Dir (Get_Name_String (For_Project.Object_Directory.Name));
2242 for Index in Interfaces'Range loop
2244 -- First, load the ALI file
2247 Add_Str_To_Name_Buffer (Interfaces (Index).all);
2248 Lib_File := Name_Find;
2249 Text := Read_Library_Info (Lib_File);
2250 The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
2253 Second_Unit := No_Unit_Id;
2254 First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
2255 Copy_Subunits := True;
2257 -- If there is both a spec and a body, check if they are both needed
2259 if ALI.Units.Table (First_Unit).Utype = Is_Body then
2260 Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
2262 -- If the body is not needed, then reset First_Unit
2264 if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
2265 First_Unit := No_Unit_Id;
2266 Copy_Subunits := False;
2269 elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
2270 Copy_Subunits := False;
2273 -- Copy the file(s) that need to be copied
2275 if First_Unit /= No_Unit_Id then
2276 Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
2279 if Second_Unit /= No_Unit_Id then
2280 Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
2283 -- Copy all the separates, if any
2285 if Copy_Subunits then
2286 for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
2287 ALI.ALIs.Table (The_ALI).Last_Sdep
2289 if Sdep.Table (Dep).Subunit_Name /= No_Name then
2290 Copy (File_Name => Sdep.Table (Dep).Sfile);
2296 -- Restore the initial working directory
2298 Change_Dir (Current);
2299 end Copy_Interface_Sources;
2305 procedure Display (Executable : String) is
2307 if not Opt.Quiet_Output then
2308 Write_Str (Executable);
2310 for Index in 1 .. Argument_Number loop
2312 Write_Str (Arguments (Index).all);
2323 function Index (S, Pattern : String) return Natural is
2324 Len : constant Natural := Pattern'Length;
2327 for J in reverse S'First .. S'Last - Len + 1 loop
2328 if Pattern = S (J .. J + Len - 1) then
2336 -------------------------
2337 -- Process_Binder_File --
2338 -------------------------
2340 procedure Process_Binder_File (Name : String) is
2342 -- Binder file's descriptor
2344 Read_Mode : constant String := "r
" & ASCII.NUL;
2347 Status : Interfaces.C_Streams.int;
2348 pragma Unreferenced (Status);
2351 Begin_Info : constant String := "-- BEGIN Object file/option list";
2352 End_Info
: constant String := "-- END Object file/option list ";
2354 Next_Line
: String (1 .. 1000);
2355 -- Current line value
2356 -- Where does this odd constant 1000 come from, looks suspicious ???
2359 -- End of line slice (the slice does not contain the line terminator)
2361 procedure Get_Next_Line
;
2362 -- Read the next line from the binder file without the line terminator
2368 procedure Get_Next_Line
is
2372 Fchars
:= fgets
(Next_Line
'Address, Next_Line
'Length, Fd
);
2374 if Fchars
= System
.Null_Address
then
2375 Fail
("Error reading binder output");
2379 while Nlast
<= Next_Line
'Last
2380 and then Next_Line
(Nlast
) /= ASCII
.LF
2381 and then Next_Line
(Nlast
) /= ASCII
.CR
2389 -- Start of processing for Process_Binder_File
2392 Fd
:= fopen
(Name
'Address, Read_Mode
'Address);
2394 if Fd
= NULL_Stream
then
2395 Fail
("Failed to open binder output");
2398 -- Skip up to the Begin Info line
2402 exit when Next_Line
(1 .. Nlast
) = Begin_Info
;
2405 -- Find the first switch
2410 exit when Next_Line
(1 .. Nlast
) = End_Info
;
2412 -- As the binder generated file is in Ada, remove the first eight
2413 -- characters " -- ".
2415 Next_Line
(1 .. Nlast
- 8) := Next_Line
(9 .. Nlast
);
2418 -- Stop when the first switch is found
2420 exit when Next_Line
(1) = '-';
2423 if Next_Line
(1 .. Nlast
) /= End_Info
then
2425 -- Ignore -static and -shared, since -shared will be used
2428 -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added
2429 -- later, because they are also needed for non Stand-Alone shared
2432 -- Also ignore the shared libraries which are :
2434 -- UNIX / Windows VMS
2435 -- -lgnat-<version> -lgnat_<version> (7 + version'length chars)
2436 -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars)
2438 if Next_Line
(1 .. Nlast
) /= "-static" and then
2439 Next_Line
(1 .. Nlast
) /= "-shared" and then
2440 Next_Line
(1 .. Nlast
) /= "-ldecgnat" and then
2441 Next_Line
(1 .. Nlast
) /= "-lgnarl" and then
2442 Next_Line
(1 .. Nlast
) /= "-lgnat" and then
2444 (1 .. Natural'Min (Nlast
, 10 + Library_Version
'Length)) /=
2445 Shared_Lib
("decgnat") and then
2447 (1 .. Natural'Min (Nlast
, 8 + Library_Version
'Length)) /=
2448 Shared_Lib
("gnarl") and then
2450 (1 .. Natural'Min (Nlast
, 7 + Library_Version
'Length)) /=
2453 if Next_Line
(1) /= '-' then
2455 -- This is not an option, should we add it?
2457 if Add_Object_Files
then
2458 Opts
.Increment_Last
;
2459 Opts
.Table
(Opts
.Last
) :=
2460 new String'(Next_Line (1 .. Nlast));
2464 -- Add all other options
2466 Opts.Increment_Last;
2467 Opts.Table (Opts.Last) :=
2468 new String'(Next_Line
(1 .. Nlast
));
2472 -- Next option, if any
2475 exit when Next_Line
(1 .. Nlast
) = End_Info
;
2477 -- Remove first eight characters " -- "
2479 Next_Line
(1 .. Nlast
- 8) := Next_Line
(9 .. Nlast
);
2484 Status
:= fclose
(Fd
);
2486 -- Is it really right to ignore any close error ???
2488 end Process_Binder_File
;
2494 procedure Reset_Tables
is
2497 Objects_Htable
.Reset
;
2500 Processed_Projects
.Reset
;
2504 ---------------------------
2505 -- SALs_Use_Constructors --
2506 ---------------------------
2508 function SALs_Use_Constructors
return Boolean is
2509 function C_SALs_Init_Using_Constructors
return Integer;
2510 pragma Import
(C
, C_SALs_Init_Using_Constructors
,
2511 "__gnat_sals_init_using_constructors");
2513 return C_SALs_Init_Using_Constructors
/= 0;
2514 end SALs_Use_Constructors
;