1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
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 ------------------------------------------------------------------------------
26 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
30 with MLib
.Tgt
; use MLib
.Tgt
;
33 with Namet
; use Namet
;
35 with Osint
; use Osint
;
39 with Prj
.Ext
; use Prj
.Ext
;
41 with Prj
.Util
; use Prj
.Util
;
43 with Snames
; use Snames
;
47 with Types
; use Types
;
48 with Hostparm
; use Hostparm
;
49 -- Used to determine if we are in VMS or not for error message purposes
51 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
52 with Ada
.Command_Line
; use Ada
.Command_Line
;
53 with Ada
.Text_IO
; use Ada
.Text_IO
;
55 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
57 with VMS_Conv
; use VMS_Conv
;
60 Project_Tree
: constant Project_Tree_Ref
:= new Project_Tree_Data
;
61 Project_File
: String_Access
;
62 Project
: Prj
.Project_Id
;
63 Current_Verbosity
: Prj
.Verbosity
:= Prj
.Default
;
64 Tool_Package_Name
: Name_Id
:= No_Name
;
66 B_Start
: String_Ptr
:= new String'("b~");
67 -- Prefix of binder generated file, changed to b__ for VMS
69 Old_Project_File_Used : Boolean := False;
70 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
71 -- an old fashioned project file. -p cannot be used in conjunction
74 Temp_File_Name : Path_Name_Type := No_Path;
75 -- The name of the temporary text file to put a list of source/object
76 -- files to pass to a tool.
78 ASIS_Main : String_Access := null;
79 -- Main for commands Check, Metric and Pretty, when -U is used
81 package First_Switches is new Table.Table
82 (Table_Component_Type => String_Access,
83 Table_Index_Type => Integer,
86 Table_Increment => 100,
87 Table_Name => "Gnatcmd.First_Switches");
88 -- A table to keep the switches from the project file
90 package Carg_Switches is new Table.Table
91 (Table_Component_Type => String_Access,
92 Table_Index_Type => Integer,
95 Table_Increment => 100,
96 Table_Name => "Gnatcmd.Carg_Switches");
97 -- A table to keep the switches following -cargs for ASIS tools
99 package Rules_Switches is new Table.Table
100 (Table_Component_Type => String_Access,
101 Table_Index_Type => Integer,
102 Table_Low_Bound => 1,
104 Table_Increment => 100,
105 Table_Name => "Gnatcmd.Rules_Switches");
106 -- A table to keep the switches following -rules for gnatcheck
108 package Library_Paths is new Table.Table (
109 Table_Component_Type => String_Access,
110 Table_Index_Type => Integer,
111 Table_Low_Bound => 1,
113 Table_Increment => 100,
114 Table_Name => "Make.Library_Path");
116 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
117 -- tool. We allocate objects because we cannot declare aliased objects
118 -- as we are in a procedure, not a library level package.
120 subtype SA is String_Access;
122 Naming_String : constant SA := new String'("naming");
123 Binder_String
: constant SA
:= new String'("binder");
124 Compiler_String : constant SA := new String'("compiler");
125 Check_String
: constant SA
:= new String'("check");
126 Synchronize_String : constant SA := new String'("synchronize");
127 Eliminate_String
: constant SA
:= new String'("eliminate");
128 Finder_String : constant SA := new String'("finder");
129 Linker_String
: constant SA
:= new String'("linker");
130 Gnatls_String : constant SA := new String'("gnatls");
131 Pretty_String
: constant SA
:= new String'("pretty_printer");
132 Stack_String : constant SA := new String'("stack");
133 Gnatstub_String
: constant SA
:= new String'("gnatstub");
134 Metric_String : constant SA := new String'("metrics");
135 Xref_String
: constant SA
:= new String'("cross_reference");
137 Packages_To_Check_By_Binder : constant String_List_Access :=
138 new String_List'((Naming_String
, Binder_String
));
140 Packages_To_Check_By_Check
: constant String_List_Access
:=
141 new String_List
'((Naming_String, Check_String, Compiler_String));
143 Packages_To_Check_By_Sync : constant String_List_Access :=
144 new String_List'((Naming_String
, Synchronize_String
, Compiler_String
));
146 Packages_To_Check_By_Eliminate
: constant String_List_Access
:=
147 new String_List
'((Naming_String, Eliminate_String, Compiler_String));
149 Packages_To_Check_By_Finder : constant String_List_Access :=
150 new String_List'((Naming_String
, Finder_String
));
152 Packages_To_Check_By_Linker
: constant String_List_Access
:=
153 new String_List
'((Naming_String, Linker_String));
155 Packages_To_Check_By_Gnatls : constant String_List_Access :=
156 new String_List'((Naming_String
, Gnatls_String
));
158 Packages_To_Check_By_Pretty
: constant String_List_Access
:=
159 new String_List
'((Naming_String, Pretty_String, Compiler_String));
161 Packages_To_Check_By_Stack : constant String_List_Access :=
162 new String_List'((Naming_String
, Stack_String
));
164 Packages_To_Check_By_Gnatstub
: constant String_List_Access
:=
165 new String_List
'((Naming_String, Gnatstub_String, Compiler_String));
167 Packages_To_Check_By_Metric : constant String_List_Access :=
168 new String_List'((Naming_String
, Metric_String
, Compiler_String
));
170 Packages_To_Check_By_Xref
: constant String_List_Access
:=
171 new String_List
'((Naming_String, Xref_String));
173 Packages_To_Check : String_List_Access := Prj.All_Packages;
175 ----------------------------------
176 -- Declarations for GNATCMD use --
177 ----------------------------------
179 The_Command : Command_Type;
180 -- The command specified in the invocation of the GNAT driver
182 Command_Arg : Positive := 1;
183 -- The index of the command in the arguments of the GNAT driver
185 My_Exit_Status : Exit_Status := Success;
186 -- The exit status of the spawned tool. Used to set the correct VMS
189 Current_Work_Dir : constant String := Get_Current_Dir;
190 -- The path of the working directory
192 All_Projects : Boolean := False;
193 -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
194 -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
195 -- should be invoked for all sources of all projects.
197 -----------------------
198 -- Local Subprograms --
199 -----------------------
201 procedure Add_To_Carg_Switches (Switch : String_Access);
202 -- Add a switch to the Carg_Switches table. If it is the first one, put the
203 -- switch "-cargs" at the beginning of the table.
205 procedure Add_To_Rules_Switches (Switch : String_Access);
206 -- Add a switch to the Rules_Switches table. If it is the first one, put
207 -- the switch "-crules" at the beginning of the table.
209 procedure Check_Files;
210 -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
211 -- project file is specified, without any file arguments. If it is the
212 -- case, invoke the GNAT tool with the proper list of files, derived from
213 -- the sources of the project.
215 function Check_Project
216 (Project : Project_Id;
217 Root_Project : Project_Id) return Boolean;
218 -- Returns True if Project = Root_Project or if we want to consider all
219 -- sources of all projects. For GNAT METRIC, also returns True if Project
220 -- is extended by Root_Project.
222 procedure Check_Relative_Executable (Name : in out String_Access);
223 -- Check if an executable is specified as a relative path. If it is, and
224 -- the path contains directory information, fail. Otherwise, prepend the
225 -- exec directory. This procedure is only used for GNAT LINK when a project
226 -- file is specified.
228 function Configuration_Pragmas_File return Path_Name_Type;
229 -- Return an argument, if there is a configuration pragmas file to be
230 -- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT
231 -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT
234 procedure Delete_Temp_Config_Files;
235 -- Delete all temporary config files. The caller is responsible for
236 -- ensuring that Keep_Temporary_Files is False.
238 procedure Get_Closure;
239 -- Get the sources in the closure of the ASIS_Main and add them to the
240 -- list of arguments.
242 function Index (Char : Character; Str : String) return Natural;
243 -- Returns first occurrence of Char in Str, returns 0 if Char not in Str
245 procedure Non_VMS_Usage;
246 -- Display usage for platforms other than VMS
248 procedure Process_Link;
249 -- Process GNAT LINK, when there is a project file specified
251 procedure Set_Library_For
252 (Project : Project_Id;
253 Libraries_Present : in out Boolean);
254 -- If Project is a library project, add the correct -L and -l switches to
255 -- the linker invocation.
257 procedure Set_Libraries is
258 new For_Every_Project_Imported (Boolean, Set_Library_For);
259 -- Add the -L and -l switches to the linker for all of the library
262 procedure Test_If_Relative_Path
263 (Switch : in out String_Access;
265 -- Test if Switch is a relative search path switch. If it is and it
266 -- includes directory information, prepend the path with Parent. This
267 -- subprogram is only called when using project files.
269 --------------------------
270 -- Add_To_Carg_Switches --
271 --------------------------
273 procedure Add_To_Carg_Switches (Switch : String_Access) is
275 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
277 if Carg_Switches.Last = 0 then
278 Carg_Switches.Increment_Last;
279 Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
282 Carg_Switches
.Increment_Last
;
283 Carg_Switches
.Table
(Carg_Switches
.Last
) := Switch
;
284 end Add_To_Carg_Switches
;
286 ---------------------------
287 -- Add_To_Rules_Switches --
288 ---------------------------
290 procedure Add_To_Rules_Switches
(Switch
: String_Access
) is
292 -- If the Rules_Switches table is empty, put "-rules" at the beginning
294 if Rules_Switches
.Last
= 0 then
295 Rules_Switches
.Increment_Last
;
296 Rules_Switches
.Table
(Rules_Switches
.Last
) := new String'("-rules");
299 Rules_Switches.Increment_Last;
300 Rules_Switches.Table (Rules_Switches.Last) := Switch;
301 end Add_To_Rules_Switches;
307 procedure Check_Files is
308 Add_Sources : Boolean := True;
309 Unit : Prj.Unit_Index;
310 Subunit : Boolean := False;
311 FD : File_Descriptor := Invalid_FD;
316 -- Check if there is at least one argument that is not a switch
318 for Index in 1 .. Last_Switches.Last loop
319 if Last_Switches.Table (Index) (1) /= '-' then
320 Add_Sources := False;
325 -- If all arguments were switches, add the path names of all the sources
326 -- of the main project.
330 -- For gnatcheck, gnatpp and gnatmetric , create a temporary file and
331 -- put the list of sources in it.
333 if The_Command = Check or else
334 The_Command = Pretty or else
337 Tempdir.Create_Temp_File (FD, Temp_File_Name);
338 Last_Switches.Increment_Last;
339 Last_Switches.Table (Last_Switches.Last) :=
340 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
347 -- Gnatstack needs to add the .ci file for the binder generated
348 -- files corresponding to all of the library projects and main
349 -- units belonging to the application.
351 if The_Command
= Stack
then
352 Proj
:= Project_Tree
.Projects
;
353 while Proj
/= null loop
354 if Check_Project
(Proj
.Project
, Project
) then
356 Main
: String_List_Id
;
357 File
: String_Access
;
360 -- Include binder generated files for main programs
362 Main
:= Proj
.Project
.Mains
;
363 while Main
/= Nil_String
loop
367 (Proj.Project.Object_Directory.Name) &
371 (Project_Tree.String_Elements.Table
375 if Is_Regular_File (File.all) then
376 Last_Switches.Increment_Last;
377 Last_Switches.Table (Last_Switches.Last) := File;
381 Project_Tree.String_Elements.Table (Main).Next;
384 if Proj.Project.Library then
386 -- Include the .ci file for the binder generated
387 -- files that contains the initialization and
388 -- finalization of the library.
393 (Proj
.Project
.Object_Directory
.Name
) &
395 Get_Name_String
(Proj
.Project
.Library_Name
) &
398 if Is_Regular_File
(File
.all) then
399 Last_Switches
.Increment_Last
;
400 Last_Switches
.Table
(Last_Switches
.Last
) := File
;
410 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
411 while Unit
/= No_Unit_Index
loop
413 -- For gnatls, we only need to put the library units, body or
414 -- spec, but not the subunits.
416 if The_Command
= List
then
417 if Unit
.File_Names
(Impl
) /= null
418 and then not Unit
.File_Names
(Impl
).Locally_Removed
420 -- There is a body, check if it is for this project
422 if All_Projects
or else
423 Unit
.File_Names
(Impl
).Project
= Project
427 if Unit
.File_Names
(Spec
) = null
428 or else Unit
.File_Names
(Spec
).Locally_Removed
430 -- We have a body with no spec: we need to check if
431 -- this is a subunit, because gnatls will complain
435 Src_Ind
: constant Source_File_Index
:=
436 Sinput
.P
.Load_Project_File
442 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
447 Last_Switches
.Increment_Last
;
448 Last_Switches
.Table
(Last_Switches
.Last
) :=
452 (Impl).Display_File));
456 elsif Unit.File_Names (Spec) /= null
457 and then not Unit.File_Names (Spec).Locally_Removed
459 -- We have a spec with no body. Check if it is for this
462 if All_Projects or else
463 Unit.File_Names (Spec).Project = Project
465 Last_Switches.Increment_Last;
466 Last_Switches.Table (Last_Switches.Last) :=
467 new String'(Get_Name_String
468 (Unit
.File_Names
(Spec
).Display_File
));
472 -- For gnatstack, we put the .ci files corresponding to the
473 -- different units, including the binder generated files. We
474 -- only need to do that for the library units, body or spec,
475 -- but not the subunits.
477 elsif The_Command
= Stack
then
478 if Unit
.File_Names
(Impl
) /= null
479 and then not Unit
.File_Names
(Impl
).Locally_Removed
481 -- There is a body. Check if .ci files for this project
485 (Unit
.File_Names
(Impl
).Project
, Project
)
489 if Unit
.File_Names
(Spec
) = null
490 or else Unit
.File_Names
(Spec
).Locally_Removed
492 -- We have a body with no spec: we need to check
493 -- if this is a subunit, because .ci files are not
494 -- generated for subunits.
497 Src_Ind
: constant Source_File_Index
:=
498 Sinput
.P
.Load_Project_File
504 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
509 Last_Switches
.Increment_Last
;
510 Last_Switches
.Table
(Last_Switches
.Last
) :=
514 (Impl).Project. Object_Directory.Name) &
517 (Unit.File_Names (Impl).Display_File),
522 elsif Unit.File_Names (Spec) /= null
523 and then not Unit.File_Names (Spec).Locally_Removed
525 -- Spec with no body, check if it is for this project
528 (Unit.File_Names (Spec).Project, Project)
530 Last_Switches.Increment_Last;
531 Last_Switches.Table (Last_Switches.Last) :=
535 (Spec
).Project
. Object_Directory
.Name
) &
538 (Get_Name_String
(Unit
.File_Names
(Spec
).File
),
544 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
545 -- sources of the project, or of all projects if -U was
548 for Kind
in Spec_Or_Body
loop
549 if Unit
.File_Names
(Kind
) /= null
550 and then Check_Project
551 (Unit
.File_Names
(Kind
).Project
, Project
)
552 and then not Unit
.File_Names
(Kind
).Locally_Removed
555 (Unit
.File_Names
(Kind
).Path
.Display_Name
);
557 if FD
/= Invalid_FD
then
558 Name_Len
:= Name_Len
+ 1;
559 Name_Buffer
(Name_Len
) := ASCII
.LF
;
561 Write
(FD
, Name_Buffer
(1)'Address, Name_Len
);
563 if Status
/= Name_Len
then
564 Osint
.Fail
("disk full");
568 Last_Switches
.Increment_Last
;
569 Last_Switches
.Table
(Last_Switches
.Last
) :=
570 new String'(Get_Name_String
572 (Kind).Path.Display_Name));
578 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
582 if FD /= Invalid_FD then
586 Osint.Fail ("disk full");
596 function Check_Project
597 (Project : Project_Id;
598 Root_Project : Project_Id) return Boolean
603 if Project = No_Project then
606 elsif All_Projects or else Project = Root_Project then
609 elsif The_Command = Metric then
610 Proj := Root_Project;
611 while Proj.Extends /= No_Project loop
612 if Project = Proj.Extends then
616 Proj := Proj.Extends;
623 -------------------------------
624 -- Check_Relative_Executable --
625 -------------------------------
627 procedure Check_Relative_Executable (Name : in out String_Access) is
628 Exec_File_Name : constant String := Name.all;
631 if not Is_Absolute_Path (Exec_File_Name) then
632 for Index in Exec_File_Name'Range loop
633 if Exec_File_Name (Index) = Directory_Separator then
634 Fail ("relative executable (""" &
636 """) with directory part not allowed " &
637 "when using project files");
641 Get_Name_String (Project.Exec_Directory.Name);
643 if Name_Buffer (Name_Len) /= Directory_Separator then
644 Name_Len := Name_Len + 1;
645 Name_Buffer (Name_Len) := Directory_Separator;
648 Name_Buffer (Name_Len + 1 ..
649 Name_Len + Exec_File_Name'Length) :=
651 Name_Len := Name_Len + Exec_File_Name'Length;
652 Name := new String'(Name_Buffer
(1 .. Name_Len
));
654 end Check_Relative_Executable
;
656 --------------------------------
657 -- Configuration_Pragmas_File --
658 --------------------------------
660 function Configuration_Pragmas_File
return Path_Name_Type
is
662 Prj
.Env
.Create_Config_Pragmas_File
(Project
, Project_Tree
);
663 return Project
.Config_File_Name
;
664 end Configuration_Pragmas_File
;
666 ------------------------------
667 -- Delete_Temp_Config_Files --
668 ------------------------------
670 procedure Delete_Temp_Config_Files
is
673 pragma Warnings
(Off
, Success
);
676 -- This should only be called if Keep_Temporary_Files is False
678 pragma Assert
(not Keep_Temporary_Files
);
680 if Project
/= No_Project
then
681 Proj
:= Project_Tree
.Projects
;
682 while Proj
/= null loop
683 if Proj
.Project
.Config_File_Temp
then
684 Delete_Temporary_File
685 (Project_Tree
, Proj
.Project
.Config_File_Name
);
692 -- If a temporary text file that contains a list of files for a tool
693 -- has been created, delete this temporary file.
695 if Temp_File_Name
/= No_Path
then
696 Delete_Temporary_File
(Project_Tree
, Temp_File_Name
);
698 end Delete_Temp_Config_Files
;
704 procedure Get_Closure
is
705 Args
: constant Argument_List
:=
706 (1 => new String'("-q"),
707 2 => new String'("-b"),
708 3 => new String'("-P"),
711 6 => new String'("-bargs"),
712 7 => new String'("-R"),
713 8 => new String'("-Z"));
714 -- Arguments for the invocation of gnatmake which are added to the
715 -- Last_Arguments list by this procedure.
717 FD
: File_Descriptor
;
718 -- File descriptor for the temp file that will get the output of the
719 -- invocation of gnatmake.
721 Name
: Path_Name_Type
;
722 -- Path of the file FD
724 GN_Name
: constant String := Program_Name
("gnatmake", "gnat").all;
727 GN_Path
: constant String_Access
:= Locate_Exec_On_Path
(GN_Name
);
730 Return_Code
: Integer;
733 pragma Warnings
(Off
, Unused
);
735 File
: Ada
.Text_IO
.File_Type
;
736 Line
: String (1 .. 250);
738 -- Used to read file if there is an error, it is good enough to display
739 -- just 250 characters if the first line of the file is very long.
742 Path
: Path_Name_Type
;
745 if GN_Path
= null then
746 Put_Line
(Standard_Error
, "could not locate " & GN_Name
);
750 -- Create the temp file
752 Tempdir
.Create_Temp_File
(FD
, Name
);
754 -- And close it, because on VMS Spawn with a file descriptor created
755 -- with Create_Temp_File does not redirect output.
759 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
762 (Program_Name
=> GN_Path
.all,
764 Output_File
=> Get_Name_String
(Name
),
766 Return_Code
=> Return_Code
,
771 -- Read the output of the invocation of gnatmake
773 Open
(File
, In_File
, Get_Name_String
(Name
));
775 -- If it was unsuccessful, display the first line in the file and exit
778 if Return_Code
/= 0 then
779 Get_Line
(File
, Line
, Last
);
781 if not Keep_Temporary_Files
then
787 Put_Line
(Standard_Error
, Line
(1 .. Last
));
789 (Standard_Error
, "could not get closure of " & ASIS_Main
.all);
793 -- Get each file name in the file, find its path and add it the
794 -- list of arguments.
796 while not End_Of_File
(File
) loop
797 Get_Line
(File
, Line
, Last
);
800 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
801 while Unit
/= No_Unit_Index
loop
802 if Unit
.File_Names
(Spec
) /= null
804 Get_Name_String
(Unit
.File_Names
(Spec
).File
) =
807 Path
:= Unit
.File_Names
(Spec
).Path
.Name
;
810 elsif Unit
.File_Names
(Impl
) /= null
812 Get_Name_String
(Unit
.File_Names
(Impl
).File
) =
815 Path
:= Unit
.File_Names
(Impl
).Path
.Name
;
819 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
822 Last_Switches
.Increment_Last
;
824 if Path
/= No_Path
then
825 Last_Switches
.Table
(Last_Switches
.Last
) :=
826 new String'(Get_Name_String (Path));
829 Last_Switches.Table (Last_Switches.Last) :=
830 new String'(Line
(1 .. Last
));
834 if not Keep_Temporary_Files
then
846 function Index
(Char
: Character; Str
: String) return Natural is
848 for Index
in Str
'Range loop
849 if Str
(Index
) = Char
then
861 procedure Process_Link
is
862 Look_For_Executable
: Boolean := True;
863 Libraries_Present
: Boolean := False;
864 Path_Option
: constant String_Access
:=
865 MLib
.Linker_Library_Path_Option
;
866 Prj
: Project_Id
:= Project
;
869 Skip_Executable
: Boolean := False;
872 -- Add the default search directories, to be able to find
873 -- libgnat in call to MLib.Utl.Lib_Directory.
875 Add_Default_Search_Dirs
;
877 Library_Paths
.Set_Last
(0);
879 -- Check if there are library project files
881 if MLib
.Tgt
.Support_For_Libraries
/= None
then
882 Set_Libraries
(Project
, Libraries_Present
);
885 -- If there are, add the necessary additional switches
887 if Libraries_Present
then
889 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
891 Last_Switches
.Increment_Last
;
892 Last_Switches
.Table
(Last_Switches
.Last
) :=
893 new String'("-L" & MLib.Utl.Lib_Directory);
894 Last_Switches.Increment_Last;
895 Last_Switches.Table (Last_Switches.Last) :=
896 new String'("-lgnarl");
897 Last_Switches
.Increment_Last
;
898 Last_Switches
.Table
(Last_Switches
.Last
) :=
899 new String'("-lgnat");
901 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
902 -- equivalent) with all the library dirs plus the standard GNAT
905 if Path_Option /= null then
907 Option : String_Access;
908 Length : Natural := Path_Option'Length;
912 if MLib.Separate_Run_Path_Options then
914 -- We are going to create one switch of the form
915 -- "-Wl,-rpath,dir_N" for each directory to consider.
917 -- One switch for each library directory
920 Library_Paths.First .. Library_Paths.Last
922 Last_Switches.Increment_Last;
924 (Last_Switches.Last) := new String'
926 Last_Switches
.Table
(Index
).all);
929 -- One switch for the standard GNAT library dir
931 Last_Switches
.Increment_Last
;
933 (Last_Switches
.Last
) := new String'
934 (Path_Option.all & MLib.Utl.Lib_Directory);
937 -- First, compute the exact length for the switch
940 Library_Paths.First .. Library_Paths.Last
942 -- Add the length of the library dir plus one for the
943 -- directory separator.
947 Library_Paths.Table (Index)'Length + 1;
950 -- Finally, add the length of the standard GNAT library dir
952 Length := Length + MLib.Utl.Lib_Directory'Length;
953 Option := new String (1 .. Length);
954 Option (1 .. Path_Option'Length) := Path_Option.all;
955 Current := Path_Option'Length;
957 -- Put each library dir followed by a dir separator
960 Library_Paths.First .. Library_Paths.Last
965 Library_Paths.Table (Index)'Length) :=
966 Library_Paths.Table (Index).all;
969 Library_Paths.Table (Index)'Length + 1;
970 Option (Current) := Path_Separator;
973 -- Finally put the standard GNAT library dir
977 Current + MLib.Utl.Lib_Directory'Length) :=
978 MLib.Utl.Lib_Directory;
980 -- And add the switch to the last switches
982 Last_Switches.Increment_Last;
983 Last_Switches.Table (Last_Switches.Last) :=
990 -- Check if the first ALI file specified can be found, either in the
991 -- object directory of the main project or in an object directory of a
992 -- project file extended by the main project. If the ALI file can be
993 -- found, replace its name with its absolute path.
995 Skip_Executable := False;
997 Switch_Loop : for J in 1 .. Last_Switches.Last loop
999 -- If we have an executable just reset the flag
1001 if Skip_Executable then
1002 Skip_Executable := False;
1004 -- If -o, set flag so that next switch is not processed
1006 elsif Last_Switches.Table (J).all = "-o" then
1007 Skip_Executable := True;
1013 Switch : constant String :=
1014 Last_Switches.Table (J).all;
1015 ALI_File : constant String (1 .. Switch'Length + 4) :=
1018 Test_Existence : Boolean := False;
1021 Last := Switch'Length;
1023 -- Skip real switches
1025 if Switch'Length /= 0
1026 and then Switch (Switch'First) /= '-'
1028 -- Append ".ali" if file name does not end with it
1030 if Switch'Length <= 4
1031 or else Switch (Switch'Last - 3 .. Switch'Last)
1034 Last := ALI_File'Last;
1037 -- If file name includes directory information, stop if ALI
1040 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1041 Test_Existence := True;
1044 for K in Switch'Range loop
1045 if Switch (K) = '/' or else
1046 Switch (K) = Directory_Separator
1048 Test_Existence := True;
1054 if Test_Existence then
1055 if Is_Regular_File (ALI_File (1 .. Last)) then
1059 -- Look in object directories if ALI file exists
1064 Dir : constant String :=
1065 Get_Name_String (Prj.Object_Directory.Name);
1069 ALI_File (1 .. Last))
1071 -- We have found the correct project, so we
1072 -- replace the file with the absolute path.
1074 Last_Switches.Table (J) :=
1075 new String'(Dir
& ALI_File
(1 .. Last
));
1083 -- Go to the project being extended, if any
1086 exit Project_Loop
when Prj
= No_Project
;
1087 end loop Project_Loop
;
1092 end loop Switch_Loop
;
1094 -- If a relative path output file has been specified, we add the exec
1097 for J
in reverse 1 .. Last_Switches
.Last
- 1 loop
1098 if Last_Switches
.Table
(J
).all = "-o" then
1099 Check_Relative_Executable
1100 (Name
=> Last_Switches
.Table
(J
+ 1));
1101 Look_For_Executable
:= False;
1106 if Look_For_Executable
then
1107 for J
in reverse 1 .. First_Switches
.Last
- 1 loop
1108 if First_Switches
.Table
(J
).all = "-o" then
1109 Look_For_Executable
:= False;
1110 Check_Relative_Executable
1111 (Name
=> First_Switches
.Table
(J
+ 1));
1117 -- If no executable is specified, then find the name of the first ALI
1118 -- file on the command line and issue a -o switch with the absolute path
1119 -- of the executable in the exec directory.
1121 if Look_For_Executable
then
1122 for J
in 1 .. Last_Switches
.Last
loop
1123 Arg
:= Last_Switches
.Table
(J
);
1126 if Arg
'Length /= 0 and then Arg
(Arg
'First) /= '-' then
1128 and then Arg
(Arg
'Last - 3 .. Arg
'Last) = ".ali"
1130 Last
:= Arg
'Last - 4;
1132 elsif Is_Regular_File
(Arg
.all & ".ali") then
1137 Last_Switches
.Increment_Last
;
1138 Last_Switches
.Table
(Last_Switches
.Last
) :=
1140 Get_Name_String (Project.Exec_Directory.Name);
1141 Last_Switches.Increment_Last;
1142 Last_Switches.Table (Last_Switches.Last) :=
1143 new String'(Name_Buffer
(1 .. Name_Len
) &
1145 (Base_Name
(Arg
(Arg
'First .. Last
))));
1153 ---------------------
1154 -- Set_Library_For --
1155 ---------------------
1157 procedure Set_Library_For
1158 (Project
: Project_Id
;
1159 Libraries_Present
: in out Boolean)
1161 Path_Option
: constant String_Access
:=
1162 MLib
.Linker_Library_Path_Option
;
1165 -- Case of library project
1167 if Project
.Library
then
1168 Libraries_Present
:= True;
1170 -- Add the -L switch
1172 Last_Switches
.Increment_Last
;
1173 Last_Switches
.Table
(Last_Switches
.Last
) :=
1174 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1176 -- Add the -l switch
1178 Last_Switches.Increment_Last;
1179 Last_Switches.Table (Last_Switches.Last) :=
1180 new String'("-l" & Get_Name_String
(Project
.Library_Name
));
1182 -- Add the directory to table Library_Paths, to be processed later
1183 -- if library is not static and if Path_Option is not null.
1185 if Project
.Library_Kind
/= Static
1186 and then Path_Option
/= null
1188 Library_Paths
.Increment_Last
;
1189 Library_Paths
.Table
(Library_Paths
.Last
) :=
1190 new String'(Get_Name_String (Project.Library_Dir.Name));
1193 end Set_Library_For;
1195 ---------------------------
1196 -- Test_If_Relative_Path --
1197 ---------------------------
1199 procedure Test_If_Relative_Path
1200 (Switch : in out String_Access;
1204 Makeutl.Test_If_Relative_Path
1205 (Switch, Parent, Including_Non_Switch => False, Including_RTS => True);
1206 end Test_If_Relative_Path;
1212 procedure Non_VMS_Usage is
1216 Put_Line ("List of available commands");
1219 for C in Command_List'Range loop
1220 if not Command_List (C).VMS_Only then
1221 if Targparm.AAMP_On_Target then
1227 Put (To_Lower (Command_List (C).Cname.all));
1230 -- Never call gnatstack with a prefix
1233 Put (Command_List (C).Unixcmd.all);
1235 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
1239 Sws : Argument_List_Access renames Command_List (C).Unixsws;
1242 for J in Sws'Range loop
1254 Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " &
1255 "accept project file switches -vPx, -Pprj and -Xnam=val");
1259 -------------------------------------
1260 -- Start of processing for GNATCmd --
1261 -------------------------------------
1271 Prj.Initialize (Project_Tree);
1274 Last_Switches.Set_Last (0);
1276 First_Switches.Init;
1277 First_Switches.Set_Last (0);
1279 Carg_Switches.Set_Last (0);
1280 Rules_Switches.Init;
1281 Rules_Switches.Set_Last (0);
1283 VMS_Conv.Initialize;
1285 -- Add the default search directories, to be able to find system.ads in the
1286 -- subsequent call to Targparm.Get_Target_Parameters.
1288 Add_Default_Search_Dirs;
1290 -- Get target parameters so that AAMP_On_Target will be set, for testing in
1291 -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
1293 Targparm.Get_Target_Parameters;
1295 -- Add the directory where the GNAT driver is invoked in front of the path,
1296 -- if the GNAT driver is invoked with directory information. Do not do this
1297 -- for VMS, where the notion of path does not really exist.
1301 Command : constant String := Command_Name;
1304 for Index in reverse Command'Range loop
1305 if Command (Index) = Directory_Separator then
1307 Absolute_Dir : constant String :=
1309 (Command (Command'First .. Index));
1311 PATH : constant String :=
1312 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1315 Setenv ("PATH", PATH);
1324 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1325 -- filenames and pathnames to Unix style.
1328 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1330 VMS_Conversion (The_Command);
1332 B_Start := new String'("b__");
1334 -- If not on VMS, scan the command line directly
1337 if Argument_Count
= 0 then
1343 if Argument_Count
> Command_Arg
1344 and then Argument
(Command_Arg
) = "-v"
1346 Verbose_Mode
:= True;
1347 Command_Arg
:= Command_Arg
+ 1;
1349 elsif Argument_Count
> Command_Arg
1350 and then Argument
(Command_Arg
) = "-dn"
1352 Keep_Temporary_Files
:= True;
1353 Command_Arg
:= Command_Arg
+ 1;
1360 The_Command
:= Real_Command_Type
'Value (Argument
(Command_Arg
));
1362 if Command_List
(The_Command
).VMS_Only
then
1366 & Command_List
(The_Command
).Cname
.all
1367 & """ can only be used on VMS");
1371 when Constraint_Error
=>
1373 -- Check if it is an alternate command
1376 Alternate
: Alternate_Command
;
1379 Alternate
:= Alternate_Command
'Value
1380 (Argument
(Command_Arg
));
1381 The_Command
:= Corresponding_To
(Alternate
);
1384 when Constraint_Error
=>
1386 Fail
("Unknown command: " & Argument
(Command_Arg
));
1390 -- Get the arguments from the command line and from the eventual
1391 -- argument file(s) specified on the command line.
1393 for Arg
in Command_Arg
+ 1 .. Argument_Count
loop
1395 The_Arg
: constant String := Argument
(Arg
);
1398 -- Check if an argument file is specified
1400 if The_Arg
(The_Arg
'First) = '@' then
1402 Arg_File
: Ada
.Text_IO
.File_Type
;
1403 Line
: String (1 .. 256);
1407 -- Open the file and fail if the file cannot be found
1412 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1417 (Standard_Error
, "Cannot open argument file """);
1420 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1422 Put_Line
(Standard_Error
, """");
1426 -- Read line by line and put the content of each non-
1427 -- empty line in the Last_Switches table.
1429 while not End_Of_File
(Arg_File
) loop
1430 Get_Line
(Arg_File
, Line
, Last
);
1433 Last_Switches
.Increment_Last
;
1434 Last_Switches
.Table
(Last_Switches
.Last
) :=
1435 new String'(Line (1 .. Last));
1443 -- It is not an argument file; just put the argument in
1444 -- the Last_Switches table.
1446 Last_Switches.Increment_Last;
1447 Last_Switches.Table (Last_Switches.Last) :=
1448 new String'(The_Arg
);
1456 Program
: String_Access
;
1457 Exec_Path
: String_Access
;
1460 if The_Command
= Stack
then
1462 -- Never call gnatstack with a prefix
1464 Program
:= new String'(Command_List (The_Command).Unixcmd.all);
1468 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1471 -- Locate the executable for the command
1473 Exec_Path := Locate_Exec_On_Path (Program.all);
1475 if Exec_Path = null then
1476 Put_Line (Standard_Error, "could not locate " & Program.all);
1480 -- If there are switches for the executable, put them as first switches
1482 if Command_List (The_Command).Unixsws /= null then
1483 for J in Command_List (The_Command).Unixsws'Range loop
1484 First_Switches.Increment_Last;
1485 First_Switches.Table (First_Switches.Last) :=
1486 Command_List (The_Command).Unixsws (J);
1490 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1491 -- SYNC and XREF, look for project file related switches.
1495 Tool_Package_Name := Name_Binder;
1496 Packages_To_Check := Packages_To_Check_By_Binder;
1498 Tool_Package_Name := Name_Check;
1499 Packages_To_Check := Packages_To_Check_By_Check;
1501 Tool_Package_Name := Name_Eliminate;
1502 Packages_To_Check := Packages_To_Check_By_Eliminate;
1504 Tool_Package_Name := Name_Finder;
1505 Packages_To_Check := Packages_To_Check_By_Finder;
1507 Tool_Package_Name := Name_Linker;
1508 Packages_To_Check := Packages_To_Check_By_Linker;
1510 Tool_Package_Name := Name_Gnatls;
1511 Packages_To_Check := Packages_To_Check_By_Gnatls;
1513 Tool_Package_Name := Name_Metrics;
1514 Packages_To_Check := Packages_To_Check_By_Metric;
1516 Tool_Package_Name := Name_Pretty_Printer;
1517 Packages_To_Check := Packages_To_Check_By_Pretty;
1519 Tool_Package_Name := Name_Stack;
1520 Packages_To_Check := Packages_To_Check_By_Stack;
1522 Tool_Package_Name := Name_Gnatstub;
1523 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1525 Tool_Package_Name := Name_Synchronize;
1526 Packages_To_Check := Packages_To_Check_By_Sync;
1528 Tool_Package_Name := Name_Cross_Reference;
1529 Packages_To_Check := Packages_To_Check_By_Xref;
1531 Tool_Package_Name := No_Name;
1534 if Tool_Package_Name /= No_Name then
1536 -- Check that the switches are consistent. Detect project file
1537 -- related switches.
1539 Inspect_Switches : declare
1540 Arg_Num : Positive := 1;
1541 Argv : String_Access;
1543 procedure Remove_Switch (Num : Positive);
1544 -- Remove a project related switch from table Last_Switches
1550 procedure Remove_Switch (Num : Positive) is
1552 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1553 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1554 Last_Switches.Decrement_Last;
1557 -- Start of processing for Inspect_Switches
1560 while Arg_Num <= Last_Switches.Last loop
1561 Argv := Last_Switches.Table (Arg_Num);
1563 if Argv (Argv'First) = '-' then
1564 if Argv'Length = 1 then
1566 ("switch character cannot be followed by a blank");
1569 -- The two style project files (-p and -P) cannot be used
1572 if (The_Command = Find or else The_Command = Xref)
1573 and then Argv (2) = 'p
'
1575 Old_Project_File_Used := True;
1576 if Project_File /= null then
1577 Fail ("-P and -p cannot be used together");
1581 -- --subdirs=... Specify Subdirs
1583 if Argv'Length > Makeutl.Subdirs_Option'Length and then
1586 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1587 Makeutl.Subdirs_Option
1592 (Argv
'First + Makeutl
.Subdirs_Option
'Length ..
1595 Remove_Switch
(Arg_Num
);
1597 -- -aPdir Add dir to the project search path
1599 elsif Argv
'Length > 3
1600 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "aP"
1602 Add_Search_Project_Directory
1603 (Argv
(Argv
'First + 3 .. Argv
'Last));
1605 Remove_Switch
(Arg_Num
);
1607 -- -eL Follow links for files
1609 elsif Argv
.all = "-eL" then
1610 Follow_Links_For_Files
:= True;
1612 Remove_Switch
(Arg_Num
);
1614 -- -vPx Specify verbosity while parsing project files
1616 elsif Argv
'Length = 4
1617 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "vP"
1619 case Argv
(Argv
'Last) is
1621 Current_Verbosity
:= Prj
.Default
;
1623 Current_Verbosity
:= Prj
.Medium
;
1625 Current_Verbosity
:= Prj
.High
;
1627 Fail
("Invalid switch: " & Argv
.all);
1630 Remove_Switch
(Arg_Num
);
1632 -- -Pproject_file Specify project file to be used
1634 elsif Argv
(Argv
'First + 1) = 'P' then
1636 -- Only one -P switch can be used
1638 if Project_File
/= null then
1641 & ": second project file forbidden (first is """
1645 -- The two style project files (-p and -P) cannot be
1648 elsif Old_Project_File_Used
then
1649 Fail
("-p and -P cannot be used together");
1651 elsif Argv
'Length = 2 then
1653 -- There is space between -P and the project file
1654 -- name. -P cannot be the last option.
1656 if Arg_Num
= Last_Switches
.Last
then
1657 Fail
("project file name missing after -P");
1660 Remove_Switch
(Arg_Num
);
1661 Argv
:= Last_Switches
.Table
(Arg_Num
);
1663 -- After -P, there must be a project file name,
1664 -- not another switch.
1666 if Argv
(Argv
'First) = '-' then
1667 Fail
("project file name missing after -P");
1670 Project_File
:= new String'(Argv.all);
1675 -- No space between -P and project file name
1678 new String'(Argv
(Argv
'First + 2 .. Argv
'Last));
1681 Remove_Switch
(Arg_Num
);
1683 -- -Xexternal=value Specify an external reference to be
1684 -- used in project files
1686 elsif Argv
'Length >= 5
1687 and then Argv
(Argv
'First + 1) = 'X'
1690 Equal_Pos
: constant Natural :=
1693 Argv
(Argv
'First + 2 .. Argv
'Last));
1695 if Equal_Pos
>= Argv
'First + 3 and then
1696 Equal_Pos
/= Argv
'Last then
1697 Add
(External_Name
=>
1698 Argv
(Argv
'First + 2 .. Equal_Pos
- 1),
1699 Value
=> Argv
(Equal_Pos
+ 1 .. Argv
'Last));
1703 & " is not a valid external assignment.");
1707 Remove_Switch
(Arg_Num
);
1710 (The_Command
= Check
or else
1711 The_Command
= Sync
or else
1712 The_Command
= Pretty
or else
1713 The_Command
= Metric
or else
1714 The_Command
= Stack
or else
1716 and then Argv
'Length = 2
1717 and then Argv
(2) = 'U'
1719 All_Projects
:= True;
1720 Remove_Switch
(Arg_Num
);
1723 Arg_Num
:= Arg_Num
+ 1;
1726 elsif ((The_Command
= Check
and then Argv
(Argv
'First) /= '+')
1727 or else The_Command
= Sync
1728 or else The_Command
= Metric
1729 or else The_Command
= Pretty
)
1730 and then Project_File
/= null
1731 and then All_Projects
1733 if ASIS_Main
/= null then
1734 Fail
("cannot specify more than one main after -U");
1737 Remove_Switch
(Arg_Num
);
1741 Arg_Num
:= Arg_Num
+ 1;
1744 end Inspect_Switches
;
1747 -- If there is a project file specified, parse it, get the switches
1748 -- for the tool and setup PATH environment variables.
1750 if Project_File
/= null then
1751 Prj
.Pars
.Set_Verbosity
(To
=> Current_Verbosity
);
1754 (Project
=> Project
,
1755 In_Tree
=> Project_Tree
,
1756 Project_File_Name
=> Project_File
.all,
1757 Flags
=> Gnatmake_Flags
,
1758 Packages_To_Check
=> Packages_To_Check
);
1760 if Project
= Prj
.No_Project
then
1761 Fail
("""" & Project_File
.all & """ processing failed");
1764 -- Check if a package with the name of the tool is in the project
1765 -- file and if there is one, get the switches, if any, and scan them.
1768 Pkg
: constant Prj
.Package_Id
:=
1770 (Name
=> Tool_Package_Name
,
1771 In_Packages
=> Project
.Decl
.Packages
,
1772 In_Tree
=> Project_Tree
);
1774 Element
: Package_Element
;
1776 Default_Switches_Array
: Array_Element_Id
;
1778 The_Switches
: Prj
.Variable_Value
;
1779 Current
: Prj
.String_List_Id
;
1780 The_String
: String_Element
;
1783 if Pkg
/= No_Package
then
1784 Element
:= Project_Tree
.Packages
.Table
(Pkg
);
1786 -- Packages Gnatls and Gnatstack have a single attribute
1787 -- Switches, that is not an associative array.
1789 if The_Command
= List
or else The_Command
= Stack
then
1792 (Variable_Name
=> Snames
.Name_Switches
,
1793 In_Variables
=> Element
.Decl
.Attributes
,
1794 In_Tree
=> Project_Tree
);
1796 -- Packages Binder (for gnatbind), Cross_Reference (for
1797 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1798 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1799 -- (for gnatcheck), and Metric (for gnatmetric) have an
1800 -- attributed Switches, an associative array, indexed by the
1801 -- name of the file.
1803 -- They also have an attribute Default_Switches, indexed by the
1804 -- name of the programming language.
1807 if The_Switches
.Kind
= Prj
.Undefined
then
1808 Default_Switches_Array
:=
1810 (Name
=> Name_Default_Switches
,
1811 In_Arrays
=> Element
.Decl
.Arrays
,
1812 In_Tree
=> Project_Tree
);
1813 The_Switches
:= Prj
.Util
.Value_Of
1816 In_Array
=> Default_Switches_Array
,
1817 In_Tree
=> Project_Tree
);
1821 -- If there are switches specified in the package of the
1822 -- project file corresponding to the tool, scan them.
1824 case The_Switches
.Kind
is
1825 when Prj
.Undefined
=>
1830 Switch
: constant String :=
1831 Get_Name_String
(The_Switches
.Value
);
1834 if Switch
'Length > 0 then
1835 First_Switches
.Increment_Last
;
1836 First_Switches
.Table
(First_Switches
.Last
) :=
1837 new String'(Switch);
1842 Current := The_Switches.Values;
1843 while Current /= Prj.Nil_String loop
1844 The_String := Project_Tree.String_Elements.
1848 Switch : constant String :=
1849 Get_Name_String (The_String.Value);
1852 if Switch'Length > 0 then
1853 First_Switches.Increment_Last;
1854 First_Switches.Table (First_Switches.Last) :=
1855 new String'(Switch
);
1859 Current
:= The_String
.Next
;
1865 if The_Command
= Bind
1866 or else The_Command
= Link
1867 or else The_Command
= Elim
1869 Change_Dir
(Get_Name_String
(Project
.Object_Directory
.Name
));
1872 -- Set up the env vars for project path files
1874 Prj
.Env
.Set_Ada_Paths
1875 (Project
, Project_Tree
, Including_Libraries
=> False);
1877 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
1878 -- a configuration pragmas file, if necessary.
1880 if The_Command
= Pretty
1881 or else The_Command
= Metric
1882 or else The_Command
= Stub
1883 or else The_Command
= Elim
1884 or else The_Command
= Check
1885 or else The_Command
= Sync
1887 -- If there are switches in package Compiler, put them in the
1888 -- Carg_Switches table.
1891 Pkg
: constant Prj
.Package_Id
:=
1893 (Name
=> Name_Compiler
,
1894 In_Packages
=> Project
.Decl
.Packages
,
1895 In_Tree
=> Project_Tree
);
1897 Element
: Package_Element
;
1899 Switches_Array
: Array_Element_Id
;
1901 The_Switches
: Prj
.Variable_Value
;
1902 Current
: Prj
.String_List_Id
;
1903 The_String
: String_Element
;
1905 Main
: String_Access
:= null;
1909 if Pkg
/= No_Package
then
1911 -- First, check if there is a single main specified.
1913 for J
in 1 .. Last_Switches
.Last
loop
1914 if Last_Switches
.Table
(J
) (1) /= '-' then
1916 Main
:= Last_Switches
.Table
(J
);
1925 Element
:= Project_Tree
.Packages
.Table
(Pkg
);
1927 -- If there is a single main and there is compilation
1928 -- switches specified in the project file, use them.
1930 if Main
/= null and then not All_Projects
then
1931 Name_Len
:= Main
'Length;
1932 Name_Buffer
(1 .. Name_Len
) := Main
.all;
1933 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1934 Main_Id
:= Name_Find
;
1938 (Name
=> Name_Switches
,
1939 In_Arrays
=> Element
.Decl
.Arrays
,
1940 In_Tree
=> Project_Tree
);
1941 The_Switches
:= Prj
.Util
.Value_Of
1944 In_Array
=> Switches_Array
,
1945 In_Tree
=> Project_Tree
);
1948 -- Otherwise, get the Default_Switches ("Ada")
1950 if The_Switches
.Kind
= Undefined
then
1953 (Name
=> Name_Default_Switches
,
1954 In_Arrays
=> Element
.Decl
.Arrays
,
1955 In_Tree
=> Project_Tree
);
1956 The_Switches
:= Prj
.Util
.Value_Of
1959 In_Array
=> Switches_Array
,
1960 In_Tree
=> Project_Tree
);
1963 -- If there are switches specified, put them in the
1964 -- Carg_Switches table.
1966 case The_Switches
.Kind
is
1967 when Prj
.Undefined
=>
1972 Switch
: constant String :=
1973 Get_Name_String
(The_Switches
.Value
);
1975 if Switch
'Length > 0 then
1976 Add_To_Carg_Switches
(new String'(Switch));
1981 Current := The_Switches.Values;
1982 while Current /= Prj.Nil_String loop
1984 Project_Tree.String_Elements.Table (Current);
1987 Switch : constant String :=
1988 Get_Name_String (The_String.Value);
1990 if Switch'Length > 0 then
1991 Add_To_Carg_Switches (new String'(Switch
));
1995 Current
:= The_String
.Next
;
2001 -- If -cargs is one of the switches, move the following switches
2002 -- to the Carg_Switches table.
2004 for J
in 1 .. First_Switches
.Last
loop
2005 if First_Switches
.Table
(J
).all = "-cargs" then
2011 -- Move the switches that are before -rules when the
2012 -- command is CHECK.
2015 while K
<= First_Switches
.Last
2017 (The_Command
/= Check
2018 or else First_Switches
.Table
(K
).all /= "-rules")
2020 Add_To_Carg_Switches
(First_Switches
.Table
(K
));
2024 if K
> First_Switches
.Last
then
2025 First_Switches
.Set_Last
(J
- 1);
2029 while K
<= First_Switches
.Last
loop
2031 First_Switches
.Table
(Last
) :=
2032 First_Switches
.Table
(K
);
2036 First_Switches
.Set_Last
(Last
);
2044 for J
in 1 .. Last_Switches
.Last
loop
2045 if Last_Switches
.Table
(J
).all = "-cargs" then
2051 -- Move the switches that are before -rules when the
2052 -- command is CHECK.
2055 while K
<= Last_Switches
.Last
2057 (The_Command
/= Check
2059 Last_Switches
.Table
(K
).all /= "-rules")
2061 Add_To_Carg_Switches
(Last_Switches
.Table
(K
));
2065 if K
> Last_Switches
.Last
then
2066 Last_Switches
.Set_Last
(J
- 1);
2070 while K
<= Last_Switches
.Last
loop
2072 Last_Switches
.Table
(Last
) :=
2073 Last_Switches
.Table
(K
);
2077 Last_Switches
.Set_Last
(Last
);
2086 CP_File
: constant Path_Name_Type
:= Configuration_Pragmas_File
;
2089 if CP_File
/= No_Path
then
2090 if The_Command
= Elim
then
2091 First_Switches
.Increment_Last
;
2092 First_Switches
.Table
(First_Switches
.Last
) :=
2093 new String'("-C" & Get_Name_String (CP_File));
2096 Add_To_Carg_Switches
2097 (new String'("-gnatec=" & Get_Name_String
(CP_File
)));
2103 if The_Command
= Link
then
2107 if The_Command
= Link
or else The_Command
= Bind
then
2109 -- For files that are specified as relative paths with directory
2110 -- information, we convert them to absolute paths, with parent
2111 -- being the current working directory if specified on the command
2112 -- line and the project directory if specified in the project
2113 -- file. This is what gnatmake is doing for linker and binder
2116 for J
in 1 .. Last_Switches
.Last
loop
2117 Test_If_Relative_Path
2118 (Last_Switches
.Table
(J
), Current_Work_Dir
);
2121 Get_Name_String
(Project
.Directory
.Name
);
2124 Project_Dir
: constant String := Name_Buffer
(1 .. Name_Len
);
2126 for J
in 1 .. First_Switches
.Last
loop
2127 Test_If_Relative_Path
2128 (First_Switches
.Table
(J
), Project_Dir
);
2132 elsif The_Command
= Stub
then
2134 File_Index
: Integer := 0;
2135 Dir_Index
: Integer := 0;
2136 Last
: constant Integer := Last_Switches
.Last
;
2137 Lang
: constant Language_Ptr
:=
2138 Get_Language_From_Name
(Project
, "ada");
2141 for Index
in 1 .. Last
loop
2142 if Last_Switches
.Table
(Index
)
2143 (Last_Switches
.Table
(Index
)'First) /= '-'
2145 File_Index
:= Index
;
2150 -- If the project file naming scheme is not standard, and if
2151 -- the file name ends with the spec suffix, then indicate to
2152 -- gnatstub the name of the body file with a -o switch.
2154 if not Is_Standard_GNAT_Naming
(Lang
.Config
.Naming_Data
) then
2155 if File_Index
/= 0 then
2157 Spec
: constant String :=
2159 (Last_Switches
.Table
(File_Index
).all);
2160 Last
: Natural := Spec
'Last;
2163 Get_Name_String
(Lang
.Config
.Naming_Data
.Spec_Suffix
);
2165 if Spec
'Length > Name_Len
2166 and then Spec
(Last
- Name_Len
+ 1 .. Last
) =
2167 Name_Buffer
(1 .. Name_Len
)
2169 Last
:= Last
- Name_Len
;
2171 (Lang
.Config
.Naming_Data
.Body_Suffix
);
2172 Last_Switches
.Increment_Last
;
2173 Last_Switches
.Table
(Last_Switches
.Last
) :=
2175 Last_Switches.Increment_Last;
2176 Last_Switches.Table (Last_Switches.Last) :=
2177 new String'(Spec
(Spec
'First .. Last
) &
2178 Name_Buffer
(1 .. Name_Len
));
2184 -- Add the directory of the spec as the destination directory
2185 -- of the body, if there is no destination directory already
2188 if File_Index
/= 0 then
2189 for Index
in File_Index
+ 1 .. Last
loop
2190 if Last_Switches
.Table
(Index
)
2191 (Last_Switches
.Table
(Index
)'First) /= '-'
2198 if Dir_Index
= 0 then
2199 Last_Switches
.Increment_Last
;
2200 Last_Switches
.Table
(Last_Switches
.Last
) :=
2202 (Dir_Name (Last_Switches.Table (File_Index).all));
2208 -- For gnatmetric, the generated files should be put in the object
2209 -- directory. This must be the first switch, because it may be
2210 -- overridden by a switch in package Metrics in the project file or
2211 -- by a command line option. Note that we don't add the -d= switch
2212 -- if there is no object directory available.
2214 if The_Command = Metric
2215 and then Project.Object_Directory /= No_Path_Information
2217 First_Switches.Increment_Last;
2218 First_Switches.Table (2 .. First_Switches.Last) :=
2219 First_Switches.Table (1 .. First_Switches.Last - 1);
2220 First_Switches.Table (1) :=
2222 Get_Name_String
(Project
.Object_Directory
.Name
));
2225 -- For gnat check, -rules and the following switches need to be the
2226 -- last options, so move all these switches to table Rules_Switches.
2228 if The_Command
= Check
then
2231 -- Set to rank of options preceding "-rules"
2233 In_Rules_Switches
: Boolean;
2234 -- Set to True when options "-rules" is found
2237 New_Last
:= First_Switches
.Last
;
2238 In_Rules_Switches
:= False;
2240 for J
in 1 .. First_Switches
.Last
loop
2241 if In_Rules_Switches
then
2242 Add_To_Rules_Switches
(First_Switches
.Table
(J
));
2244 elsif First_Switches
.Table
(J
).all = "-rules" then
2246 In_Rules_Switches
:= True;
2250 if In_Rules_Switches
then
2251 First_Switches
.Set_Last
(New_Last
);
2254 New_Last
:= Last_Switches
.Last
;
2255 In_Rules_Switches
:= False;
2257 for J
in 1 .. Last_Switches
.Last
loop
2258 if In_Rules_Switches
then
2259 Add_To_Rules_Switches
(Last_Switches
.Table
(J
));
2261 elsif Last_Switches
.Table
(J
).all = "-rules" then
2263 In_Rules_Switches
:= True;
2267 if In_Rules_Switches
then
2268 Last_Switches
.Set_Last
(New_Last
);
2273 -- For gnat check, sync, metric or pretty with -U + a main, get the
2274 -- list of sources from the closure and add them to the arguments.
2276 if ASIS_Main
/= null then
2279 -- On VMS, set up the env var again for source dirs file. This is
2280 -- because the call to gnatmake has set this env var to another
2281 -- file that has now been deleted.
2283 if Hostparm
.OpenVMS
then
2285 -- First make sure that the recorded file names are empty
2287 Prj
.Env
.Initialize
(Project_Tree
);
2289 Prj
.Env
.Set_Ada_Paths
2290 (Project
, Project_Tree
, Including_Libraries
=> False);
2293 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2294 -- and gnat stack, if no file has been put on the command line, call
2295 -- tool with all the sources of the main project.
2297 elsif The_Command
= Check
or else
2298 The_Command
= Sync
or else
2299 The_Command
= Pretty
or else
2300 The_Command
= Metric
or else
2301 The_Command
= List
or else
2308 -- Gather all the arguments and invoke the executable
2311 The_Args
: Argument_List
2312 (1 .. First_Switches
.Last
+
2313 Last_Switches
.Last
+
2314 Carg_Switches
.Last
+
2315 Rules_Switches
.Last
);
2316 Arg_Num
: Natural := 0;
2319 for J
in 1 .. First_Switches
.Last
loop
2320 Arg_Num
:= Arg_Num
+ 1;
2321 The_Args
(Arg_Num
) := First_Switches
.Table
(J
);
2324 for J
in 1 .. Last_Switches
.Last
loop
2325 Arg_Num
:= Arg_Num
+ 1;
2326 The_Args
(Arg_Num
) := Last_Switches
.Table
(J
);
2329 for J
in 1 .. Carg_Switches
.Last
loop
2330 Arg_Num
:= Arg_Num
+ 1;
2331 The_Args
(Arg_Num
) := Carg_Switches
.Table
(J
);
2334 for J
in 1 .. Rules_Switches
.Last
loop
2335 Arg_Num
:= Arg_Num
+ 1;
2336 The_Args
(Arg_Num
) := Rules_Switches
.Table
(J
);
2339 -- If Display_Command is on, only display the generated command
2341 if Display_Command
then
2342 Put
(Standard_Error
, "generated command -->");
2343 Put
(Standard_Error
, Exec_Path
.all);
2345 for Arg
in The_Args
'Range loop
2346 Put
(Standard_Error
, " ");
2347 Put
(Standard_Error
, The_Args
(Arg
).all);
2350 Put
(Standard_Error
, "<--");
2351 New_Line
(Standard_Error
);
2355 if Verbose_Mode
then
2356 Output
.Write_Str
(Exec_Path
.all);
2358 for Arg
in The_Args
'Range loop
2359 Output
.Write_Char
(' ');
2360 Output
.Write_Str
(The_Args
(Arg
).all);
2367 Exit_Status
(Spawn
(Exec_Path
.all, The_Args
));
2374 if not Keep_Temporary_Files
then
2375 Prj
.Delete_All_Temp_Files
(Project_Tree
);
2376 Delete_Temp_Config_Files
;
2379 Set_Exit_Status
(Failure
);
2382 if not Keep_Temporary_Files
then
2383 Prj
.Delete_All_Temp_Files
(Project_Tree
);
2384 Delete_Temp_Config_Files
;
2387 -- Since GNATCmd is normally called from DCL (the VMS shell), it must
2388 -- return an understandable VMS exit status. However the exit status
2389 -- returned *to* GNATCmd is a Posix style code, so we test it and return
2390 -- just a simple success or failure on VMS.
2392 if Hostparm
.OpenVMS
and then My_Exit_Status
/= Success
then
2393 Set_Exit_Status
(Failure
);
2395 Set_Exit_Status
(My_Exit_Status
);