1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2013, 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
;
29 with Hostparm
; use Hostparm
;
30 with Makeutl
; use Makeutl
;
31 with MLib
.Tgt
; use MLib
.Tgt
;
34 with Namet
; use Namet
;
36 with Osint
; use Osint
;
37 with Output
; use Output
;
40 with Prj
.Ext
; use Prj
.Ext
;
42 with Prj
.Tree
; use Prj
.Tree
;
43 with Prj
.Util
; use Prj
.Util
;
46 with Snames
; use Snames
;
51 with Types
; use Types
;
52 with VMS_Conv
; use VMS_Conv
;
53 with VMS_Cmds
; use VMS_Cmds
;
55 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
56 with Ada
.Command_Line
; use Ada
.Command_Line
;
57 with Ada
.Text_IO
; use Ada
.Text_IO
;
59 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
62 Project_Node_Tree
: Project_Node_Tree_Ref
;
63 Project_File
: String_Access
;
64 Project
: Prj
.Project_Id
;
65 Current_Verbosity
: Prj
.Verbosity
:= Prj
.Default
;
66 Tool_Package_Name
: Name_Id
:= No_Name
;
68 B_Start
: String_Ptr
:= new String'("b~");
69 -- Prefix of binder generated file, changed to b__ for VMS
71 Project_Tree : constant Project_Tree_Ref :=
72 new Project_Tree_Data (Is_Root_Tree => True);
75 Old_Project_File_Used : Boolean := False;
76 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
77 -- an old fashioned project file. -p cannot be used in conjunction
80 Temp_File_Name : Path_Name_Type := No_Path;
81 -- The name of the temporary text file to put a list of source/object
82 -- files to pass to a tool.
84 ASIS_Main : String_Access := null;
85 -- Main for commands Check, Metric and Pretty, when -U is used
87 package First_Switches is new Table.Table
88 (Table_Component_Type => String_Access,
89 Table_Index_Type => Integer,
92 Table_Increment => 100,
93 Table_Name => "Gnatcmd.First_Switches");
94 -- A table to keep the switches from the project file
96 package Carg_Switches is new Table.Table
97 (Table_Component_Type => String_Access,
98 Table_Index_Type => Integer,
101 Table_Increment => 100,
102 Table_Name => "Gnatcmd.Carg_Switches");
103 -- A table to keep the switches following -cargs for ASIS tools
105 package Rules_Switches is new Table.Table
106 (Table_Component_Type => String_Access,
107 Table_Index_Type => Integer,
108 Table_Low_Bound => 1,
110 Table_Increment => 100,
111 Table_Name => "Gnatcmd.Rules_Switches");
112 -- A table to keep the switches following -rules for gnatcheck
114 package Library_Paths is new Table.Table (
115 Table_Component_Type => String_Access,
116 Table_Index_Type => Integer,
117 Table_Low_Bound => 1,
119 Table_Increment => 100,
120 Table_Name => "Make.Library_Path");
122 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
123 -- tool. We allocate objects because we cannot declare aliased objects
124 -- as we are in a procedure, not a library level package.
126 subtype SA is String_Access;
128 Naming_String : constant SA := new String'("naming");
129 Binder_String
: constant SA
:= new String'("binder");
130 Builder_String : constant SA := new String'("builder");
131 Compiler_String
: constant SA
:= new String'("compiler");
132 Check_String : constant SA := new String'("check");
133 Synchronize_String
: constant SA
:= new String'("synchronize");
134 Eliminate_String : constant SA := new String'("eliminate");
135 Finder_String
: constant SA
:= new String'("finder");
136 Linker_String : constant SA := new String'("linker");
137 Gnatls_String
: constant SA
:= new String'("gnatls");
138 Pretty_String : constant SA := new String'("pretty_printer");
139 Stack_String
: constant SA
:= new String'("stack");
140 Gnatstub_String : constant SA := new String'("gnatstub");
141 Metric_String
: constant SA
:= new String'("metrics");
142 Xref_String : constant SA := new String'("cross_reference");
144 Packages_To_Check_By_Binder
: constant String_List_Access
:=
145 new String_List
'((Naming_String, Binder_String));
147 Packages_To_Check_By_Check : constant String_List_Access :=
149 ((Naming_String
, Builder_String
, Check_String
, Compiler_String
));
151 Packages_To_Check_By_Sync
: constant String_List_Access
:=
152 new String_List
'((Naming_String, Synchronize_String, Compiler_String));
154 Packages_To_Check_By_Eliminate : constant String_List_Access :=
155 new String_List'((Naming_String
, Eliminate_String
, Compiler_String
));
157 Packages_To_Check_By_Finder
: constant String_List_Access
:=
158 new String_List
'((Naming_String, Finder_String));
160 Packages_To_Check_By_Linker : constant String_List_Access :=
161 new String_List'((Naming_String
, Linker_String
));
163 Packages_To_Check_By_Gnatls
: constant String_List_Access
:=
164 new String_List
'((Naming_String, Gnatls_String));
166 Packages_To_Check_By_Pretty : constant String_List_Access :=
167 new String_List'((Naming_String
, Pretty_String
, Compiler_String
));
169 Packages_To_Check_By_Stack
: constant String_List_Access
:=
170 new String_List
'((Naming_String, Stack_String));
172 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
173 new String_List'((Naming_String
, Gnatstub_String
, Compiler_String
));
175 Packages_To_Check_By_Metric
: constant String_List_Access
:=
176 new String_List
'((Naming_String, Metric_String, Compiler_String));
178 Packages_To_Check_By_Xref : constant String_List_Access :=
179 new String_List'((Naming_String
, Xref_String
));
181 Packages_To_Check
: String_List_Access
:= Prj
.All_Packages
;
183 ----------------------------------
184 -- Declarations for GNATCMD use --
185 ----------------------------------
187 The_Command
: Command_Type
;
188 -- The command specified in the invocation of the GNAT driver
190 Command_Arg
: Positive := 1;
191 -- The index of the command in the arguments of the GNAT driver
193 My_Exit_Status
: Exit_Status
:= Success
;
194 -- The exit status of the spawned tool. Used to set the correct VMS
197 Current_Work_Dir
: constant String := Get_Current_Dir
;
198 -- The path of the working directory
200 All_Projects
: Boolean := False;
201 -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
202 -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
203 -- should be invoked for all sources of all projects.
205 Max_OpenVMS_Logical_Length
: constant Integer := 255;
206 -- The maximum length of OpenVMS logicals
208 -----------------------
209 -- Local Subprograms --
210 -----------------------
212 procedure Add_To_Carg_Switches
(Switch
: String_Access
);
213 -- Add a switch to the Carg_Switches table. If it is the first one, put the
214 -- switch "-cargs" at the beginning of the table.
216 procedure Add_To_Rules_Switches
(Switch
: String_Access
);
217 -- Add a switch to the Rules_Switches table. If it is the first one, put
218 -- the switch "-crules" at the beginning of the table.
220 procedure Check_Files
;
221 -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
222 -- project file is specified, without any file arguments and without a
223 -- switch -files=. If it is the case, invoke the GNAT tool with the proper
224 -- list of files, derived from the sources of the project.
226 function Check_Project
227 (Project
: Project_Id
;
228 Root_Project
: Project_Id
) return Boolean;
229 -- Returns True if Project = Root_Project or if we want to consider all
230 -- sources of all projects. For GNAT METRIC, also returns True if Project
231 -- is extended by Root_Project.
233 procedure Check_Relative_Executable
(Name
: in out String_Access
);
234 -- Check if an executable is specified as a relative path. If it is, and
235 -- the path contains directory information, fail. Otherwise, prepend the
236 -- exec directory. This procedure is only used for GNAT LINK when a project
237 -- file is specified.
239 function Configuration_Pragmas_File
return Path_Name_Type
;
240 -- Return an argument, if there is a configuration pragmas file to be
241 -- specified for Project, otherwise return No_Name. Used for gnatstub
242 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
245 procedure Delete_Temp_Config_Files
;
246 -- Delete all temporary config files. The caller is responsible for
247 -- ensuring that Keep_Temporary_Files is False.
249 procedure Ensure_Absolute_Path
250 (Switch
: in out String_Access
;
252 -- Test if Switch is a relative search path switch. If it is and it
253 -- includes directory information, prepend the path with Parent. This
254 -- subprogram is only called when using project files.
256 procedure Get_Closure
;
257 -- Get the sources in the closure of the ASIS_Main and add them to the
258 -- list of arguments.
260 function Mapping_File
return Path_Name_Type
;
261 -- Create and return the path name of a mapping file. Used for gnatstub
262 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
265 procedure Non_VMS_Usage
;
266 -- Display usage for platforms other than VMS
268 procedure Process_Link
;
269 -- Process GNAT LINK, when there is a project file specified
271 procedure Set_Library_For
272 (Project
: Project_Id
;
273 Tree
: Project_Tree_Ref
;
274 Libraries_Present
: in out Boolean);
275 -- If Project is a library project, add the correct -L and -l switches to
276 -- the linker invocation.
278 procedure Set_Libraries
is new
279 For_Every_Project_Imported
(Boolean, Set_Library_For
);
280 -- Add the -L and -l switches to the linker for all the library projects
282 --------------------------
283 -- Add_To_Carg_Switches --
284 --------------------------
286 procedure Add_To_Carg_Switches
(Switch
: String_Access
) is
288 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
290 if Carg_Switches
.Last
= 0 then
291 Carg_Switches
.Increment_Last
;
292 Carg_Switches
.Table
(Carg_Switches
.Last
) := new String'("-cargs");
295 Carg_Switches.Increment_Last;
296 Carg_Switches.Table (Carg_Switches.Last) := Switch;
297 end Add_To_Carg_Switches;
299 ---------------------------
300 -- Add_To_Rules_Switches --
301 ---------------------------
303 procedure Add_To_Rules_Switches (Switch : String_Access) is
305 -- If the Rules_Switches table is empty, put "-rules" at the beginning
307 if Rules_Switches.Last = 0 then
308 Rules_Switches.Increment_Last;
309 Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
312 Rules_Switches
.Increment_Last
;
313 Rules_Switches
.Table
(Rules_Switches
.Last
) := Switch
;
314 end Add_To_Rules_Switches
;
320 procedure Check_Files
is
321 Add_Sources
: Boolean := True;
322 Unit
: Prj
.Unit_Index
;
323 Subunit
: Boolean := False;
324 FD
: File_Descriptor
:= Invalid_FD
;
328 procedure Add_To_Response_File
330 Check_File
: Boolean := True);
331 -- Include the file name passed as parameter in the response file for
332 -- the tool being called. If the response file can not be written then
333 -- the file name is passed in the parameter list of the tool. If the
334 -- Check_File parameter is True then the procedure verifies the
335 -- existence of the file before adding it to the response file.
337 --------------------------
338 -- Add_To_Response_File --
339 --------------------------
341 procedure Add_To_Response_File
343 Check_File
: Boolean := True)
348 Add_Str_To_Name_Buffer
(File_Name
);
350 if not Check_File
or else
351 Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
353 if FD
/= Invalid_FD
then
354 Name_Len
:= Name_Len
+ 1;
355 Name_Buffer
(Name_Len
) := ASCII
.LF
;
357 Status
:= Write
(FD
, Name_Buffer
(1)'Address, Name_Len
);
359 if Status
/= Name_Len
then
360 Osint
.Fail
("disk full");
363 Last_Switches
.Increment_Last
;
364 Last_Switches
.Table
(Last_Switches
.Last
) :=
365 new String'(File_Name);
368 end Add_To_Response_File;
370 -- Start of processing for Check_Files
373 -- Check if there is at least one argument that is not a switch or if
374 -- there is a -files= switch.
376 for Index in 1 .. Last_Switches.Last loop
377 if Last_Switches.Table (Index).all'Length > 7
378 and then Last_Switches.Table (Index) (1 .. 7) = "-files="
380 Add_Sources := False;
383 elsif Last_Switches.Table (Index) (1) /= '-' then
387 and then Last_Switches.Table (Index - 1).all /= "-o")
389 (The_Command = Pretty
390 and then Last_Switches.Table (Index - 1).all /= "-o"
391 and then Last_Switches.Table (Index - 1).all /= "-of")
393 (The_Command = Metric
395 Last_Switches.Table (Index - 1).all /= "-o" and then
396 Last_Switches.Table (Index - 1).all /= "-og" and then
397 Last_Switches.Table (Index - 1).all /= "-ox" and then
398 Last_Switches.Table (Index - 1).all /= "-d")
400 (The_Command /= Check and then
401 The_Command /= Pretty and then
402 The_Command /= Metric)
404 Add_Sources := False;
410 -- If all arguments are switches and there is no switch -files=, add the
411 -- path names of all the sources of the main project.
415 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file and
416 -- put the list of sources in it. For gnatstack create a temporary
417 -- file with the list of .ci files.
419 if The_Command = Check or else
420 The_Command = Pretty or else
421 The_Command = Metric or else
422 The_Command = List or else
425 Tempdir.Create_Temp_File (FD, Temp_File_Name);
426 Last_Switches.Increment_Last;
427 Last_Switches.Table (Last_Switches.Last) :=
428 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
435 -- Gnatstack needs to add the .ci file for the binder generated
436 -- files corresponding to all of the library projects and main
437 -- units belonging to the application.
439 if The_Command
= Stack
then
440 Proj
:= Project_Tree
.Projects
;
441 while Proj
/= null loop
442 if Check_Project
(Proj
.Project
, Project
) then
444 Main
: String_List_Id
;
447 -- Include binder generated files for main programs
449 Main
:= Proj
.Project
.Mains
;
450 while Main
/= Nil_String
loop
453 (Proj
.Project
.Object_Directory
.Name
) &
457 (Project_Tree
.Shared
.String_Elements
.Table
461 -- When looking for the .ci file for a binder
462 -- generated file, look for both b~xxx and b__xxx
463 -- as gprbuild always uses b__ as the prefix of
466 if not Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
467 and then B_Start
.all /= "b__"
471 (Proj
.Project
.Object_Directory
.Name
) &
476 .String_Elements
.Table
(Main
).Value
),
480 Main
:= Project_Tree
.Shared
.String_Elements
.Table
484 if Proj
.Project
.Library
then
486 -- Include the .ci file for the binder generated
487 -- files that contains the initialization and
488 -- finalization of the library.
492 (Proj
.Project
.Object_Directory
.Name
) &
494 Get_Name_String
(Proj
.Project
.Library_Name
) &
497 -- When looking for the .ci file for a binder
498 -- generated file, look for both b~xxx and b__xxx
499 -- as gprbuild always uses b__ as the prefix of
502 if not Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
503 and then B_Start
.all /= "b__"
507 (Proj
.Project
.Object_Directory
.Name
) &
509 Get_Name_String
(Proj
.Project
.Library_Name
) &
520 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
521 while Unit
/= No_Unit_Index
loop
523 -- For gnatls, we only need to put the library units, body or
524 -- spec, but not the subunits.
526 if The_Command
= List
then
527 if Unit
.File_Names
(Impl
) /= null
528 and then not Unit
.File_Names
(Impl
).Locally_Removed
530 -- There is a body, check if it is for this project
533 or else Unit
.File_Names
(Impl
).Project
= Project
537 if Unit
.File_Names
(Spec
) = null
538 or else Unit
.File_Names
(Spec
).Locally_Removed
540 -- We have a body with no spec: we need to check if
541 -- this is a subunit, because gnatls will complain
545 Src_Ind
: constant Source_File_Index
:=
546 Sinput
.P
.Load_Project_File
552 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
559 (Unit
.File_Names
(Impl
).Display_File
),
560 Check_File
=> False);
564 elsif Unit
.File_Names
(Spec
) /= null
565 and then not Unit
.File_Names
(Spec
).Locally_Removed
567 -- We have a spec with no body. Check if it is for this
570 if All_Projects
or else
571 Unit
.File_Names
(Spec
).Project
= Project
575 (Unit
.File_Names
(Spec
).Display_File
),
576 Check_File
=> False);
580 -- For gnatstack, we put the .ci files corresponding to the
581 -- different units, including the binder generated files. We
582 -- only need to do that for the library units, body or spec,
583 -- but not the subunits.
585 elsif The_Command
= Stack
then
586 if Unit
.File_Names
(Impl
) /= null
587 and then not Unit
.File_Names
(Impl
).Locally_Removed
589 -- There is a body. Check if .ci files for this project
593 (Unit
.File_Names
(Impl
).Project
, Project
)
597 if Unit
.File_Names
(Spec
) = null
598 or else Unit
.File_Names
(Spec
).Locally_Removed
600 -- We have a body with no spec: we need to check
601 -- if this is a subunit, because .ci files are not
602 -- generated for subunits.
605 Src_Ind
: constant Source_File_Index
:=
606 Sinput
.P
.Load_Project_File
612 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
620 (Impl
).Project
. Object_Directory
.Name
) &
623 (Unit
.File_Names
(Impl
).Display_File
),
628 elsif Unit
.File_Names
(Spec
) /= null
629 and then not Unit
.File_Names
(Spec
).Locally_Removed
631 -- Spec with no body, check if it is for this project
634 (Unit
.File_Names
(Spec
).Project
, Project
)
639 (Spec
).Project
. Object_Directory
.Name
) &
642 (Get_Name_String
(Unit
.File_Names
(Spec
).File
),
648 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
649 -- sources of the project, or of all projects if -U was
652 for Kind
in Spec_Or_Body
loop
653 if Unit
.File_Names
(Kind
) /= null
654 and then Check_Project
655 (Unit
.File_Names
(Kind
).Project
, Project
)
656 and then not Unit
.File_Names
(Kind
).Locally_Removed
661 (Unit
.File_Names
(Kind
).Path
.Display_Name
) &
663 Check_File
=> False);
668 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
672 if FD
/= Invalid_FD
then
676 Osint
.Fail
("disk full");
686 function Check_Project
687 (Project
: Project_Id
;
688 Root_Project
: Project_Id
) return Boolean
693 if Project
= No_Project
then
696 elsif All_Projects
or else Project
= Root_Project
then
699 elsif The_Command
= Metric
then
700 Proj
:= Root_Project
;
701 while Proj
.Extends
/= No_Project
loop
702 if Project
= Proj
.Extends
then
706 Proj
:= Proj
.Extends
;
713 -------------------------------
714 -- Check_Relative_Executable --
715 -------------------------------
717 procedure Check_Relative_Executable
(Name
: in out String_Access
) is
718 Exec_File_Name
: constant String := Name
.all;
721 if not Is_Absolute_Path
(Exec_File_Name
) then
722 for Index
in Exec_File_Name
'Range loop
723 if Exec_File_Name
(Index
) = Directory_Separator
then
724 Fail
("relative executable (""" &
726 """) with directory part not allowed " &
727 "when using project files");
731 Get_Name_String
(Project
.Exec_Directory
.Name
);
733 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
734 Name_Len
:= Name_Len
+ 1;
735 Name_Buffer
(Name_Len
) := Directory_Separator
;
738 Name_Buffer
(Name_Len
+ 1 ..
739 Name_Len
+ Exec_File_Name
'Length) :=
741 Name_Len
:= Name_Len
+ Exec_File_Name
'Length;
742 Name
:= new String'(Name_Buffer (1 .. Name_Len));
744 end Check_Relative_Executable;
746 --------------------------------
747 -- Configuration_Pragmas_File --
748 --------------------------------
750 function Configuration_Pragmas_File return Path_Name_Type is
752 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
753 return Project.Config_File_Name;
754 end Configuration_Pragmas_File;
756 ------------------------------
757 -- Delete_Temp_Config_Files --
758 ------------------------------
760 procedure Delete_Temp_Config_Files is
763 pragma Warnings (Off, Success);
766 -- This should only be called if Keep_Temporary_Files is False
768 pragma Assert (not Keep_Temporary_Files);
770 if Project /= No_Project then
771 Proj := Project_Tree.Projects;
772 while Proj /= null loop
773 if Proj.Project.Config_File_Temp then
774 Delete_Temporary_File
775 (Project_Tree.Shared, Proj.Project.Config_File_Name);
782 -- If a temporary text file that contains a list of files for a tool
783 -- has been created, delete this temporary file.
785 if Temp_File_Name /= No_Path then
786 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
788 end Delete_Temp_Config_Files;
790 ---------------------------
791 -- Ensure_Absolute_Path --
792 ---------------------------
794 procedure Ensure_Absolute_Path
795 (Switch : in out String_Access;
799 Makeutl.Ensure_Absolute_Path
801 Do_Fail => Osint.Fail'Access,
802 Including_Non_Switch => False,
803 Including_RTS => True);
804 end Ensure_Absolute_Path;
810 procedure Get_Closure is
811 Args : constant Argument_List :=
812 (1 => new String'("-q"),
813 2 => new String'("-b"),
814 3 => new String'("-P"),
817 6 => new String'("-bargs"),
818 7 => new String'("-R"),
819 8 => new String'("-Z"));
820 -- Arguments for the invocation of gnatmake which are added to the
821 -- Last_Arguments list by this procedure.
823 FD : File_Descriptor;
824 -- File descriptor for the temp file that will get the output of the
825 -- invocation of gnatmake.
827 Name : Path_Name_Type;
828 -- Path of the file FD
830 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
833 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
836 Return_Code : Integer;
839 pragma Warnings (Off, Unused);
841 File : Ada.Text_IO.File_Type;
842 Line : String (1 .. 250);
844 -- Used to read file if there is an error, it is good enough to display
845 -- just 250 characters if the first line of the file is very long.
848 Path : Path_Name_Type;
850 Files_File : Ada.Text_IO.File_Type;
851 Temp_File_Name : Path_Name_Type;
854 if GN_Path = null then
855 Put_Line (Standard_Error, "could not locate " & GN_Name);
859 -- Create the temp file
861 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
863 -- And close it, because on VMS Spawn with a file descriptor created
864 -- with Create_Temp_File does not redirect output.
868 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
871 (Program_Name => GN_Path.all,
873 Output_File => Get_Name_String (Name),
875 Return_Code => Return_Code,
878 -- Read the output of the invocation of gnatmake
880 Open (File, In_File, Get_Name_String (Name));
882 -- If it was unsuccessful, display the first line in the file and exit
885 if Return_Code /= 0 then
886 Get_Line (File, Line, Last);
889 if not Keep_Temporary_Files then
895 -- Don't crash if it is not possible to delete or close the file,
896 -- just ignore the situation.
903 Put_Line (Standard_Error, Line (1 .. Last));
905 (Standard_Error, "could not get closure of " & ASIS_Main.all);
909 -- Create a temporary file to put the list of files in the closure
911 Tempdir.Create_Temp_File (FD, Temp_File_Name);
912 Last_Switches.Increment_Last;
913 Last_Switches.Table (Last_Switches.Last) :=
914 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
918 Open
(Files_File
, Out_File
, Get_Name_String
(Temp_File_Name
));
920 -- Get each file name in the file, find its path and add it the list
923 while not End_Of_File
(File
) loop
924 Get_Line
(File
, Line
, Last
);
927 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
928 while Unit
/= No_Unit_Index
loop
929 if Unit
.File_Names
(Spec
) /= null
931 Get_Name_String
(Unit
.File_Names
(Spec
).File
) =
934 Path
:= Unit
.File_Names
(Spec
).Path
.Name
;
937 elsif Unit
.File_Names
(Impl
) /= null
939 Get_Name_String
(Unit
.File_Names
(Impl
).File
) =
942 Path
:= Unit
.File_Names
(Impl
).Path
.Name
;
946 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
949 if Path
/= No_Path
then
950 Put_Line
(Files_File
, Get_Name_String
(Path
));
953 Put_Line
(Files_File
, Line
(1 .. Last
));
960 if not Keep_Temporary_Files
then
966 -- Don't crash if it is not possible to delete or close the file,
967 -- just ignore the situation.
980 function Mapping_File
return Path_Name_Type
is
981 Result
: Path_Name_Type
;
983 Prj
.Env
.Create_Mapping_File
985 Language
=> Name_Ada
,
986 In_Tree
=> Project_Tree
,
995 procedure Non_VMS_Usage
is
999 Put_Line
("List of available commands");
1002 for C
in Command_List
'Range loop
1004 -- No usage for VMS only command or for Sync
1006 if not Command_List
(C
).VMS_Only
and then C
/= Sync
then
1007 if Targparm
.AAMP_On_Target
then
1013 Put
(To_Lower
(Command_List
(C
).Cname
.all));
1016 -- Never call gnatstack with a prefix
1019 Put
(Command_List
(C
).Unixcmd
.all);
1021 Put
(Program_Name
(Command_List
(C
).Unixcmd
.all, "gnat").all);
1025 Sws
: Argument_List_Access
renames Command_List
(C
).Unixsws
;
1028 for J
in Sws
'Range loop
1040 Put_Line
("All commands except chop, krunch and preprocess " &
1041 "accept project file switches -vPx, -Pprj and -Xnam=val");
1049 procedure Process_Link
is
1050 Look_For_Executable
: Boolean := True;
1051 Libraries_Present
: Boolean := False;
1052 Path_Option
: constant String_Access
:=
1053 MLib
.Linker_Library_Path_Option
;
1054 Prj
: Project_Id
:= Project
;
1055 Arg
: String_Access
;
1056 Last
: Natural := 0;
1057 Skip_Executable
: Boolean := False;
1060 -- Add the default search directories, to be able to find
1061 -- libgnat in call to MLib.Utl.Lib_Directory.
1063 Add_Default_Search_Dirs
;
1065 Library_Paths
.Set_Last
(0);
1067 -- Check if there are library project files
1069 if MLib
.Tgt
.Support_For_Libraries
/= None
then
1070 Set_Libraries
(Project
, Project_Tree
, Libraries_Present
);
1073 -- If there are, add the necessary additional switches
1075 if Libraries_Present
then
1077 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
1079 Last_Switches
.Increment_Last
;
1080 Last_Switches
.Table
(Last_Switches
.Last
) :=
1081 new String'("-L" & MLib.Utl.Lib_Directory);
1082 Last_Switches.Increment_Last;
1083 Last_Switches.Table (Last_Switches.Last) :=
1084 new String'("-lgnarl");
1085 Last_Switches
.Increment_Last
;
1086 Last_Switches
.Table
(Last_Switches
.Last
) :=
1087 new String'("-lgnat");
1089 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
1090 -- equivalent) with all the library dirs plus the standard GNAT
1093 if Path_Option /= null then
1095 Option : String_Access;
1096 Length : Natural := Path_Option'Length;
1100 if MLib.Separate_Run_Path_Options then
1102 -- We are going to create one switch of the form
1103 -- "-Wl,-rpath,dir_N" for each directory to consider.
1105 -- One switch for each library directory
1108 Library_Paths.First .. Library_Paths.Last
1110 Last_Switches.Increment_Last;
1112 (Last_Switches.Last) := new String'
1114 Last_Switches
.Table
(Index
).all);
1117 -- One switch for the standard GNAT library dir
1119 Last_Switches
.Increment_Last
;
1121 (Last_Switches
.Last
) := new String'
1122 (Path_Option.all & MLib.Utl.Lib_Directory);
1125 -- First, compute the exact length for the switch
1128 Library_Paths.First .. Library_Paths.Last
1130 -- Add the length of the library dir plus one for the
1131 -- directory separator.
1135 Library_Paths.Table (Index)'Length + 1;
1138 -- Finally, add the length of the standard GNAT library dir
1140 Length := Length + MLib.Utl.Lib_Directory'Length;
1141 Option := new String (1 .. Length);
1142 Option (1 .. Path_Option'Length) := Path_Option.all;
1143 Current := Path_Option'Length;
1145 -- Put each library dir followed by a dir separator
1148 Library_Paths.First .. Library_Paths.Last
1153 Library_Paths.Table (Index)'Length) :=
1154 Library_Paths.Table (Index).all;
1157 Library_Paths.Table (Index)'Length + 1;
1158 Option (Current) := Path_Separator;
1161 -- Finally put the standard GNAT library dir
1165 Current + MLib.Utl.Lib_Directory'Length) :=
1166 MLib.Utl.Lib_Directory;
1168 -- And add the switch to the last switches
1170 Last_Switches.Increment_Last;
1171 Last_Switches.Table (Last_Switches.Last) :=
1178 -- Check if the first ALI file specified can be found, either in the
1179 -- object directory of the main project or in an object directory of a
1180 -- project file extended by the main project. If the ALI file can be
1181 -- found, replace its name with its absolute path.
1183 Skip_Executable := False;
1185 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1187 -- If we have an executable just reset the flag
1189 if Skip_Executable then
1190 Skip_Executable := False;
1192 -- If -o, set flag so that next switch is not processed
1194 elsif Last_Switches.Table (J).all = "-o" then
1195 Skip_Executable := True;
1201 Switch : constant String :=
1202 Last_Switches.Table (J).all;
1203 ALI_File : constant String (1 .. Switch'Length + 4) :=
1206 Test_Existence : Boolean := False;
1209 Last := Switch'Length;
1211 -- Skip real switches
1213 if Switch'Length /= 0
1214 and then Switch (Switch'First) /= '-'
1216 -- Append ".ali" if file name does not end with it
1218 if Switch'Length <= 4
1219 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1221 Last := ALI_File'Last;
1224 -- If file name includes directory information, stop if ALI
1227 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1228 Test_Existence := True;
1231 for K in Switch'Range loop
1233 or else Switch (K) = Directory_Separator
1235 Test_Existence := True;
1241 if Test_Existence then
1242 if Is_Regular_File (ALI_File (1 .. Last)) then
1246 -- Look in object directories if ALI file exists
1251 Dir : constant String :=
1252 Get_Name_String (Prj.Object_Directory.Name);
1256 ALI_File (1 .. Last))
1258 -- We have found the correct project, so we
1259 -- replace the file with the absolute path.
1261 Last_Switches.Table (J) :=
1262 new String'(Dir
& ALI_File
(1 .. Last
));
1270 -- Go to the project being extended, if any
1273 exit Project_Loop
when Prj
= No_Project
;
1274 end loop Project_Loop
;
1279 end loop Switch_Loop
;
1281 -- If a relative path output file has been specified, we add the exec
1284 for J
in reverse 1 .. Last_Switches
.Last
- 1 loop
1285 if Last_Switches
.Table
(J
).all = "-o" then
1286 Check_Relative_Executable
1287 (Name
=> Last_Switches
.Table
(J
+ 1));
1288 Look_For_Executable
:= False;
1293 if Look_For_Executable
then
1294 for J
in reverse 1 .. First_Switches
.Last
- 1 loop
1295 if First_Switches
.Table
(J
).all = "-o" then
1296 Look_For_Executable
:= False;
1297 Check_Relative_Executable
1298 (Name
=> First_Switches
.Table
(J
+ 1));
1304 -- If no executable is specified, then find the name of the first ALI
1305 -- file on the command line and issue a -o switch with the absolute path
1306 -- of the executable in the exec directory.
1308 if Look_For_Executable
then
1309 for J
in 1 .. Last_Switches
.Last
loop
1310 Arg
:= Last_Switches
.Table
(J
);
1313 if Arg
'Length /= 0 and then Arg
(Arg
'First) /= '-' then
1315 and then Arg
(Arg
'Last - 3 .. Arg
'Last) = ".ali"
1317 Last
:= Arg
'Last - 4;
1319 elsif Is_Regular_File
(Arg
.all & ".ali") then
1324 Last_Switches
.Increment_Last
;
1325 Last_Switches
.Table
(Last_Switches
.Last
) :=
1327 Get_Name_String (Project.Exec_Directory.Name);
1328 Last_Switches.Increment_Last;
1329 Last_Switches.Table (Last_Switches.Last) :=
1330 new String'(Name_Buffer
(1 .. Name_Len
) &
1332 (Base_Name
(Arg
(Arg
'First .. Last
))));
1340 ---------------------
1341 -- Set_Library_For --
1342 ---------------------
1344 procedure Set_Library_For
1345 (Project
: Project_Id
;
1346 Tree
: Project_Tree_Ref
;
1347 Libraries_Present
: in out Boolean)
1349 pragma Unreferenced
(Tree
);
1351 Path_Option
: constant String_Access
:=
1352 MLib
.Linker_Library_Path_Option
;
1355 -- Case of library project
1357 if Project
.Library
then
1358 Libraries_Present
:= True;
1360 -- Add the -L switch
1362 Last_Switches
.Increment_Last
;
1363 Last_Switches
.Table
(Last_Switches
.Last
) :=
1364 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1366 -- Add the -l switch
1368 Last_Switches.Increment_Last;
1369 Last_Switches.Table (Last_Switches.Last) :=
1370 new String'("-l" & Get_Name_String
(Project
.Library_Name
));
1372 -- Add the directory to table Library_Paths, to be processed later
1373 -- if library is not static and if Path_Option is not null.
1375 if Project
.Library_Kind
/= Static
1376 and then Path_Option
/= null
1378 Library_Paths
.Increment_Last
;
1379 Library_Paths
.Table
(Library_Paths
.Last
) :=
1380 new String'(Get_Name_String (Project.Library_Dir.Name));
1383 end Set_Library_For;
1385 -- Start of processing for GNATCmd
1388 -- All output from GNATCmd is debugging or error output: send to stderr
1398 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1400 Project_Node_Tree := new Project_Node_Tree_Data;
1401 Prj.Tree.Initialize (Project_Node_Tree);
1403 Prj.Initialize (Project_Tree);
1406 Last_Switches.Set_Last (0);
1408 First_Switches.Init;
1409 First_Switches.Set_Last (0);
1411 Carg_Switches.Set_Last (0);
1412 Rules_Switches.Init;
1413 Rules_Switches.Set_Last (0);
1415 VMS_Conv.Initialize;
1417 -- Add the default search directories, to be able to find system.ads in the
1418 -- subsequent call to Targparm.Get_Target_Parameters.
1420 Add_Default_Search_Dirs;
1422 -- Get target parameters so that AAMP_On_Target will be set, for testing in
1423 -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
1425 Targparm.Get_Target_Parameters;
1427 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1428 -- so that the spawned tool may know the way the GNAT driver was invoked.
1431 Add_Str_To_Name_Buffer (Command_Name);
1433 for J in 1 .. Argument_Count loop
1434 Add_Char_To_Name_Buffer (' ');
1435 Add_Str_To_Name_Buffer (Argument (J));
1438 -- On OpenVMS, setenv creates a logical whose length is limited to
1441 if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
1442 Name_Buffer (Max_OpenVMS_Logical_Length - 2
1443 .. Max_OpenVMS_Logical_Length) := "...";
1444 Name_Len := Max_OpenVMS_Logical_Length;
1447 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1449 -- Add the directory where the GNAT driver is invoked in front of the path,
1450 -- if the GNAT driver is invoked with directory information. Do not do this
1451 -- for VMS, where the notion of path does not really exist.
1455 Command : constant String := Command_Name;
1458 for Index in reverse Command'Range loop
1459 if Command (Index) = Directory_Separator then
1461 Absolute_Dir : constant String :=
1463 (Command (Command'First .. Index));
1465 PATH : constant String :=
1466 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1469 Setenv ("PATH", PATH);
1478 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1479 -- filenames and pathnames to Unix style.
1482 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1484 VMS_Conversion (The_Command);
1486 B_Start := new String'("b__");
1488 -- If not on VMS, scan the command line directly
1491 if Argument_Count
= 0 then
1497 if Argument_Count
> Command_Arg
1498 and then Argument
(Command_Arg
) = "-v"
1500 Verbose_Mode
:= True;
1501 Command_Arg
:= Command_Arg
+ 1;
1503 elsif Argument_Count
> Command_Arg
1504 and then Argument
(Command_Arg
) = "-dn"
1506 Keep_Temporary_Files
:= True;
1507 Command_Arg
:= Command_Arg
+ 1;
1514 The_Command
:= Real_Command_Type
'Value (Argument
(Command_Arg
));
1516 if Command_List
(The_Command
).VMS_Only
then
1520 & Command_List
(The_Command
).Cname
.all
1521 & """ can only be used on VMS");
1525 when Constraint_Error
=>
1527 -- Check if it is an alternate command
1530 Alternate
: Alternate_Command
;
1533 Alternate
:= Alternate_Command
'Value
1534 (Argument
(Command_Arg
));
1535 The_Command
:= Corresponding_To
(Alternate
);
1538 when Constraint_Error
=>
1540 Fail
("Unknown command: " & Argument
(Command_Arg
));
1544 -- Get the arguments from the command line and from the eventual
1545 -- argument file(s) specified on the command line.
1547 for Arg
in Command_Arg
+ 1 .. Argument_Count
loop
1549 The_Arg
: constant String := Argument
(Arg
);
1552 -- Check if an argument file is specified
1554 if The_Arg
(The_Arg
'First) = '@' then
1556 Arg_File
: Ada
.Text_IO
.File_Type
;
1557 Line
: String (1 .. 256);
1561 -- Open the file and fail if the file cannot be found
1566 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1571 (Standard_Error
, "Cannot open argument file """);
1574 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1576 Put_Line
(Standard_Error
, """");
1580 -- Read line by line and put the content of each non-
1581 -- empty line in the Last_Switches table.
1583 while not End_Of_File
(Arg_File
) loop
1584 Get_Line
(Arg_File
, Line
, Last
);
1587 Last_Switches
.Increment_Last
;
1588 Last_Switches
.Table
(Last_Switches
.Last
) :=
1589 new String'(Line (1 .. Last));
1597 -- It is not an argument file; just put the argument in
1598 -- the Last_Switches table.
1600 Last_Switches.Increment_Last;
1601 Last_Switches.Table (Last_Switches.Last) :=
1602 new String'(The_Arg
);
1610 Program
: String_Access
;
1611 Exec_Path
: String_Access
;
1614 if The_Command
= Stack
then
1616 -- Never call gnatstack with a prefix
1618 Program
:= new String'(Command_List (The_Command).Unixcmd.all);
1622 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1625 -- For the tools where the GNAT driver processes the project files,
1626 -- allow shared library projects to import projects that are not shared
1627 -- library projects, to avoid adding a switch for these tools. For the
1628 -- builder (gnatmake), if a shared library project imports a project
1629 -- that is not a shared library project and the appropriate switch is
1630 -- not specified, the invocation of gnatmake will fail.
1632 Opt.Unchecked_Shared_Lib_Imports := True;
1634 -- Locate the executable for the command
1636 Exec_Path := Locate_Exec_On_Path (Program.all);
1638 if Exec_Path = null then
1639 Put_Line (Standard_Error, "could not locate " & Program.all);
1643 -- If there are switches for the executable, put them as first switches
1645 if Command_List (The_Command).Unixsws /= null then
1646 for J in Command_List (The_Command).Unixsws'Range loop
1647 First_Switches.Increment_Last;
1648 First_Switches.Table (First_Switches.Last) :=
1649 Command_List (The_Command).Unixsws (J);
1653 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1654 -- SYNC and XREF, look for project file related switches.
1658 Tool_Package_Name := Name_Binder;
1659 Packages_To_Check := Packages_To_Check_By_Binder;
1661 Tool_Package_Name := Name_Check;
1662 Packages_To_Check := Packages_To_Check_By_Check;
1664 Tool_Package_Name := Name_Eliminate;
1665 Packages_To_Check := Packages_To_Check_By_Eliminate;
1667 Tool_Package_Name := Name_Finder;
1668 Packages_To_Check := Packages_To_Check_By_Finder;
1670 Tool_Package_Name := Name_Linker;
1671 Packages_To_Check := Packages_To_Check_By_Linker;
1673 Tool_Package_Name := Name_Gnatls;
1674 Packages_To_Check := Packages_To_Check_By_Gnatls;
1676 Tool_Package_Name := Name_Metrics;
1677 Packages_To_Check := Packages_To_Check_By_Metric;
1679 Tool_Package_Name := Name_Pretty_Printer;
1680 Packages_To_Check := Packages_To_Check_By_Pretty;
1682 Tool_Package_Name := Name_Stack;
1683 Packages_To_Check := Packages_To_Check_By_Stack;
1685 Tool_Package_Name := Name_Gnatstub;
1686 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1688 Tool_Package_Name := Name_Synchronize;
1689 Packages_To_Check := Packages_To_Check_By_Sync;
1691 Tool_Package_Name := Name_Cross_Reference;
1692 Packages_To_Check := Packages_To_Check_By_Xref;
1694 Tool_Package_Name := No_Name;
1697 if Tool_Package_Name /= No_Name then
1699 -- Check that the switches are consistent. Detect project file
1700 -- related switches.
1702 Inspect_Switches : declare
1703 Arg_Num : Positive := 1;
1704 Argv : String_Access;
1706 procedure Remove_Switch (Num : Positive);
1707 -- Remove a project related switch from table Last_Switches
1713 procedure Remove_Switch (Num : Positive) is
1715 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1716 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1717 Last_Switches.Decrement_Last;
1720 -- Start of processing for Inspect_Switches
1723 while Arg_Num <= Last_Switches.Last loop
1724 Argv := Last_Switches.Table (Arg_Num);
1726 if Argv (Argv'First) = '-' then
1727 if Argv'Length = 1 then
1729 ("switch character cannot be followed by a blank");
1732 -- The two style project files (-p and -P) cannot be used
1735 if (The_Command = Find or else The_Command = Xref)
1736 and then Argv (2) = 'p
'
1738 Old_Project_File_Used := True;
1739 if Project_File /= null then
1740 Fail ("-P and -p cannot be used together");
1744 -- --subdirs=... Specify Subdirs
1746 if Argv'Length > Makeutl.Subdirs_Option'Length
1750 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1751 Makeutl.Subdirs_Option
1756 (Argv
'First + Makeutl
.Subdirs_Option
'Length ..
1759 Remove_Switch
(Arg_Num
);
1761 -- -aPdir Add dir to the project search path
1763 elsif Argv
'Length > 3
1764 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "aP"
1766 Prj
.Env
.Add_Directories
1767 (Root_Environment
.Project_Path
,
1768 Argv
(Argv
'First + 3 .. Argv
'Last));
1770 -- Pass -aPdir to gnatls, but not to other tools
1772 if The_Command
= List
then
1773 Arg_Num
:= Arg_Num
+ 1;
1775 Remove_Switch
(Arg_Num
);
1778 -- -eL Follow links for files
1780 elsif Argv
.all = "-eL" then
1781 Follow_Links_For_Files
:= True;
1782 Follow_Links_For_Dirs
:= True;
1784 Remove_Switch
(Arg_Num
);
1786 -- -vPx Specify verbosity while parsing project files
1788 elsif Argv
'Length >= 3
1789 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "vP"
1792 and then Argv
(Argv
'Last) in '0' .. '2'
1794 case Argv
(Argv
'Last) is
1796 Current_Verbosity
:= Prj
.Default
;
1798 Current_Verbosity
:= Prj
.Medium
;
1800 Current_Verbosity
:= Prj
.High
;
1805 raise Program_Error
;
1808 Fail
("invalid verbosity level: "
1809 & Argv
(Argv
'First + 3 .. Argv
'Last));
1812 Remove_Switch
(Arg_Num
);
1814 -- -Pproject_file Specify project file to be used
1816 elsif Argv
(Argv
'First + 1) = 'P' then
1818 -- Only one -P switch can be used
1820 if Project_File
/= null then
1823 & ": second project file forbidden (first is """
1827 -- The two style project files (-p and -P) cannot be
1830 elsif Old_Project_File_Used
then
1831 Fail
("-p and -P cannot be used together");
1833 elsif Argv
'Length = 2 then
1835 -- There is space between -P and the project file
1836 -- name. -P cannot be the last option.
1838 if Arg_Num
= Last_Switches
.Last
then
1839 Fail
("project file name missing after -P");
1842 Remove_Switch
(Arg_Num
);
1843 Argv
:= Last_Switches
.Table
(Arg_Num
);
1845 -- After -P, there must be a project file name,
1846 -- not another switch.
1848 if Argv
(Argv
'First) = '-' then
1849 Fail
("project file name missing after -P");
1852 Project_File
:= new String'(Argv.all);
1857 -- No space between -P and project file name
1860 new String'(Argv
(Argv
'First + 2 .. Argv
'Last));
1863 Remove_Switch
(Arg_Num
);
1865 -- -Xexternal=value Specify an external reference to be
1866 -- used in project files
1868 elsif Argv
'Length >= 5
1869 and then Argv
(Argv
'First + 1) = 'X'
1871 if not Check
(Root_Environment
.External
,
1872 Argv
(Argv
'First + 2 .. Argv
'Last))
1875 & " is not a valid external assignment.");
1878 Remove_Switch
(Arg_Num
);
1881 (The_Command
= Check
or else
1882 The_Command
= Sync
or else
1883 The_Command
= Pretty
or else
1884 The_Command
= Metric
or else
1885 The_Command
= Stack
or else
1887 and then Argv
'Length = 2
1888 and then Argv
(2) = 'U'
1890 All_Projects
:= True;
1891 Remove_Switch
(Arg_Num
);
1894 Arg_Num
:= Arg_Num
+ 1;
1897 elsif ((The_Command
= Check
and then Argv
(Argv
'First) /= '+')
1898 or else The_Command
= Sync
1899 or else The_Command
= Metric
1900 or else The_Command
= Pretty
)
1901 and then Project_File
/= null
1902 and then All_Projects
1904 if ASIS_Main
/= null then
1905 Fail
("cannot specify more than one main after -U");
1908 Remove_Switch
(Arg_Num
);
1912 Arg_Num
:= Arg_Num
+ 1;
1915 end Inspect_Switches
;
1918 -- Add the default project search directories now, after the directories
1919 -- that have been specified by switches -aP<dir>.
1921 Prj
.Env
.Initialize_Default_Project_Path
1922 (Root_Environment
.Project_Path
,
1923 Target_Name
=> Sdefault
.Target_Name
.all);
1925 -- If there is a project file specified, parse it, get the switches
1926 -- for the tool and setup PATH environment variables.
1928 if Project_File
/= null then
1929 Prj
.Pars
.Set_Verbosity
(To
=> Current_Verbosity
);
1932 (Project
=> Project
,
1933 In_Tree
=> Project_Tree
,
1934 In_Node_Tree
=> Project_Node_Tree
,
1935 Project_File_Name
=> Project_File
.all,
1936 Env
=> Root_Environment
,
1937 Packages_To_Check
=> Packages_To_Check
);
1939 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1943 if Project
= Prj
.No_Project
then
1944 Fail
("""" & Project_File
.all & """ processing failed");
1946 elsif Project
.Qualifier
= Aggregate
then
1947 Fail
("aggregate projects are not supported");
1949 elsif Aggregate_Libraries_In
(Project_Tree
) then
1950 Fail
("aggregate library projects are not supported");
1953 -- Check if a package with the name of the tool is in the project
1954 -- file and if there is one, get the switches, if any, and scan them.
1957 Pkg
: constant Prj
.Package_Id
:=
1959 (Name
=> Tool_Package_Name
,
1960 In_Packages
=> Project
.Decl
.Packages
,
1961 Shared
=> Project_Tree
.Shared
);
1963 Element
: Package_Element
;
1965 Switches_Array
: Array_Element_Id
;
1967 The_Switches
: Prj
.Variable_Value
;
1968 Current
: Prj
.String_List_Id
;
1969 The_String
: String_Element
;
1971 Main
: String_Access
:= null;
1974 if Pkg
/= No_Package
then
1975 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
1977 -- Packages Gnatls and Gnatstack have a single attribute
1978 -- Switches, that is not an associative array.
1980 if The_Command
= List
or else The_Command
= Stack
then
1983 (Variable_Name
=> Snames
.Name_Switches
,
1984 In_Variables
=> Element
.Decl
.Attributes
,
1985 Shared
=> Project_Tree
.Shared
);
1987 -- Packages Binder (for gnatbind), Cross_Reference (for
1988 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1989 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1990 -- (for gnatcheck), and Metric (for gnatmetric) have an
1991 -- attributed Switches, an associative array, indexed by the
1992 -- name of the file.
1994 -- They also have an attribute Default_Switches, indexed by the
1995 -- name of the programming language.
1998 -- First check if there is a single main
2000 for J
in 1 .. Last_Switches
.Last
loop
2001 if Last_Switches
.Table
(J
) (1) /= '-' then
2003 Main
:= Last_Switches
.Table
(J
);
2012 if Main
/= null then
2015 (Name
=> Name_Switches
,
2016 In_Arrays
=> Element
.Decl
.Arrays
,
2017 Shared
=> Project_Tree
.Shared
);
2020 -- If the single main has been specified as an absolute
2021 -- path, use only the simple file name. If the absolute
2022 -- path is incorrect, an error will be reported by the
2023 -- underlying tool and it does not make a difference
2024 -- what switches are used.
2026 if Is_Absolute_Path
(Main
.all) then
2027 Add_Str_To_Name_Buffer
(File_Name
(Main
.all));
2029 Add_Str_To_Name_Buffer
(Main
.all);
2032 The_Switches
:= Prj
.Util
.Value_Of
2033 (Index
=> Name_Find
,
2035 In_Array
=> Switches_Array
,
2036 Shared
=> Project_Tree
.Shared
);
2039 if The_Switches
.Kind
= Prj
.Undefined
then
2042 (Name
=> Name_Default_Switches
,
2043 In_Arrays
=> Element
.Decl
.Arrays
,
2044 Shared
=> Project_Tree
.Shared
);
2045 The_Switches
:= Prj
.Util
.Value_Of
2048 In_Array
=> Switches_Array
,
2049 Shared
=> Project_Tree
.Shared
);
2053 -- If there are switches specified in the package of the
2054 -- project file corresponding to the tool, scan them.
2056 case The_Switches
.Kind
is
2057 when Prj
.Undefined
=>
2062 Switch
: constant String :=
2063 Get_Name_String
(The_Switches
.Value
);
2066 if Switch
'Length > 0 then
2067 First_Switches
.Increment_Last
;
2068 First_Switches
.Table
(First_Switches
.Last
) :=
2069 new String'(Switch);
2074 Current := The_Switches.Values;
2075 while Current /= Prj.Nil_String loop
2076 The_String := Project_Tree.Shared.String_Elements.
2080 Switch : constant String :=
2081 Get_Name_String (The_String.Value);
2084 if Switch'Length > 0 then
2085 First_Switches.Increment_Last;
2086 First_Switches.Table (First_Switches.Last) :=
2087 new String'(Switch
);
2091 Current
:= The_String
.Next
;
2097 if The_Command
= Bind
2098 or else The_Command
= Link
2099 or else The_Command
= Elim
2101 if Project
.Object_Directory
.Name
= No_Path
then
2102 Fail
("project " & Get_Name_String
(Project
.Display_Name
) &
2103 " has no object directory");
2106 Change_Dir
(Get_Name_String
(Project
.Object_Directory
.Name
));
2109 -- Set up the env vars for project path files
2111 Prj
.Env
.Set_Ada_Paths
2112 (Project
, Project_Tree
, Including_Libraries
=> True);
2114 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2115 -- a configuration pragmas file, if necessary.
2117 if The_Command
= Pretty
2118 or else The_Command
= Metric
2119 or else The_Command
= Stub
2120 or else The_Command
= Elim
2121 or else The_Command
= Check
2122 or else The_Command
= Sync
2124 -- If there are switches in package Compiler, put them in the
2125 -- Carg_Switches table.
2128 Pkg
: constant Prj
.Package_Id
:=
2130 (Name
=> Name_Compiler
,
2131 In_Packages
=> Project
.Decl
.Packages
,
2132 Shared
=> Project_Tree
.Shared
);
2134 Element
: Package_Element
;
2136 Switches_Array
: Array_Element_Id
;
2138 The_Switches
: Prj
.Variable_Value
;
2139 Current
: Prj
.String_List_Id
;
2140 The_String
: String_Element
;
2142 Main
: String_Access
:= null;
2146 if Pkg
/= No_Package
then
2148 -- First, check if there is a single main specified
2150 for J
in 1 .. Last_Switches
.Last
loop
2151 if Last_Switches
.Table
(J
) (1) /= '-' then
2153 Main
:= Last_Switches
.Table
(J
);
2162 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
2164 -- If there is a single main and there is compilation
2165 -- switches specified in the project file, use them.
2167 if Main
/= null and then not All_Projects
then
2168 Name_Len
:= Main
'Length;
2169 Name_Buffer
(1 .. Name_Len
) := Main
.all;
2170 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2171 Main_Id
:= Name_Find
;
2175 (Name
=> Name_Switches
,
2176 In_Arrays
=> Element
.Decl
.Arrays
,
2177 Shared
=> Project_Tree
.Shared
);
2178 The_Switches
:= Prj
.Util
.Value_Of
2181 In_Array
=> Switches_Array
,
2182 Shared
=> Project_Tree
.Shared
);
2185 -- Otherwise, get the Default_Switches ("Ada")
2187 if The_Switches
.Kind
= Undefined
then
2190 (Name
=> Name_Default_Switches
,
2191 In_Arrays
=> Element
.Decl
.Arrays
,
2192 Shared
=> Project_Tree
.Shared
);
2193 The_Switches
:= Prj
.Util
.Value_Of
2196 In_Array
=> Switches_Array
,
2197 Shared
=> Project_Tree
.Shared
);
2200 -- If there are switches specified, put them in the
2201 -- Carg_Switches table.
2203 case The_Switches
.Kind
is
2204 when Prj
.Undefined
=>
2209 Switch
: constant String :=
2210 Get_Name_String
(The_Switches
.Value
);
2212 if Switch
'Length > 0 then
2213 Add_To_Carg_Switches
(new String'(Switch));
2218 Current := The_Switches.Values;
2219 while Current /= Prj.Nil_String loop
2220 The_String := Project_Tree.Shared.String_Elements
2224 Switch : constant String :=
2225 Get_Name_String (The_String.Value);
2227 if Switch'Length > 0 then
2228 Add_To_Carg_Switches (new String'(Switch
));
2232 Current
:= The_String
.Next
;
2238 -- If -cargs is one of the switches, move the following switches
2239 -- to the Carg_Switches table.
2241 for J
in 1 .. First_Switches
.Last
loop
2242 if First_Switches
.Table
(J
).all = "-cargs" then
2248 -- Move the switches that are before -rules when the
2249 -- command is CHECK.
2252 while K
<= First_Switches
.Last
2254 (The_Command
/= Check
2255 or else First_Switches
.Table
(K
).all /= "-rules")
2257 Add_To_Carg_Switches
(First_Switches
.Table
(K
));
2261 if K
> First_Switches
.Last
then
2262 First_Switches
.Set_Last
(J
- 1);
2266 while K
<= First_Switches
.Last
loop
2268 First_Switches
.Table
(Last
) :=
2269 First_Switches
.Table
(K
);
2273 First_Switches
.Set_Last
(Last
);
2281 for J
in 1 .. Last_Switches
.Last
loop
2282 if Last_Switches
.Table
(J
).all = "-cargs" then
2288 -- Move the switches that are before -rules when the
2289 -- command is CHECK.
2292 while K
<= Last_Switches
.Last
2294 (The_Command
/= Check
2295 or else Last_Switches
.Table
(K
).all /= "-rules")
2297 Add_To_Carg_Switches
(Last_Switches
.Table
(K
));
2301 if K
> Last_Switches
.Last
then
2302 Last_Switches
.Set_Last
(J
- 1);
2306 while K
<= Last_Switches
.Last
loop
2308 Last_Switches
.Table
(Last
) :=
2309 Last_Switches
.Table
(K
);
2313 Last_Switches
.Set_Last
(Last
);
2322 CP_File
: constant Path_Name_Type
:= Configuration_Pragmas_File
;
2323 M_File
: constant Path_Name_Type
:= Mapping_File
;
2326 if CP_File
/= No_Path
then
2327 if The_Command
= Elim
then
2328 First_Switches
.Increment_Last
;
2329 First_Switches
.Table
(First_Switches
.Last
) :=
2330 new String'("-C" & Get_Name_String (CP_File));
2333 Add_To_Carg_Switches
2334 (new String'("-gnatec=" & Get_Name_String
(CP_File
)));
2338 if M_File
/= No_Path
then
2339 Add_To_Carg_Switches
2340 (new String'("-gnatem=" & Get_Name_String (M_File)));
2343 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2344 -- indicate a global configuration pragmas file and, if -U
2345 -- is not used, a local one.
2347 if The_Command = Check or else
2348 The_Command = Pretty or else
2349 The_Command = Stub or else
2350 The_Command = Metric
2353 Pkg : constant Prj.Package_Id :=
2355 (Name => Name_Builder,
2356 In_Packages => Project.Decl.Packages,
2357 Shared => Project_Tree.Shared);
2359 Variable : Variable_Value :=
2362 Attribute_Or_Array_Name =>
2363 Name_Global_Configuration_Pragmas,
2365 Shared => Project_Tree.Shared);
2368 if (Variable = Nil_Variable_Value
2369 or else Length_Of_Name (Variable.Value) = 0)
2370 and then Pkg /= No_Package
2375 Attribute_Or_Array_Name =>
2376 Name_Global_Config_File,
2378 Shared => Project_Tree.Shared);
2381 if Variable /= Nil_Variable_Value
2382 and then Length_Of_Name (Variable.Value) /= 0
2385 Path : constant String :=
2387 (Path_Name_Type (Variable.Value),
2390 Add_To_Carg_Switches
2391 (new String'("-gnatec=" & Path
));
2396 if not All_Projects
then
2398 Pkg
: constant Prj
.Package_Id
:=
2400 (Name
=> Name_Compiler
,
2401 In_Packages
=> Project
.Decl
.Packages
,
2402 Shared
=> Project_Tree
.Shared
);
2404 Variable
: Variable_Value
:=
2407 Attribute_Or_Array_Name
=>
2408 Name_Local_Configuration_Pragmas
,
2410 Shared
=> Project_Tree
.Shared
);
2413 if (Variable
= Nil_Variable_Value
2414 or else Length_Of_Name
(Variable
.Value
) = 0)
2415 and then Pkg
/= No_Package
2420 Attribute_Or_Array_Name
=>
2421 Name_Local_Config_File
,
2424 Project_Tree
.Shared
);
2427 if Variable
/= Nil_Variable_Value
2428 and then Length_Of_Name
(Variable
.Value
) /= 0
2431 Path
: constant String :=
2433 (Path_Name_Type
(Variable
.Value
),
2436 Add_To_Carg_Switches
2437 (new String'("-gnatec=" & Path));
2446 if The_Command = Link then
2450 if The_Command = Link or else The_Command = Bind then
2452 -- For files that are specified as relative paths with directory
2453 -- information, we convert them to absolute paths, with parent
2454 -- being the current working directory if specified on the command
2455 -- line and the project directory if specified in the project
2456 -- file. This is what gnatmake is doing for linker and binder
2459 for J in 1 .. Last_Switches.Last loop
2460 GNATCmd.Ensure_Absolute_Path
2461 (Last_Switches.Table (J), Current_Work_Dir);
2464 Get_Name_String (Project.Directory.Name);
2467 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2469 for J in 1 .. First_Switches.Last loop
2470 GNATCmd.Ensure_Absolute_Path
2471 (First_Switches.Table (J), Project_Dir);
2475 elsif The_Command = Stub then
2477 File_Index : Integer := 0;
2478 Dir_Index : Integer := 0;
2479 Last : constant Integer := Last_Switches.Last;
2480 Lang : constant Language_Ptr :=
2481 Get_Language_From_Name (Project, "ada");
2484 for Index in 1 .. Last loop
2485 if Last_Switches.Table (Index)
2486 (Last_Switches.Table (Index)'First) /= '-'
2488 File_Index := Index;
2493 -- If the project file naming scheme is not standard, and if
2494 -- the file name ends with the spec suffix, then indicate to
2495 -- gnatstub the name of the body file with a -o switch.
2497 if Lang /= No_Language_Index
2498 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data)
2500 if File_Index /= 0 then
2502 Spec : constant String :=
2504 (Last_Switches.Table (File_Index).all);
2505 Last : Natural := Spec'Last;
2508 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2510 if Spec'Length > Name_Len
2511 and then Spec (Last - Name_Len + 1 .. Last) =
2512 Name_Buffer (1 .. Name_Len)
2514 Last := Last - Name_Len;
2516 (Lang.Config.Naming_Data.Body_Suffix);
2517 Last_Switches.Increment_Last;
2518 Last_Switches.Table (Last_Switches.Last) :=
2520 Last_Switches
.Increment_Last
;
2521 Last_Switches
.Table
(Last_Switches
.Last
) :=
2522 new String'(Spec (Spec'First .. Last) &
2523 Name_Buffer (1 .. Name_Len));
2529 -- Add the directory of the spec as the destination directory
2530 -- of the body, if there is no destination directory already
2533 if File_Index /= 0 then
2534 for Index in File_Index + 1 .. Last loop
2535 if Last_Switches.Table (Index)
2536 (Last_Switches.Table (Index)'First) /= '-'
2543 if Dir_Index = 0 then
2544 Last_Switches.Increment_Last;
2545 Last_Switches.Table (Last_Switches.Last) :=
2547 (Dir_Name
(Last_Switches
.Table
(File_Index
).all));
2553 -- For gnatmetric, the generated files should be put in the object
2554 -- directory. This must be the first switch, because it may be
2555 -- overridden by a switch in package Metrics in the project file or
2556 -- by a command line option. Note that we don't add the -d= switch
2557 -- if there is no object directory available.
2559 if The_Command
= Metric
2560 and then Project
.Object_Directory
/= No_Path_Information
2562 First_Switches
.Increment_Last
;
2563 First_Switches
.Table
(2 .. First_Switches
.Last
) :=
2564 First_Switches
.Table
(1 .. First_Switches
.Last
- 1);
2565 First_Switches
.Table
(1) :=
2567 Get_Name_String (Project.Object_Directory.Name));
2570 -- For gnat check, -rules and the following switches need to be the
2571 -- last options, so move all these switches to table Rules_Switches.
2573 if The_Command = Check then
2576 -- Set to rank of options preceding "-rules"
2578 In_Rules_Switches : Boolean;
2579 -- Set to True when options "-rules" is found
2582 New_Last := First_Switches.Last;
2583 In_Rules_Switches := False;
2585 for J in 1 .. First_Switches.Last loop
2586 if In_Rules_Switches then
2587 Add_To_Rules_Switches (First_Switches.Table (J));
2589 elsif First_Switches.Table (J).all = "-rules" then
2591 In_Rules_Switches := True;
2595 if In_Rules_Switches then
2596 First_Switches.Set_Last (New_Last);
2599 New_Last := Last_Switches.Last;
2600 In_Rules_Switches := False;
2602 for J in 1 .. Last_Switches.Last loop
2603 if In_Rules_Switches then
2604 Add_To_Rules_Switches (Last_Switches.Table (J));
2606 elsif Last_Switches.Table (J).all = "-rules" then
2608 In_Rules_Switches := True;
2612 if In_Rules_Switches then
2613 Last_Switches.Set_Last (New_Last);
2618 -- For gnat check, sync, metric or pretty with -U + a main, get the
2619 -- list of sources from the closure and add them to the arguments.
2621 if ASIS_Main /= null then
2624 -- On VMS, set up the env var again for source dirs file. This is
2625 -- because the call to gnatmake has set this env var to another
2626 -- file that has now been deleted.
2628 if Hostparm.OpenVMS then
2630 -- First make sure that the recorded file names are empty
2632 Prj.Env.Initialize (Project_Tree);
2634 Prj.Env.Set_Ada_Paths
2635 (Project, Project_Tree, Including_Libraries => False);
2638 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2639 -- and gnat stack, if no file has been put on the command line, call
2640 -- tool with all the sources of the main project.
2642 elsif The_Command = Check or else
2643 The_Command = Sync or else
2644 The_Command = Pretty or else
2645 The_Command = Metric or else
2646 The_Command = List or else
2653 -- Gather all the arguments and invoke the executable
2656 The_Args : Argument_List
2657 (1 .. First_Switches.Last +
2658 Last_Switches.Last +
2659 Carg_Switches.Last +
2660 Rules_Switches.Last);
2661 Arg_Num : Natural := 0;
2664 for J in 1 .. First_Switches.Last loop
2665 Arg_Num := Arg_Num + 1;
2666 The_Args (Arg_Num) := First_Switches.Table (J);
2669 for J in 1 .. Last_Switches.Last loop
2670 Arg_Num := Arg_Num + 1;
2671 The_Args (Arg_Num) := Last_Switches.Table (J);
2674 for J in 1 .. Carg_Switches.Last loop
2675 Arg_Num := Arg_Num + 1;
2676 The_Args (Arg_Num) := Carg_Switches.Table (J);
2679 for J in 1 .. Rules_Switches.Last loop
2680 Arg_Num := Arg_Num + 1;
2681 The_Args (Arg_Num) := Rules_Switches.Table (J);
2684 -- If Display_Command is on, only display the generated command
2686 if Display_Command then
2687 Put (Standard_Error, "generated command -->");
2688 Put (Standard_Error, Exec_Path.all);
2690 for Arg in The_Args'Range loop
2691 Put (Standard_Error, " ");
2692 Put (Standard_Error, The_Args (Arg).all);
2695 Put (Standard_Error, "<--");
2696 New_Line (Standard_Error);
2700 if Verbose_Mode then
2701 Output.Write_Str (Exec_Path.all);
2703 for Arg in The_Args'Range loop
2704 Output.Write_Char (' ');
2705 Output.Write_Str (The_Args (Arg).all);
2712 Exit_Status (Spawn (Exec_Path.all, The_Args));
2719 if not Keep_Temporary_Files then
2720 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2721 Delete_Temp_Config_Files;
2724 Set_Exit_Status (Failure);
2727 if not Keep_Temporary_Files then
2728 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2729 Delete_Temp_Config_Files;
2732 -- Since GNATCmd is normally called from DCL (the VMS shell), it must
2733 -- return an understandable VMS exit status. However the exit status
2734 -- returned *to* GNATCmd is a Posix style code, so we test it and return
2735 -- just a simple success or failure on VMS.
2737 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
2738 Set_Exit_Status (Failure);
2740 Set_Exit_Status (My_Exit_Status);