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
;
50 with Types
; use Types
;
51 with VMS_Conv
; use VMS_Conv
;
52 with VMS_Cmds
; use VMS_Cmds
;
54 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
55 with Ada
.Command_Line
; use Ada
.Command_Line
;
56 with Ada
.Text_IO
; use Ada
.Text_IO
;
58 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
61 Project_Node_Tree
: Project_Node_Tree_Ref
;
62 Project_File
: String_Access
;
63 Project
: Prj
.Project_Id
;
64 Current_Verbosity
: Prj
.Verbosity
:= Prj
.Default
;
65 Tool_Package_Name
: Name_Id
:= No_Name
;
67 B_Start
: String_Ptr
:= new String'("b~");
68 -- Prefix of binder generated file, changed to b__ for VMS
70 Project_Tree : constant Project_Tree_Ref :=
71 new Project_Tree_Data (Is_Root_Tree => True);
74 Old_Project_File_Used : Boolean := False;
75 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
76 -- an old fashioned project file. -p cannot be used in conjunction
79 Temp_File_Name : Path_Name_Type := No_Path;
80 -- The name of the temporary text file to put a list of source/object
81 -- files to pass to a tool.
83 ASIS_Main : String_Access := null;
84 -- Main for commands Check, Metric and Pretty, when -U is used
86 package First_Switches is new Table.Table
87 (Table_Component_Type => String_Access,
88 Table_Index_Type => Integer,
91 Table_Increment => 100,
92 Table_Name => "Gnatcmd.First_Switches");
93 -- A table to keep the switches from the project file
95 package Carg_Switches is new Table.Table
96 (Table_Component_Type => String_Access,
97 Table_Index_Type => Integer,
100 Table_Increment => 100,
101 Table_Name => "Gnatcmd.Carg_Switches");
102 -- A table to keep the switches following -cargs for ASIS tools
104 package Rules_Switches is new Table.Table
105 (Table_Component_Type => String_Access,
106 Table_Index_Type => Integer,
107 Table_Low_Bound => 1,
109 Table_Increment => 100,
110 Table_Name => "Gnatcmd.Rules_Switches");
111 -- A table to keep the switches following -rules for gnatcheck
113 package Library_Paths is new Table.Table (
114 Table_Component_Type => String_Access,
115 Table_Index_Type => Integer,
116 Table_Low_Bound => 1,
118 Table_Increment => 100,
119 Table_Name => "Make.Library_Path");
121 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
122 -- tool. We allocate objects because we cannot declare aliased objects
123 -- as we are in a procedure, not a library level package.
125 subtype SA is String_Access;
127 Naming_String : constant SA := new String'("naming");
128 Binder_String
: constant SA
:= new String'("binder");
129 Builder_String : constant SA := new String'("builder");
130 Compiler_String
: constant SA
:= new String'("compiler");
131 Check_String : constant SA := new String'("check");
132 Synchronize_String
: constant SA
:= new String'("synchronize");
133 Eliminate_String : constant SA := new String'("eliminate");
134 Finder_String
: constant SA
:= new String'("finder");
135 Linker_String : constant SA := new String'("linker");
136 Gnatls_String
: constant SA
:= new String'("gnatls");
137 Pretty_String : constant SA := new String'("pretty_printer");
138 Stack_String
: constant SA
:= new String'("stack");
139 Gnatstub_String : constant SA := new String'("gnatstub");
140 Metric_String
: constant SA
:= new String'("metrics");
141 Xref_String : constant SA := new String'("cross_reference");
143 Packages_To_Check_By_Binder
: constant String_List_Access
:=
144 new String_List
'((Naming_String, Binder_String));
146 Packages_To_Check_By_Check : constant String_List_Access :=
148 ((Naming_String
, Builder_String
, Check_String
, Compiler_String
));
150 Packages_To_Check_By_Sync
: constant String_List_Access
:=
151 new String_List
'((Naming_String, Synchronize_String, Compiler_String));
153 Packages_To_Check_By_Eliminate : constant String_List_Access :=
154 new String_List'((Naming_String
, Eliminate_String
, Compiler_String
));
156 Packages_To_Check_By_Finder
: constant String_List_Access
:=
157 new String_List
'((Naming_String, Finder_String));
159 Packages_To_Check_By_Linker : constant String_List_Access :=
160 new String_List'((Naming_String
, Linker_String
));
162 Packages_To_Check_By_Gnatls
: constant String_List_Access
:=
163 new String_List
'((Naming_String, Gnatls_String));
165 Packages_To_Check_By_Pretty : constant String_List_Access :=
166 new String_List'((Naming_String
, Pretty_String
, Compiler_String
));
168 Packages_To_Check_By_Stack
: constant String_List_Access
:=
169 new String_List
'((Naming_String, Stack_String));
171 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
172 new String_List'((Naming_String
, Gnatstub_String
, Compiler_String
));
174 Packages_To_Check_By_Metric
: constant String_List_Access
:=
175 new String_List
'((Naming_String, Metric_String, Compiler_String));
177 Packages_To_Check_By_Xref : constant String_List_Access :=
178 new String_List'((Naming_String
, Xref_String
));
180 Packages_To_Check
: String_List_Access
:= Prj
.All_Packages
;
182 ----------------------------------
183 -- Declarations for GNATCMD use --
184 ----------------------------------
186 The_Command
: Command_Type
;
187 -- The command specified in the invocation of the GNAT driver
189 Command_Arg
: Positive := 1;
190 -- The index of the command in the arguments of the GNAT driver
192 My_Exit_Status
: Exit_Status
:= Success
;
193 -- The exit status of the spawned tool. Used to set the correct VMS
196 Current_Work_Dir
: constant String := Get_Current_Dir
;
197 -- The path of the working directory
199 All_Projects
: Boolean := False;
200 -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
201 -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
202 -- should be invoked for all sources of all projects.
204 Max_OpenVMS_Logical_Length
: constant Integer := 255;
205 -- The maximum length of OpenVMS logicals
207 -----------------------
208 -- Local Subprograms --
209 -----------------------
211 procedure Add_To_Carg_Switches
(Switch
: String_Access
);
212 -- Add a switch to the Carg_Switches table. If it is the first one, put the
213 -- switch "-cargs" at the beginning of the table.
215 procedure Add_To_Rules_Switches
(Switch
: String_Access
);
216 -- Add a switch to the Rules_Switches table. If it is the first one, put
217 -- the switch "-crules" at the beginning of the table.
219 procedure Check_Files
;
220 -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
221 -- project file is specified, without any file arguments and without a
222 -- switch -files=. If it is the case, invoke the GNAT tool with the proper
223 -- list of files, derived from the sources of the project.
225 function Check_Project
226 (Project
: Project_Id
;
227 Root_Project
: Project_Id
) return Boolean;
228 -- Returns True if Project = Root_Project or if we want to consider all
229 -- sources of all projects. For GNAT METRIC, also returns True if Project
230 -- is extended by Root_Project.
232 procedure Check_Relative_Executable
(Name
: in out String_Access
);
233 -- Check if an executable is specified as a relative path. If it is, and
234 -- the path contains directory information, fail. Otherwise, prepend the
235 -- exec directory. This procedure is only used for GNAT LINK when a project
236 -- file is specified.
238 function Configuration_Pragmas_File
return Path_Name_Type
;
239 -- Return an argument, if there is a configuration pragmas file to be
240 -- specified for Project, otherwise return No_Name. Used for gnatstub
241 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
244 procedure Delete_Temp_Config_Files
;
245 -- Delete all temporary config files. The caller is responsible for
246 -- ensuring that Keep_Temporary_Files is False.
248 procedure Ensure_Absolute_Path
249 (Switch
: in out String_Access
;
251 -- Test if Switch is a relative search path switch. If it is and it
252 -- includes directory information, prepend the path with Parent. This
253 -- subprogram is only called when using project files.
255 procedure Get_Closure
;
256 -- Get the sources in the closure of the ASIS_Main and add them to the
257 -- list of arguments.
259 function Mapping_File
return Path_Name_Type
;
260 -- Create and return the path name of a mapping file. Used for gnatstub
261 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
264 procedure Non_VMS_Usage
;
265 -- Display usage for platforms other than VMS
267 procedure Process_Link
;
268 -- Process GNAT LINK, when there is a project file specified
270 procedure Set_Library_For
271 (Project
: Project_Id
;
272 Tree
: Project_Tree_Ref
;
273 Libraries_Present
: in out Boolean);
274 -- If Project is a library project, add the correct -L and -l switches to
275 -- the linker invocation.
277 procedure Set_Libraries
is new
278 For_Every_Project_Imported
(Boolean, Set_Library_For
);
279 -- Add the -L and -l switches to the linker for all the library projects
281 --------------------------
282 -- Add_To_Carg_Switches --
283 --------------------------
285 procedure Add_To_Carg_Switches
(Switch
: String_Access
) is
287 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
289 if Carg_Switches
.Last
= 0 then
290 Carg_Switches
.Increment_Last
;
291 Carg_Switches
.Table
(Carg_Switches
.Last
) := new String'("-cargs");
294 Carg_Switches.Increment_Last;
295 Carg_Switches.Table (Carg_Switches.Last) := Switch;
296 end Add_To_Carg_Switches;
298 ---------------------------
299 -- Add_To_Rules_Switches --
300 ---------------------------
302 procedure Add_To_Rules_Switches (Switch : String_Access) is
304 -- If the Rules_Switches table is empty, put "-rules" at the beginning
306 if Rules_Switches.Last = 0 then
307 Rules_Switches.Increment_Last;
308 Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
311 Rules_Switches
.Increment_Last
;
312 Rules_Switches
.Table
(Rules_Switches
.Last
) := Switch
;
313 end Add_To_Rules_Switches
;
319 procedure Check_Files
is
320 Add_Sources
: Boolean := True;
321 Unit
: Prj
.Unit_Index
;
322 Subunit
: Boolean := False;
323 FD
: File_Descriptor
:= Invalid_FD
;
327 procedure Add_To_Response_File
329 Check_File
: Boolean := True);
330 -- Include the file name passed as parameter in the response file for
331 -- the tool being called. If the response file can not be written then
332 -- the file name is passed in the parameter list of the tool. If the
333 -- Check_File parameter is True then the procedure verifies the
334 -- existence of the file before adding it to the response file.
336 --------------------------
337 -- Add_To_Response_File --
338 --------------------------
340 procedure Add_To_Response_File
342 Check_File
: Boolean := True)
347 Add_Str_To_Name_Buffer
(File_Name
);
349 if not Check_File
or else
350 Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
352 if FD
/= Invalid_FD
then
353 Name_Len
:= Name_Len
+ 1;
354 Name_Buffer
(Name_Len
) := ASCII
.LF
;
356 Status
:= Write
(FD
, Name_Buffer
(1)'Address, Name_Len
);
358 if Status
/= Name_Len
then
359 Osint
.Fail
("disk full");
362 Last_Switches
.Increment_Last
;
363 Last_Switches
.Table
(Last_Switches
.Last
) :=
364 new String'(File_Name);
367 end Add_To_Response_File;
369 -- Start of processing for Check_Files
372 -- Check if there is at least one argument that is not a switch or if
373 -- there is a -files= switch.
375 for Index in 1 .. Last_Switches.Last loop
376 if Last_Switches.Table (Index).all'Length > 7
377 and then Last_Switches.Table (Index) (1 .. 7) = "-files="
379 Add_Sources := False;
382 elsif Last_Switches.Table (Index) (1) /= '-' then
386 and then Last_Switches.Table (Index - 1).all /= "-o")
388 (The_Command = Pretty
389 and then Last_Switches.Table (Index - 1).all /= "-o"
390 and then Last_Switches.Table (Index - 1).all /= "-of")
392 (The_Command = Metric
394 Last_Switches.Table (Index - 1).all /= "-o" and then
395 Last_Switches.Table (Index - 1).all /= "-og" and then
396 Last_Switches.Table (Index - 1).all /= "-ox" and then
397 Last_Switches.Table (Index - 1).all /= "-d")
399 (The_Command /= Check and then
400 The_Command /= Pretty and then
401 The_Command /= Metric)
403 Add_Sources := False;
409 -- If all arguments are switches and there is no switch -files=, add the
410 -- path names of all the sources of the main project.
414 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file and
415 -- put the list of sources in it. For gnatstack create a temporary
416 -- file with the list of .ci files.
418 if The_Command = Check or else
419 The_Command = Pretty or else
420 The_Command = Metric or else
421 The_Command = List or else
424 Tempdir.Create_Temp_File (FD, Temp_File_Name);
425 Last_Switches.Increment_Last;
426 Last_Switches.Table (Last_Switches.Last) :=
427 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
434 -- Gnatstack needs to add the .ci file for the binder generated
435 -- files corresponding to all of the library projects and main
436 -- units belonging to the application.
438 if The_Command
= Stack
then
439 Proj
:= Project_Tree
.Projects
;
440 while Proj
/= null loop
441 if Check_Project
(Proj
.Project
, Project
) then
443 Main
: String_List_Id
;
446 -- Include binder generated files for main programs
448 Main
:= Proj
.Project
.Mains
;
449 while Main
/= Nil_String
loop
452 (Proj
.Project
.Object_Directory
.Name
) &
456 (Project_Tree
.Shared
.String_Elements
.Table
460 -- When looking for the .ci file for a binder
461 -- generated file, look for both b~xxx and b__xxx
462 -- as gprbuild always uses b__ as the prefix of
465 if not Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
466 and then B_Start
.all /= "b__"
470 (Proj
.Project
.Object_Directory
.Name
) &
475 .String_Elements
.Table
(Main
).Value
),
479 Main
:= Project_Tree
.Shared
.String_Elements
.Table
483 if Proj
.Project
.Library
then
485 -- Include the .ci file for the binder generated
486 -- files that contains the initialization and
487 -- finalization of the library.
491 (Proj
.Project
.Object_Directory
.Name
) &
493 Get_Name_String
(Proj
.Project
.Library_Name
) &
496 -- When looking for the .ci file for a binder
497 -- generated file, look for both b~xxx and b__xxx
498 -- as gprbuild always uses b__ as the prefix of
501 if not Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
502 and then B_Start
.all /= "b__"
506 (Proj
.Project
.Object_Directory
.Name
) &
508 Get_Name_String
(Proj
.Project
.Library_Name
) &
519 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
520 while Unit
/= No_Unit_Index
loop
522 -- For gnatls, we only need to put the library units, body or
523 -- spec, but not the subunits.
525 if The_Command
= List
then
526 if Unit
.File_Names
(Impl
) /= null
527 and then not Unit
.File_Names
(Impl
).Locally_Removed
529 -- There is a body, check if it is for this project
532 or else Unit
.File_Names
(Impl
).Project
= Project
536 if Unit
.File_Names
(Spec
) = null
537 or else Unit
.File_Names
(Spec
).Locally_Removed
539 -- We have a body with no spec: we need to check if
540 -- this is a subunit, because gnatls will complain
544 Src_Ind
: constant Source_File_Index
:=
545 Sinput
.P
.Load_Project_File
551 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
558 (Unit
.File_Names
(Impl
).Display_File
),
559 Check_File
=> False);
563 elsif Unit
.File_Names
(Spec
) /= null
564 and then not Unit
.File_Names
(Spec
).Locally_Removed
566 -- We have a spec with no body. Check if it is for this
569 if All_Projects
or else
570 Unit
.File_Names
(Spec
).Project
= Project
574 (Unit
.File_Names
(Spec
).Display_File
),
575 Check_File
=> False);
579 -- For gnatstack, we put the .ci files corresponding to the
580 -- different units, including the binder generated files. We
581 -- only need to do that for the library units, body or spec,
582 -- but not the subunits.
584 elsif The_Command
= Stack
then
585 if Unit
.File_Names
(Impl
) /= null
586 and then not Unit
.File_Names
(Impl
).Locally_Removed
588 -- There is a body. Check if .ci files for this project
592 (Unit
.File_Names
(Impl
).Project
, Project
)
596 if Unit
.File_Names
(Spec
) = null
597 or else Unit
.File_Names
(Spec
).Locally_Removed
599 -- We have a body with no spec: we need to check
600 -- if this is a subunit, because .ci files are not
601 -- generated for subunits.
604 Src_Ind
: constant Source_File_Index
:=
605 Sinput
.P
.Load_Project_File
611 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
619 (Impl
).Project
. Object_Directory
.Name
) &
622 (Unit
.File_Names
(Impl
).Display_File
),
627 elsif Unit
.File_Names
(Spec
) /= null
628 and then not Unit
.File_Names
(Spec
).Locally_Removed
630 -- Spec with no body, check if it is for this project
633 (Unit
.File_Names
(Spec
).Project
, Project
)
638 (Spec
).Project
. Object_Directory
.Name
) &
641 (Get_Name_String
(Unit
.File_Names
(Spec
).File
),
647 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
648 -- sources of the project, or of all projects if -U was
651 for Kind
in Spec_Or_Body
loop
652 if Unit
.File_Names
(Kind
) /= null
653 and then Check_Project
654 (Unit
.File_Names
(Kind
).Project
, Project
)
655 and then not Unit
.File_Names
(Kind
).Locally_Removed
660 (Unit
.File_Names
(Kind
).Path
.Display_Name
) &
662 Check_File
=> False);
667 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
671 if FD
/= Invalid_FD
then
675 Osint
.Fail
("disk full");
685 function Check_Project
686 (Project
: Project_Id
;
687 Root_Project
: Project_Id
) return Boolean
692 if Project
= No_Project
then
695 elsif All_Projects
or else Project
= Root_Project
then
698 elsif The_Command
= Metric
then
699 Proj
:= Root_Project
;
700 while Proj
.Extends
/= No_Project
loop
701 if Project
= Proj
.Extends
then
705 Proj
:= Proj
.Extends
;
712 -------------------------------
713 -- Check_Relative_Executable --
714 -------------------------------
716 procedure Check_Relative_Executable
(Name
: in out String_Access
) is
717 Exec_File_Name
: constant String := Name
.all;
720 if not Is_Absolute_Path
(Exec_File_Name
) then
721 for Index
in Exec_File_Name
'Range loop
722 if Exec_File_Name
(Index
) = Directory_Separator
then
723 Fail
("relative executable (""" &
725 """) with directory part not allowed " &
726 "when using project files");
730 Get_Name_String
(Project
.Exec_Directory
.Name
);
732 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
733 Name_Len
:= Name_Len
+ 1;
734 Name_Buffer
(Name_Len
) := Directory_Separator
;
737 Name_Buffer
(Name_Len
+ 1 ..
738 Name_Len
+ Exec_File_Name
'Length) :=
740 Name_Len
:= Name_Len
+ Exec_File_Name
'Length;
741 Name
:= new String'(Name_Buffer (1 .. Name_Len));
743 end Check_Relative_Executable;
745 --------------------------------
746 -- Configuration_Pragmas_File --
747 --------------------------------
749 function Configuration_Pragmas_File return Path_Name_Type is
751 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
752 return Project.Config_File_Name;
753 end Configuration_Pragmas_File;
755 ------------------------------
756 -- Delete_Temp_Config_Files --
757 ------------------------------
759 procedure Delete_Temp_Config_Files is
762 pragma Warnings (Off, Success);
765 -- This should only be called if Keep_Temporary_Files is False
767 pragma Assert (not Keep_Temporary_Files);
769 if Project /= No_Project then
770 Proj := Project_Tree.Projects;
771 while Proj /= null loop
772 if Proj.Project.Config_File_Temp then
773 Delete_Temporary_File
774 (Project_Tree.Shared, Proj.Project.Config_File_Name);
781 -- If a temporary text file that contains a list of files for a tool
782 -- has been created, delete this temporary file.
784 if Temp_File_Name /= No_Path then
785 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
787 end Delete_Temp_Config_Files;
789 ---------------------------
790 -- Ensure_Absolute_Path --
791 ---------------------------
793 procedure Ensure_Absolute_Path
794 (Switch : in out String_Access;
798 Makeutl.Ensure_Absolute_Path
800 Do_Fail => Osint.Fail'Access,
801 Including_Non_Switch => False,
802 Including_RTS => True);
803 end Ensure_Absolute_Path;
809 procedure Get_Closure is
810 Args : constant Argument_List :=
811 (1 => new String'("-q"),
812 2 => new String'("-b"),
813 3 => new String'("-P"),
816 6 => new String'("-bargs"),
817 7 => new String'("-R"),
818 8 => new String'("-Z"));
819 -- Arguments for the invocation of gnatmake which are added to the
820 -- Last_Arguments list by this procedure.
822 FD : File_Descriptor;
823 -- File descriptor for the temp file that will get the output of the
824 -- invocation of gnatmake.
826 Name : Path_Name_Type;
827 -- Path of the file FD
829 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
832 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
835 Return_Code : Integer;
838 pragma Warnings (Off, Unused);
840 File : Ada.Text_IO.File_Type;
841 Line : String (1 .. 250);
843 -- Used to read file if there is an error, it is good enough to display
844 -- just 250 characters if the first line of the file is very long.
847 Path : Path_Name_Type;
849 Files_File : Ada.Text_IO.File_Type;
850 Temp_File_Name : Path_Name_Type;
853 if GN_Path = null then
854 Put_Line (Standard_Error, "could not locate " & GN_Name);
858 -- Create the temp file
860 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
862 -- And close it, because on VMS Spawn with a file descriptor created
863 -- with Create_Temp_File does not redirect output.
867 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
870 (Program_Name => GN_Path.all,
872 Output_File => Get_Name_String (Name),
874 Return_Code => Return_Code,
877 -- Read the output of the invocation of gnatmake
879 Open (File, In_File, Get_Name_String (Name));
881 -- If it was unsuccessful, display the first line in the file and exit
884 if Return_Code /= 0 then
885 Get_Line (File, Line, Last);
888 if not Keep_Temporary_Files then
894 -- Don't crash if it is not possible to delete or close the file,
895 -- just ignore the situation.
902 Put_Line (Standard_Error, Line (1 .. Last));
904 (Standard_Error, "could not get closure of " & ASIS_Main.all);
908 -- Create a temporary file to put the list of files in the closure
910 Tempdir.Create_Temp_File (FD, Temp_File_Name);
911 Last_Switches.Increment_Last;
912 Last_Switches.Table (Last_Switches.Last) :=
913 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
917 Open
(Files_File
, Out_File
, Get_Name_String
(Temp_File_Name
));
919 -- Get each file name in the file, find its path and add it the list
922 while not End_Of_File
(File
) loop
923 Get_Line
(File
, Line
, Last
);
926 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
927 while Unit
/= No_Unit_Index
loop
928 if Unit
.File_Names
(Spec
) /= null
930 Get_Name_String
(Unit
.File_Names
(Spec
).File
) =
933 Path
:= Unit
.File_Names
(Spec
).Path
.Name
;
936 elsif Unit
.File_Names
(Impl
) /= null
938 Get_Name_String
(Unit
.File_Names
(Impl
).File
) =
941 Path
:= Unit
.File_Names
(Impl
).Path
.Name
;
945 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
948 if Path
/= No_Path
then
949 Put_Line
(Files_File
, Get_Name_String
(Path
));
952 Put_Line
(Files_File
, Line
(1 .. Last
));
959 if not Keep_Temporary_Files
then
965 -- Don't crash if it is not possible to delete or close the file,
966 -- just ignore the situation.
979 function Mapping_File
return Path_Name_Type
is
980 Result
: Path_Name_Type
;
982 Prj
.Env
.Create_Mapping_File
984 Language
=> Name_Ada
,
985 In_Tree
=> Project_Tree
,
994 procedure Non_VMS_Usage
is
998 Put_Line
("List of available commands");
1001 for C
in Command_List
'Range loop
1003 -- No usage for VMS only command or for Sync
1005 if not Command_List
(C
).VMS_Only
and then C
/= Sync
then
1006 if Targparm
.AAMP_On_Target
then
1012 Put
(To_Lower
(Command_List
(C
).Cname
.all));
1015 -- Never call gnatstack with a prefix
1018 Put
(Command_List
(C
).Unixcmd
.all);
1020 Put
(Program_Name
(Command_List
(C
).Unixcmd
.all, "gnat").all);
1024 Sws
: Argument_List_Access
renames Command_List
(C
).Unixsws
;
1027 for J
in Sws
'Range loop
1039 Put_Line
("All commands except chop, krunch and preprocess " &
1040 "accept project file switches -vPx, -Pprj and -Xnam=val");
1047 procedure Process_Link
is
1048 Look_For_Executable
: Boolean := True;
1049 Libraries_Present
: Boolean := False;
1050 Path_Option
: constant String_Access
:=
1051 MLib
.Linker_Library_Path_Option
;
1052 Prj
: Project_Id
:= Project
;
1053 Arg
: String_Access
;
1054 Last
: Natural := 0;
1055 Skip_Executable
: Boolean := False;
1058 -- Add the default search directories, to be able to find
1059 -- libgnat in call to MLib.Utl.Lib_Directory.
1061 Add_Default_Search_Dirs
;
1063 Library_Paths
.Set_Last
(0);
1065 -- Check if there are library project files
1067 if MLib
.Tgt
.Support_For_Libraries
/= None
then
1068 Set_Libraries
(Project
, Project_Tree
, Libraries_Present
);
1071 -- If there are, add the necessary additional switches
1073 if Libraries_Present
then
1075 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
1077 Last_Switches
.Increment_Last
;
1078 Last_Switches
.Table
(Last_Switches
.Last
) :=
1079 new String'("-L" & MLib.Utl.Lib_Directory);
1080 Last_Switches.Increment_Last;
1081 Last_Switches.Table (Last_Switches.Last) :=
1082 new String'("-lgnarl");
1083 Last_Switches
.Increment_Last
;
1084 Last_Switches
.Table
(Last_Switches
.Last
) :=
1085 new String'("-lgnat");
1087 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
1088 -- equivalent) with all the library dirs plus the standard GNAT
1091 if Path_Option /= null then
1093 Option : String_Access;
1094 Length : Natural := Path_Option'Length;
1098 if MLib.Separate_Run_Path_Options then
1100 -- We are going to create one switch of the form
1101 -- "-Wl,-rpath,dir_N" for each directory to consider.
1103 -- One switch for each library directory
1106 Library_Paths.First .. Library_Paths.Last
1108 Last_Switches.Increment_Last;
1110 (Last_Switches.Last) := new String'
1112 Last_Switches
.Table
(Index
).all);
1115 -- One switch for the standard GNAT library dir
1117 Last_Switches
.Increment_Last
;
1119 (Last_Switches
.Last
) := new String'
1120 (Path_Option.all & MLib.Utl.Lib_Directory);
1123 -- First, compute the exact length for the switch
1126 Library_Paths.First .. Library_Paths.Last
1128 -- Add the length of the library dir plus one for the
1129 -- directory separator.
1133 Library_Paths.Table (Index)'Length + 1;
1136 -- Finally, add the length of the standard GNAT library dir
1138 Length := Length + MLib.Utl.Lib_Directory'Length;
1139 Option := new String (1 .. Length);
1140 Option (1 .. Path_Option'Length) := Path_Option.all;
1141 Current := Path_Option'Length;
1143 -- Put each library dir followed by a dir separator
1146 Library_Paths.First .. Library_Paths.Last
1151 Library_Paths.Table (Index)'Length) :=
1152 Library_Paths.Table (Index).all;
1155 Library_Paths.Table (Index)'Length + 1;
1156 Option (Current) := Path_Separator;
1159 -- Finally put the standard GNAT library dir
1163 Current + MLib.Utl.Lib_Directory'Length) :=
1164 MLib.Utl.Lib_Directory;
1166 -- And add the switch to the last switches
1168 Last_Switches.Increment_Last;
1169 Last_Switches.Table (Last_Switches.Last) :=
1176 -- Check if the first ALI file specified can be found, either in the
1177 -- object directory of the main project or in an object directory of a
1178 -- project file extended by the main project. If the ALI file can be
1179 -- found, replace its name with its absolute path.
1181 Skip_Executable := False;
1183 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1185 -- If we have an executable just reset the flag
1187 if Skip_Executable then
1188 Skip_Executable := False;
1190 -- If -o, set flag so that next switch is not processed
1192 elsif Last_Switches.Table (J).all = "-o" then
1193 Skip_Executable := True;
1199 Switch : constant String :=
1200 Last_Switches.Table (J).all;
1201 ALI_File : constant String (1 .. Switch'Length + 4) :=
1204 Test_Existence : Boolean := False;
1207 Last := Switch'Length;
1209 -- Skip real switches
1211 if Switch'Length /= 0
1212 and then Switch (Switch'First) /= '-'
1214 -- Append ".ali" if file name does not end with it
1216 if Switch'Length <= 4
1217 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1219 Last := ALI_File'Last;
1222 -- If file name includes directory information, stop if ALI
1225 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1226 Test_Existence := True;
1229 for K in Switch'Range loop
1231 or else Switch (K) = Directory_Separator
1233 Test_Existence := True;
1239 if Test_Existence then
1240 if Is_Regular_File (ALI_File (1 .. Last)) then
1244 -- Look in object directories if ALI file exists
1249 Dir : constant String :=
1250 Get_Name_String (Prj.Object_Directory.Name);
1254 ALI_File (1 .. Last))
1256 -- We have found the correct project, so we
1257 -- replace the file with the absolute path.
1259 Last_Switches.Table (J) :=
1260 new String'(Dir
& ALI_File
(1 .. Last
));
1268 -- Go to the project being extended, if any
1271 exit Project_Loop
when Prj
= No_Project
;
1272 end loop Project_Loop
;
1277 end loop Switch_Loop
;
1279 -- If a relative path output file has been specified, we add the exec
1282 for J
in reverse 1 .. Last_Switches
.Last
- 1 loop
1283 if Last_Switches
.Table
(J
).all = "-o" then
1284 Check_Relative_Executable
1285 (Name
=> Last_Switches
.Table
(J
+ 1));
1286 Look_For_Executable
:= False;
1291 if Look_For_Executable
then
1292 for J
in reverse 1 .. First_Switches
.Last
- 1 loop
1293 if First_Switches
.Table
(J
).all = "-o" then
1294 Look_For_Executable
:= False;
1295 Check_Relative_Executable
1296 (Name
=> First_Switches
.Table
(J
+ 1));
1302 -- If no executable is specified, then find the name of the first ALI
1303 -- file on the command line and issue a -o switch with the absolute path
1304 -- of the executable in the exec directory.
1306 if Look_For_Executable
then
1307 for J
in 1 .. Last_Switches
.Last
loop
1308 Arg
:= Last_Switches
.Table
(J
);
1311 if Arg
'Length /= 0 and then Arg
(Arg
'First) /= '-' then
1313 and then Arg
(Arg
'Last - 3 .. Arg
'Last) = ".ali"
1315 Last
:= Arg
'Last - 4;
1317 elsif Is_Regular_File
(Arg
.all & ".ali") then
1322 Last_Switches
.Increment_Last
;
1323 Last_Switches
.Table
(Last_Switches
.Last
) :=
1325 Get_Name_String (Project.Exec_Directory.Name);
1326 Last_Switches.Increment_Last;
1327 Last_Switches.Table (Last_Switches.Last) :=
1328 new String'(Name_Buffer
(1 .. Name_Len
) &
1330 (Base_Name
(Arg
(Arg
'First .. Last
))));
1338 ---------------------
1339 -- Set_Library_For --
1340 ---------------------
1342 procedure Set_Library_For
1343 (Project
: Project_Id
;
1344 Tree
: Project_Tree_Ref
;
1345 Libraries_Present
: in out Boolean)
1347 pragma Unreferenced
(Tree
);
1349 Path_Option
: constant String_Access
:=
1350 MLib
.Linker_Library_Path_Option
;
1353 -- Case of library project
1355 if Project
.Library
then
1356 Libraries_Present
:= True;
1358 -- Add the -L switch
1360 Last_Switches
.Increment_Last
;
1361 Last_Switches
.Table
(Last_Switches
.Last
) :=
1362 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1364 -- Add the -l switch
1366 Last_Switches.Increment_Last;
1367 Last_Switches.Table (Last_Switches.Last) :=
1368 new String'("-l" & Get_Name_String
(Project
.Library_Name
));
1370 -- Add the directory to table Library_Paths, to be processed later
1371 -- if library is not static and if Path_Option is not null.
1373 if Project
.Library_Kind
/= Static
1374 and then Path_Option
/= null
1376 Library_Paths
.Increment_Last
;
1377 Library_Paths
.Table
(Library_Paths
.Last
) :=
1378 new String'(Get_Name_String (Project.Library_Dir.Name));
1381 end Set_Library_For;
1383 -- Start of processing for GNATCmd
1386 -- All output from GNATCmd is debugging or error output: send to stderr
1395 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1397 Project_Node_Tree := new Project_Node_Tree_Data;
1398 Prj.Tree.Initialize (Project_Node_Tree);
1400 Prj.Initialize (Project_Tree);
1403 Last_Switches.Set_Last (0);
1405 First_Switches.Init;
1406 First_Switches.Set_Last (0);
1408 Carg_Switches.Set_Last (0);
1409 Rules_Switches.Init;
1410 Rules_Switches.Set_Last (0);
1412 VMS_Conv.Initialize;
1414 -- Add the default search directories, to be able to find system.ads in the
1415 -- subsequent call to Targparm.Get_Target_Parameters.
1417 Add_Default_Search_Dirs;
1419 -- Get target parameters so that AAMP_On_Target will be set, for testing in
1420 -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
1422 Targparm.Get_Target_Parameters;
1424 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1425 -- so that the spawned tool may know the way the GNAT driver was invoked.
1428 Add_Str_To_Name_Buffer (Command_Name);
1430 for J in 1 .. Argument_Count loop
1431 Add_Char_To_Name_Buffer (' ');
1432 Add_Str_To_Name_Buffer (Argument (J));
1435 -- On OpenVMS, setenv creates a logical whose length is limited to
1438 if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
1439 Name_Buffer (Max_OpenVMS_Logical_Length - 2
1440 .. Max_OpenVMS_Logical_Length) := "...";
1441 Name_Len := Max_OpenVMS_Logical_Length;
1444 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1446 -- Add the directory where the GNAT driver is invoked in front of the path,
1447 -- if the GNAT driver is invoked with directory information. Do not do this
1448 -- for VMS, where the notion of path does not really exist.
1452 Command : constant String := Command_Name;
1455 for Index in reverse Command'Range loop
1456 if Command (Index) = Directory_Separator then
1458 Absolute_Dir : constant String :=
1460 (Command (Command'First .. Index));
1462 PATH : constant String :=
1463 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1466 Setenv ("PATH", PATH);
1475 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1476 -- filenames and pathnames to Unix style.
1479 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1481 VMS_Conversion (The_Command);
1483 B_Start := new String'("b__");
1485 -- If not on VMS, scan the command line directly
1488 if Argument_Count
= 0 then
1494 if Argument_Count
> Command_Arg
1495 and then Argument
(Command_Arg
) = "-v"
1497 Verbose_Mode
:= True;
1498 Command_Arg
:= Command_Arg
+ 1;
1500 elsif Argument_Count
> Command_Arg
1501 and then Argument
(Command_Arg
) = "-dn"
1503 Keep_Temporary_Files
:= True;
1504 Command_Arg
:= Command_Arg
+ 1;
1511 The_Command
:= Real_Command_Type
'Value (Argument
(Command_Arg
));
1513 if Command_List
(The_Command
).VMS_Only
then
1517 & Command_List
(The_Command
).Cname
.all
1518 & """ can only be used on VMS");
1522 when Constraint_Error
=>
1524 -- Check if it is an alternate command
1527 Alternate
: Alternate_Command
;
1530 Alternate
:= Alternate_Command
'Value
1531 (Argument
(Command_Arg
));
1532 The_Command
:= Corresponding_To
(Alternate
);
1535 when Constraint_Error
=>
1537 Fail
("Unknown command: " & Argument
(Command_Arg
));
1541 -- Get the arguments from the command line and from the eventual
1542 -- argument file(s) specified on the command line.
1544 for Arg
in Command_Arg
+ 1 .. Argument_Count
loop
1546 The_Arg
: constant String := Argument
(Arg
);
1549 -- Check if an argument file is specified
1551 if The_Arg
(The_Arg
'First) = '@' then
1553 Arg_File
: Ada
.Text_IO
.File_Type
;
1554 Line
: String (1 .. 256);
1558 -- Open the file and fail if the file cannot be found
1563 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1568 (Standard_Error
, "Cannot open argument file """);
1571 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1573 Put_Line
(Standard_Error
, """");
1577 -- Read line by line and put the content of each non-
1578 -- empty line in the Last_Switches table.
1580 while not End_Of_File
(Arg_File
) loop
1581 Get_Line
(Arg_File
, Line
, Last
);
1584 Last_Switches
.Increment_Last
;
1585 Last_Switches
.Table
(Last_Switches
.Last
) :=
1586 new String'(Line (1 .. Last));
1594 -- It is not an argument file; just put the argument in
1595 -- the Last_Switches table.
1597 Last_Switches.Increment_Last;
1598 Last_Switches.Table (Last_Switches.Last) :=
1599 new String'(The_Arg
);
1607 Program
: String_Access
;
1608 Exec_Path
: String_Access
;
1611 if The_Command
= Stack
then
1613 -- Never call gnatstack with a prefix
1615 Program
:= new String'(Command_List (The_Command).Unixcmd.all);
1619 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1622 -- For the tools where the GNAT driver processes the project files,
1623 -- allow shared library projects to import projects that are not shared
1624 -- library projects, to avoid adding a switch for these tools. For the
1625 -- builder (gnatmake), if a shared library project imports a project
1626 -- that is not a shared library project and the appropriate switch is
1627 -- not specified, the invocation of gnatmake will fail.
1629 Opt.Unchecked_Shared_Lib_Imports := True;
1631 -- Locate the executable for the command
1633 Exec_Path := Locate_Exec_On_Path (Program.all);
1635 if Exec_Path = null then
1636 Put_Line (Standard_Error, "could not locate " & Program.all);
1640 -- If there are switches for the executable, put them as first switches
1642 if Command_List (The_Command).Unixsws /= null then
1643 for J in Command_List (The_Command).Unixsws'Range loop
1644 First_Switches.Increment_Last;
1645 First_Switches.Table (First_Switches.Last) :=
1646 Command_List (The_Command).Unixsws (J);
1650 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1651 -- SYNC and XREF, look for project file related switches.
1655 Tool_Package_Name := Name_Binder;
1656 Packages_To_Check := Packages_To_Check_By_Binder;
1658 Tool_Package_Name := Name_Check;
1659 Packages_To_Check := Packages_To_Check_By_Check;
1661 Tool_Package_Name := Name_Eliminate;
1662 Packages_To_Check := Packages_To_Check_By_Eliminate;
1664 Tool_Package_Name := Name_Finder;
1665 Packages_To_Check := Packages_To_Check_By_Finder;
1667 Tool_Package_Name := Name_Linker;
1668 Packages_To_Check := Packages_To_Check_By_Linker;
1670 Tool_Package_Name := Name_Gnatls;
1671 Packages_To_Check := Packages_To_Check_By_Gnatls;
1673 Tool_Package_Name := Name_Metrics;
1674 Packages_To_Check := Packages_To_Check_By_Metric;
1676 Tool_Package_Name := Name_Pretty_Printer;
1677 Packages_To_Check := Packages_To_Check_By_Pretty;
1679 Tool_Package_Name := Name_Stack;
1680 Packages_To_Check := Packages_To_Check_By_Stack;
1682 Tool_Package_Name := Name_Gnatstub;
1683 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1685 Tool_Package_Name := Name_Synchronize;
1686 Packages_To_Check := Packages_To_Check_By_Sync;
1688 Tool_Package_Name := Name_Cross_Reference;
1689 Packages_To_Check := Packages_To_Check_By_Xref;
1691 Tool_Package_Name := No_Name;
1694 if Tool_Package_Name /= No_Name then
1696 -- Check that the switches are consistent. Detect project file
1697 -- related switches.
1699 Inspect_Switches : declare
1700 Arg_Num : Positive := 1;
1701 Argv : String_Access;
1703 procedure Remove_Switch (Num : Positive);
1704 -- Remove a project related switch from table Last_Switches
1710 procedure Remove_Switch (Num : Positive) is
1712 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1713 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1714 Last_Switches.Decrement_Last;
1717 -- Start of processing for Inspect_Switches
1720 while Arg_Num <= Last_Switches.Last loop
1721 Argv := Last_Switches.Table (Arg_Num);
1723 if Argv (Argv'First) = '-' then
1724 if Argv'Length = 1 then
1726 ("switch character cannot be followed by a blank");
1729 -- The two style project files (-p and -P) cannot be used
1732 if (The_Command = Find or else The_Command = Xref)
1733 and then Argv (2) = 'p
'
1735 Old_Project_File_Used := True;
1736 if Project_File /= null then
1737 Fail ("-P and -p cannot be used together");
1741 -- --subdirs=... Specify Subdirs
1743 if Argv'Length > Makeutl.Subdirs_Option'Length
1747 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1748 Makeutl.Subdirs_Option
1753 (Argv
'First + Makeutl
.Subdirs_Option
'Length ..
1756 Remove_Switch
(Arg_Num
);
1758 -- -aPdir Add dir to the project search path
1760 elsif Argv
'Length > 3
1761 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "aP"
1763 Prj
.Env
.Add_Directories
1764 (Root_Environment
.Project_Path
,
1765 Argv
(Argv
'First + 3 .. Argv
'Last));
1767 -- Pass -aPdir to gnatls, but not to other tools
1769 if The_Command
= List
then
1770 Arg_Num
:= Arg_Num
+ 1;
1772 Remove_Switch
(Arg_Num
);
1775 -- -eL Follow links for files
1777 elsif Argv
.all = "-eL" then
1778 Follow_Links_For_Files
:= True;
1779 Follow_Links_For_Dirs
:= True;
1781 Remove_Switch
(Arg_Num
);
1783 -- -vPx Specify verbosity while parsing project files
1785 elsif Argv
'Length >= 3
1786 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "vP"
1789 and then Argv
(Argv
'Last) in '0' .. '2'
1791 case Argv
(Argv
'Last) is
1793 Current_Verbosity
:= Prj
.Default
;
1795 Current_Verbosity
:= Prj
.Medium
;
1797 Current_Verbosity
:= Prj
.High
;
1802 raise Program_Error
;
1805 Fail
("invalid verbosity level: "
1806 & Argv
(Argv
'First + 3 .. Argv
'Last));
1809 Remove_Switch
(Arg_Num
);
1811 -- -Pproject_file Specify project file to be used
1813 elsif Argv
(Argv
'First + 1) = 'P' then
1815 -- Only one -P switch can be used
1817 if Project_File
/= null then
1820 & ": second project file forbidden (first is """
1824 -- The two style project files (-p and -P) cannot be
1827 elsif Old_Project_File_Used
then
1828 Fail
("-p and -P cannot be used together");
1830 elsif Argv
'Length = 2 then
1832 -- There is space between -P and the project file
1833 -- name. -P cannot be the last option.
1835 if Arg_Num
= Last_Switches
.Last
then
1836 Fail
("project file name missing after -P");
1839 Remove_Switch
(Arg_Num
);
1840 Argv
:= Last_Switches
.Table
(Arg_Num
);
1842 -- After -P, there must be a project file name,
1843 -- not another switch.
1845 if Argv
(Argv
'First) = '-' then
1846 Fail
("project file name missing after -P");
1849 Project_File
:= new String'(Argv.all);
1854 -- No space between -P and project file name
1857 new String'(Argv
(Argv
'First + 2 .. Argv
'Last));
1860 Remove_Switch
(Arg_Num
);
1862 -- -Xexternal=value Specify an external reference to be
1863 -- used in project files
1865 elsif Argv
'Length >= 5
1866 and then Argv
(Argv
'First + 1) = 'X'
1868 if not Check
(Root_Environment
.External
,
1869 Argv
(Argv
'First + 2 .. Argv
'Last))
1872 & " is not a valid external assignment.");
1875 Remove_Switch
(Arg_Num
);
1878 (The_Command
= Check
or else
1879 The_Command
= Sync
or else
1880 The_Command
= Pretty
or else
1881 The_Command
= Metric
or else
1882 The_Command
= Stack
or else
1884 and then Argv
'Length = 2
1885 and then Argv
(2) = 'U'
1887 All_Projects
:= True;
1888 Remove_Switch
(Arg_Num
);
1891 Arg_Num
:= Arg_Num
+ 1;
1894 elsif ((The_Command
= Check
and then Argv
(Argv
'First) /= '+')
1895 or else The_Command
= Sync
1896 or else The_Command
= Metric
1897 or else The_Command
= Pretty
)
1898 and then Project_File
/= null
1899 and then All_Projects
1901 if ASIS_Main
/= null then
1902 Fail
("cannot specify more than one main after -U");
1905 Remove_Switch
(Arg_Num
);
1909 Arg_Num
:= Arg_Num
+ 1;
1912 end Inspect_Switches
;
1915 -- Add the default project search directories now, after the directories
1916 -- that have been specified by switches -aP<dir>.
1918 Prj
.Env
.Initialize_Default_Project_Path
1919 (Root_Environment
.Project_Path
,
1920 Target_Name
=> Sdefault
.Target_Name
.all);
1922 -- If there is a project file specified, parse it, get the switches
1923 -- for the tool and setup PATH environment variables.
1925 if Project_File
/= null then
1926 Prj
.Pars
.Set_Verbosity
(To
=> Current_Verbosity
);
1929 (Project
=> Project
,
1930 In_Tree
=> Project_Tree
,
1931 In_Node_Tree
=> Project_Node_Tree
,
1932 Project_File_Name
=> Project_File
.all,
1933 Env
=> Root_Environment
,
1934 Packages_To_Check
=> Packages_To_Check
);
1936 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1940 if Project
= Prj
.No_Project
then
1941 Fail
("""" & Project_File
.all & """ processing failed");
1944 -- Check if a package with the name of the tool is in the project
1945 -- file and if there is one, get the switches, if any, and scan them.
1948 Pkg
: constant Prj
.Package_Id
:=
1950 (Name
=> Tool_Package_Name
,
1951 In_Packages
=> Project
.Decl
.Packages
,
1952 Shared
=> Project_Tree
.Shared
);
1954 Element
: Package_Element
;
1956 Switches_Array
: Array_Element_Id
;
1958 The_Switches
: Prj
.Variable_Value
;
1959 Current
: Prj
.String_List_Id
;
1960 The_String
: String_Element
;
1962 Main
: String_Access
:= null;
1965 if Pkg
/= No_Package
then
1966 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
1968 -- Packages Gnatls and Gnatstack have a single attribute
1969 -- Switches, that is not an associative array.
1971 if The_Command
= List
or else The_Command
= Stack
then
1974 (Variable_Name
=> Snames
.Name_Switches
,
1975 In_Variables
=> Element
.Decl
.Attributes
,
1976 Shared
=> Project_Tree
.Shared
);
1978 -- Packages Binder (for gnatbind), Cross_Reference (for
1979 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1980 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1981 -- (for gnatcheck), and Metric (for gnatmetric) have an
1982 -- attributed Switches, an associative array, indexed by the
1983 -- name of the file.
1985 -- They also have an attribute Default_Switches, indexed by the
1986 -- name of the programming language.
1989 -- First check if there is a single main
1991 for J
in 1 .. Last_Switches
.Last
loop
1992 if Last_Switches
.Table
(J
) (1) /= '-' then
1994 Main
:= Last_Switches
.Table
(J
);
2003 if Main
/= null then
2006 (Name
=> Name_Switches
,
2007 In_Arrays
=> Element
.Decl
.Arrays
,
2008 Shared
=> Project_Tree
.Shared
);
2011 -- If the single main has been specified as an absolute
2012 -- path, use only the simple file name. If the absolute
2013 -- path is incorrect, an error will be reported by the
2014 -- underlying tool and it does not make a difference
2015 -- what switches are used.
2017 if Is_Absolute_Path
(Main
.all) then
2018 Add_Str_To_Name_Buffer
(File_Name
(Main
.all));
2020 Add_Str_To_Name_Buffer
(Main
.all);
2023 The_Switches
:= Prj
.Util
.Value_Of
2024 (Index
=> Name_Find
,
2026 In_Array
=> Switches_Array
,
2027 Shared
=> Project_Tree
.Shared
);
2030 if The_Switches
.Kind
= Prj
.Undefined
then
2033 (Name
=> Name_Default_Switches
,
2034 In_Arrays
=> Element
.Decl
.Arrays
,
2035 Shared
=> Project_Tree
.Shared
);
2036 The_Switches
:= Prj
.Util
.Value_Of
2039 In_Array
=> Switches_Array
,
2040 Shared
=> Project_Tree
.Shared
);
2044 -- If there are switches specified in the package of the
2045 -- project file corresponding to the tool, scan them.
2047 case The_Switches
.Kind
is
2048 when Prj
.Undefined
=>
2053 Switch
: constant String :=
2054 Get_Name_String
(The_Switches
.Value
);
2057 if Switch
'Length > 0 then
2058 First_Switches
.Increment_Last
;
2059 First_Switches
.Table
(First_Switches
.Last
) :=
2060 new String'(Switch);
2065 Current := The_Switches.Values;
2066 while Current /= Prj.Nil_String loop
2067 The_String := Project_Tree.Shared.String_Elements.
2071 Switch : constant String :=
2072 Get_Name_String (The_String.Value);
2075 if Switch'Length > 0 then
2076 First_Switches.Increment_Last;
2077 First_Switches.Table (First_Switches.Last) :=
2078 new String'(Switch
);
2082 Current
:= The_String
.Next
;
2088 if The_Command
= Bind
2089 or else The_Command
= Link
2090 or else The_Command
= Elim
2092 if Project
.Object_Directory
.Name
= No_Path
then
2093 Fail
("project " & Get_Name_String
(Project
.Display_Name
) &
2094 " has no object directory");
2097 Change_Dir
(Get_Name_String
(Project
.Object_Directory
.Name
));
2100 -- Set up the env vars for project path files
2102 Prj
.Env
.Set_Ada_Paths
2103 (Project
, Project_Tree
, Including_Libraries
=> False);
2105 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2106 -- a configuration pragmas file, if necessary.
2108 if The_Command
= Pretty
2109 or else The_Command
= Metric
2110 or else The_Command
= Stub
2111 or else The_Command
= Elim
2112 or else The_Command
= Check
2113 or else The_Command
= Sync
2115 -- If there are switches in package Compiler, put them in the
2116 -- Carg_Switches table.
2119 Pkg
: constant Prj
.Package_Id
:=
2121 (Name
=> Name_Compiler
,
2122 In_Packages
=> Project
.Decl
.Packages
,
2123 Shared
=> Project_Tree
.Shared
);
2125 Element
: Package_Element
;
2127 Switches_Array
: Array_Element_Id
;
2129 The_Switches
: Prj
.Variable_Value
;
2130 Current
: Prj
.String_List_Id
;
2131 The_String
: String_Element
;
2133 Main
: String_Access
:= null;
2137 if Pkg
/= No_Package
then
2139 -- First, check if there is a single main specified
2141 for J
in 1 .. Last_Switches
.Last
loop
2142 if Last_Switches
.Table
(J
) (1) /= '-' then
2144 Main
:= Last_Switches
.Table
(J
);
2153 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
2155 -- If there is a single main and there is compilation
2156 -- switches specified in the project file, use them.
2158 if Main
/= null and then not All_Projects
then
2159 Name_Len
:= Main
'Length;
2160 Name_Buffer
(1 .. Name_Len
) := Main
.all;
2161 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2162 Main_Id
:= Name_Find
;
2166 (Name
=> Name_Switches
,
2167 In_Arrays
=> Element
.Decl
.Arrays
,
2168 Shared
=> Project_Tree
.Shared
);
2169 The_Switches
:= Prj
.Util
.Value_Of
2172 In_Array
=> Switches_Array
,
2173 Shared
=> Project_Tree
.Shared
);
2176 -- Otherwise, get the Default_Switches ("Ada")
2178 if The_Switches
.Kind
= Undefined
then
2181 (Name
=> Name_Default_Switches
,
2182 In_Arrays
=> Element
.Decl
.Arrays
,
2183 Shared
=> Project_Tree
.Shared
);
2184 The_Switches
:= Prj
.Util
.Value_Of
2187 In_Array
=> Switches_Array
,
2188 Shared
=> Project_Tree
.Shared
);
2191 -- If there are switches specified, put them in the
2192 -- Carg_Switches table.
2194 case The_Switches
.Kind
is
2195 when Prj
.Undefined
=>
2200 Switch
: constant String :=
2201 Get_Name_String
(The_Switches
.Value
);
2203 if Switch
'Length > 0 then
2204 Add_To_Carg_Switches
(new String'(Switch));
2209 Current := The_Switches.Values;
2210 while Current /= Prj.Nil_String loop
2211 The_String := Project_Tree.Shared.String_Elements
2215 Switch : constant String :=
2216 Get_Name_String (The_String.Value);
2218 if Switch'Length > 0 then
2219 Add_To_Carg_Switches (new String'(Switch
));
2223 Current
:= The_String
.Next
;
2229 -- If -cargs is one of the switches, move the following switches
2230 -- to the Carg_Switches table.
2232 for J
in 1 .. First_Switches
.Last
loop
2233 if First_Switches
.Table
(J
).all = "-cargs" then
2239 -- Move the switches that are before -rules when the
2240 -- command is CHECK.
2243 while K
<= First_Switches
.Last
2245 (The_Command
/= Check
2246 or else First_Switches
.Table
(K
).all /= "-rules")
2248 Add_To_Carg_Switches
(First_Switches
.Table
(K
));
2252 if K
> First_Switches
.Last
then
2253 First_Switches
.Set_Last
(J
- 1);
2257 while K
<= First_Switches
.Last
loop
2259 First_Switches
.Table
(Last
) :=
2260 First_Switches
.Table
(K
);
2264 First_Switches
.Set_Last
(Last
);
2272 for J
in 1 .. Last_Switches
.Last
loop
2273 if Last_Switches
.Table
(J
).all = "-cargs" then
2279 -- Move the switches that are before -rules when the
2280 -- command is CHECK.
2283 while K
<= Last_Switches
.Last
2285 (The_Command
/= Check
2286 or else Last_Switches
.Table
(K
).all /= "-rules")
2288 Add_To_Carg_Switches
(Last_Switches
.Table
(K
));
2292 if K
> Last_Switches
.Last
then
2293 Last_Switches
.Set_Last
(J
- 1);
2297 while K
<= Last_Switches
.Last
loop
2299 Last_Switches
.Table
(Last
) :=
2300 Last_Switches
.Table
(K
);
2304 Last_Switches
.Set_Last
(Last
);
2313 CP_File
: constant Path_Name_Type
:= Configuration_Pragmas_File
;
2314 M_File
: constant Path_Name_Type
:= Mapping_File
;
2317 if CP_File
/= No_Path
then
2318 if The_Command
= Elim
then
2319 First_Switches
.Increment_Last
;
2320 First_Switches
.Table
(First_Switches
.Last
) :=
2321 new String'("-C" & Get_Name_String (CP_File));
2324 Add_To_Carg_Switches
2325 (new String'("-gnatec=" & Get_Name_String
(CP_File
)));
2329 if M_File
/= No_Path
then
2330 Add_To_Carg_Switches
2331 (new String'("-gnatem=" & Get_Name_String (M_File)));
2334 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2335 -- indicate a global configuration pragmas file and, if -U
2336 -- is not used, a local one.
2338 if The_Command = Check or else
2339 The_Command = Pretty or else
2340 The_Command = Stub or else
2341 The_Command = Metric
2344 Pkg : constant Prj.Package_Id :=
2346 (Name => Name_Builder,
2347 In_Packages => Project.Decl.Packages,
2348 Shared => Project_Tree.Shared);
2350 Variable : Variable_Value :=
2353 Attribute_Or_Array_Name =>
2354 Name_Global_Configuration_Pragmas,
2356 Shared => Project_Tree.Shared);
2359 if (Variable = Nil_Variable_Value
2360 or else Length_Of_Name (Variable.Value) = 0)
2361 and then Pkg /= No_Package
2366 Attribute_Or_Array_Name =>
2367 Name_Global_Config_File,
2369 Shared => Project_Tree.Shared);
2372 if Variable /= Nil_Variable_Value
2373 and then Length_Of_Name (Variable.Value) /= 0
2376 Path : constant String :=
2378 (Path_Name_Type (Variable.Value),
2381 Add_To_Carg_Switches
2382 (new String'("-gnatec=" & Path
));
2387 if not All_Projects
then
2389 Pkg
: constant Prj
.Package_Id
:=
2391 (Name
=> Name_Compiler
,
2392 In_Packages
=> Project
.Decl
.Packages
,
2393 Shared
=> Project_Tree
.Shared
);
2395 Variable
: Variable_Value
:=
2398 Attribute_Or_Array_Name
=>
2399 Name_Local_Configuration_Pragmas
,
2401 Shared
=> Project_Tree
.Shared
);
2404 if (Variable
= Nil_Variable_Value
2405 or else Length_Of_Name
(Variable
.Value
) = 0)
2406 and then Pkg
/= No_Package
2411 Attribute_Or_Array_Name
=>
2412 Name_Local_Config_File
,
2415 Project_Tree
.Shared
);
2418 if Variable
/= Nil_Variable_Value
2419 and then Length_Of_Name
(Variable
.Value
) /= 0
2422 Path
: constant String :=
2424 (Path_Name_Type
(Variable
.Value
),
2427 Add_To_Carg_Switches
2428 (new String'("-gnatec=" & Path));
2437 if The_Command = Link then
2441 if The_Command = Link or else The_Command = Bind then
2443 -- For files that are specified as relative paths with directory
2444 -- information, we convert them to absolute paths, with parent
2445 -- being the current working directory if specified on the command
2446 -- line and the project directory if specified in the project
2447 -- file. This is what gnatmake is doing for linker and binder
2450 for J in 1 .. Last_Switches.Last loop
2451 GNATCmd.Ensure_Absolute_Path
2452 (Last_Switches.Table (J), Current_Work_Dir);
2455 Get_Name_String (Project.Directory.Name);
2458 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2460 for J in 1 .. First_Switches.Last loop
2461 GNATCmd.Ensure_Absolute_Path
2462 (First_Switches.Table (J), Project_Dir);
2466 elsif The_Command = Stub then
2468 File_Index : Integer := 0;
2469 Dir_Index : Integer := 0;
2470 Last : constant Integer := Last_Switches.Last;
2471 Lang : constant Language_Ptr :=
2472 Get_Language_From_Name (Project, "ada");
2475 for Index in 1 .. Last loop
2476 if Last_Switches.Table (Index)
2477 (Last_Switches.Table (Index)'First) /= '-'
2479 File_Index := Index;
2484 -- If the project file naming scheme is not standard, and if
2485 -- the file name ends with the spec suffix, then indicate to
2486 -- gnatstub the name of the body file with a -o switch.
2488 if Lang /= No_Language_Index
2489 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data)
2491 if File_Index /= 0 then
2493 Spec : constant String :=
2495 (Last_Switches.Table (File_Index).all);
2496 Last : Natural := Spec'Last;
2499 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2501 if Spec'Length > Name_Len
2502 and then Spec (Last - Name_Len + 1 .. Last) =
2503 Name_Buffer (1 .. Name_Len)
2505 Last := Last - Name_Len;
2507 (Lang.Config.Naming_Data.Body_Suffix);
2508 Last_Switches.Increment_Last;
2509 Last_Switches.Table (Last_Switches.Last) :=
2511 Last_Switches
.Increment_Last
;
2512 Last_Switches
.Table
(Last_Switches
.Last
) :=
2513 new String'(Spec (Spec'First .. Last) &
2514 Name_Buffer (1 .. Name_Len));
2520 -- Add the directory of the spec as the destination directory
2521 -- of the body, if there is no destination directory already
2524 if File_Index /= 0 then
2525 for Index in File_Index + 1 .. Last loop
2526 if Last_Switches.Table (Index)
2527 (Last_Switches.Table (Index)'First) /= '-'
2534 if Dir_Index = 0 then
2535 Last_Switches.Increment_Last;
2536 Last_Switches.Table (Last_Switches.Last) :=
2538 (Dir_Name
(Last_Switches
.Table
(File_Index
).all));
2544 -- For gnatmetric, the generated files should be put in the object
2545 -- directory. This must be the first switch, because it may be
2546 -- overridden by a switch in package Metrics in the project file or
2547 -- by a command line option. Note that we don't add the -d= switch
2548 -- if there is no object directory available.
2550 if The_Command
= Metric
2551 and then Project
.Object_Directory
/= No_Path_Information
2553 First_Switches
.Increment_Last
;
2554 First_Switches
.Table
(2 .. First_Switches
.Last
) :=
2555 First_Switches
.Table
(1 .. First_Switches
.Last
- 1);
2556 First_Switches
.Table
(1) :=
2558 Get_Name_String (Project.Object_Directory.Name));
2561 -- For gnat check, -rules and the following switches need to be the
2562 -- last options, so move all these switches to table Rules_Switches.
2564 if The_Command = Check then
2567 -- Set to rank of options preceding "-rules"
2569 In_Rules_Switches : Boolean;
2570 -- Set to True when options "-rules" is found
2573 New_Last := First_Switches.Last;
2574 In_Rules_Switches := False;
2576 for J in 1 .. First_Switches.Last loop
2577 if In_Rules_Switches then
2578 Add_To_Rules_Switches (First_Switches.Table (J));
2580 elsif First_Switches.Table (J).all = "-rules" then
2582 In_Rules_Switches := True;
2586 if In_Rules_Switches then
2587 First_Switches.Set_Last (New_Last);
2590 New_Last := Last_Switches.Last;
2591 In_Rules_Switches := False;
2593 for J in 1 .. Last_Switches.Last loop
2594 if In_Rules_Switches then
2595 Add_To_Rules_Switches (Last_Switches.Table (J));
2597 elsif Last_Switches.Table (J).all = "-rules" then
2599 In_Rules_Switches := True;
2603 if In_Rules_Switches then
2604 Last_Switches.Set_Last (New_Last);
2609 -- For gnat check, sync, metric or pretty with -U + a main, get the
2610 -- list of sources from the closure and add them to the arguments.
2612 if ASIS_Main /= null then
2615 -- On VMS, set up the env var again for source dirs file. This is
2616 -- because the call to gnatmake has set this env var to another
2617 -- file that has now been deleted.
2619 if Hostparm.OpenVMS then
2621 -- First make sure that the recorded file names are empty
2623 Prj.Env.Initialize (Project_Tree);
2625 Prj.Env.Set_Ada_Paths
2626 (Project, Project_Tree, Including_Libraries => False);
2629 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2630 -- and gnat stack, if no file has been put on the command line, call
2631 -- tool with all the sources of the main project.
2633 elsif The_Command = Check or else
2634 The_Command = Sync or else
2635 The_Command = Pretty or else
2636 The_Command = Metric or else
2637 The_Command = List or else
2644 -- Gather all the arguments and invoke the executable
2647 The_Args : Argument_List
2648 (1 .. First_Switches.Last +
2649 Last_Switches.Last +
2650 Carg_Switches.Last +
2651 Rules_Switches.Last);
2652 Arg_Num : Natural := 0;
2655 for J in 1 .. First_Switches.Last loop
2656 Arg_Num := Arg_Num + 1;
2657 The_Args (Arg_Num) := First_Switches.Table (J);
2660 for J in 1 .. Last_Switches.Last loop
2661 Arg_Num := Arg_Num + 1;
2662 The_Args (Arg_Num) := Last_Switches.Table (J);
2665 for J in 1 .. Carg_Switches.Last loop
2666 Arg_Num := Arg_Num + 1;
2667 The_Args (Arg_Num) := Carg_Switches.Table (J);
2670 for J in 1 .. Rules_Switches.Last loop
2671 Arg_Num := Arg_Num + 1;
2672 The_Args (Arg_Num) := Rules_Switches.Table (J);
2675 -- If Display_Command is on, only display the generated command
2677 if Display_Command then
2678 Put (Standard_Error, "generated command -->");
2679 Put (Standard_Error, Exec_Path.all);
2681 for Arg in The_Args'Range loop
2682 Put (Standard_Error, " ");
2683 Put (Standard_Error, The_Args (Arg).all);
2686 Put (Standard_Error, "<--");
2687 New_Line (Standard_Error);
2691 if Verbose_Mode then
2692 Output.Write_Str (Exec_Path.all);
2694 for Arg in The_Args'Range loop
2695 Output.Write_Char (' ');
2696 Output.Write_Str (The_Args (Arg).all);
2703 Exit_Status (Spawn (Exec_Path.all, The_Args));
2710 if not Keep_Temporary_Files then
2711 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2712 Delete_Temp_Config_Files;
2715 Set_Exit_Status (Failure);
2718 if not Keep_Temporary_Files then
2719 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2720 Delete_Temp_Config_Files;
2723 -- Since GNATCmd is normally called from DCL (the VMS shell), it must
2724 -- return an understandable VMS exit status. However the exit status
2725 -- returned *to* GNATCmd is a Posix style code, so we test it and return
2726 -- just a simple success or failure on VMS.
2728 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
2729 Set_Exit_Status (Failure);
2731 Set_Exit_Status (My_Exit_Status);