1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2012, 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 Root_Environment
: Prj
.Tree
.Environment
;
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
411 -- the path names of all the sources of the main project.
415 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file
416 -- and put the list of sources in it. For gnatstack create a
417 -- temporary 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
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
);
556 Last_Switches
.Increment_Last
;
557 Last_Switches
.Table
(Last_Switches
.Last
) :=
561 (Impl).Display_File));
565 elsif Unit.File_Names (Spec) /= null
566 and then not Unit.File_Names (Spec).Locally_Removed
568 -- We have a spec with no body. Check if it is for this
571 if All_Projects or else
572 Unit.File_Names (Spec).Project = Project
574 Last_Switches.Increment_Last;
575 Last_Switches.Table (Last_Switches.Last) :=
576 new String'(Get_Name_String
577 (Unit
.File_Names
(Spec
).Display_File
));
581 -- For gnatstack, we put the .ci files corresponding to the
582 -- different units, including the binder generated files. We
583 -- only need to do that for the library units, body or spec,
584 -- but not the subunits.
586 elsif The_Command
= Stack
then
587 if Unit
.File_Names
(Impl
) /= null
588 and then not Unit
.File_Names
(Impl
).Locally_Removed
590 -- There is a body. Check if .ci files for this project
594 (Unit
.File_Names
(Impl
).Project
, Project
)
598 if Unit
.File_Names
(Spec
) = null
599 or else Unit
.File_Names
(Spec
).Locally_Removed
601 -- We have a body with no spec: we need to check
602 -- if this is a subunit, because .ci files are not
603 -- generated for subunits.
606 Src_Ind
: constant Source_File_Index
:=
607 Sinput
.P
.Load_Project_File
613 Sinput
.P
.Source_File_Is_Subunit
(Src_Ind
);
621 (Impl
).Project
. Object_Directory
.Name
) &
624 (Unit
.File_Names
(Impl
).Display_File
),
629 elsif Unit
.File_Names
(Spec
) /= null
630 and then not Unit
.File_Names
(Spec
).Locally_Removed
632 -- Spec with no body, check if it is for this project
635 (Unit
.File_Names
(Spec
).Project
, Project
)
640 (Spec
).Project
. Object_Directory
.Name
) &
643 (Get_Name_String
(Unit
.File_Names
(Spec
).File
),
649 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
650 -- sources of the project, or of all projects if -U was
653 for Kind
in Spec_Or_Body
loop
654 if Unit
.File_Names
(Kind
) /= null
655 and then Check_Project
656 (Unit
.File_Names
(Kind
).Project
, Project
)
657 and then not Unit
.File_Names
(Kind
).Locally_Removed
662 (Unit
.File_Names
(Kind
).Path
.Display_Name
) &
664 Check_File
=> False);
669 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
673 if FD
/= Invalid_FD
then
677 Osint
.Fail
("disk full");
687 function Check_Project
688 (Project
: Project_Id
;
689 Root_Project
: Project_Id
) return Boolean
694 if Project
= No_Project
then
697 elsif All_Projects
or else Project
= Root_Project
then
700 elsif The_Command
= Metric
then
701 Proj
:= Root_Project
;
702 while Proj
.Extends
/= No_Project
loop
703 if Project
= Proj
.Extends
then
707 Proj
:= Proj
.Extends
;
714 -------------------------------
715 -- Check_Relative_Executable --
716 -------------------------------
718 procedure Check_Relative_Executable
(Name
: in out String_Access
) is
719 Exec_File_Name
: constant String := Name
.all;
722 if not Is_Absolute_Path
(Exec_File_Name
) then
723 for Index
in Exec_File_Name
'Range loop
724 if Exec_File_Name
(Index
) = Directory_Separator
then
725 Fail
("relative executable (""" &
727 """) with directory part not allowed " &
728 "when using project files");
732 Get_Name_String
(Project
.Exec_Directory
.Name
);
734 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
735 Name_Len
:= Name_Len
+ 1;
736 Name_Buffer
(Name_Len
) := Directory_Separator
;
739 Name_Buffer
(Name_Len
+ 1 ..
740 Name_Len
+ Exec_File_Name
'Length) :=
742 Name_Len
:= Name_Len
+ Exec_File_Name
'Length;
743 Name
:= new String'(Name_Buffer (1 .. Name_Len));
745 end Check_Relative_Executable;
747 --------------------------------
748 -- Configuration_Pragmas_File --
749 --------------------------------
751 function Configuration_Pragmas_File return Path_Name_Type is
753 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
754 return Project.Config_File_Name;
755 end Configuration_Pragmas_File;
757 ------------------------------
758 -- Delete_Temp_Config_Files --
759 ------------------------------
761 procedure Delete_Temp_Config_Files is
764 pragma Warnings (Off, Success);
767 -- This should only be called if Keep_Temporary_Files is False
769 pragma Assert (not Keep_Temporary_Files);
771 if Project /= No_Project then
772 Proj := Project_Tree.Projects;
773 while Proj /= null loop
774 if Proj.Project.Config_File_Temp then
775 Delete_Temporary_File
776 (Project_Tree.Shared, Proj.Project.Config_File_Name);
783 -- If a temporary text file that contains a list of files for a tool
784 -- has been created, delete this temporary file.
786 if Temp_File_Name /= No_Path then
787 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
789 end Delete_Temp_Config_Files;
791 ---------------------------
792 -- Ensure_Absolute_Path --
793 ---------------------------
795 procedure Ensure_Absolute_Path
796 (Switch : in out String_Access;
800 Makeutl.Ensure_Absolute_Path
802 Do_Fail => Osint.Fail'Access,
803 Including_Non_Switch => False,
804 Including_RTS => True);
805 end Ensure_Absolute_Path;
811 procedure Get_Closure is
812 Args : constant Argument_List :=
813 (1 => new String'("-q"),
814 2 => new String'("-b"),
815 3 => new String'("-P"),
818 6 => new String'("-bargs"),
819 7 => new String'("-R"),
820 8 => new String'("-Z"));
821 -- Arguments for the invocation of gnatmake which are added to the
822 -- Last_Arguments list by this procedure.
824 FD : File_Descriptor;
825 -- File descriptor for the temp file that will get the output of the
826 -- invocation of gnatmake.
828 Name : Path_Name_Type;
829 -- Path of the file FD
831 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
834 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
837 Return_Code : Integer;
840 pragma Warnings (Off, Unused);
842 File : Ada.Text_IO.File_Type;
843 Line : String (1 .. 250);
845 -- Used to read file if there is an error, it is good enough to display
846 -- just 250 characters if the first line of the file is very long.
849 Path : Path_Name_Type;
851 Files_File : Ada.Text_IO.File_Type;
852 Temp_File_Name : Path_Name_Type;
855 if GN_Path = null then
856 Put_Line (Standard_Error, "could not locate " & GN_Name);
860 -- Create the temp file
862 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
864 -- And close it, because on VMS Spawn with a file descriptor created
865 -- with Create_Temp_File does not redirect output.
869 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
872 (Program_Name => GN_Path.all,
874 Output_File => Get_Name_String (Name),
876 Return_Code => Return_Code,
879 -- Read the output of the invocation of gnatmake
881 Open (File, In_File, Get_Name_String (Name));
883 -- If it was unsuccessful, display the first line in the file and exit
886 if Return_Code /= 0 then
887 Get_Line (File, Line, Last);
890 if not Keep_Temporary_Files then
896 -- Don't crash if it is not possible to delete or close the file,
897 -- just ignore the situation.
904 Put_Line (Standard_Error, Line (1 .. Last));
906 (Standard_Error, "could not get closure of " & ASIS_Main.all);
910 -- Create a temporary file to put the list of files in the closure
912 Tempdir.Create_Temp_File (FD, Temp_File_Name);
913 Last_Switches.Increment_Last;
914 Last_Switches.Table (Last_Switches.Last) :=
915 new String'("-files=" & Get_Name_String
(Temp_File_Name
));
919 Open
(Files_File
, Out_File
, Get_Name_String
(Temp_File_Name
));
921 -- Get each file name in the file, find its path and add it the list
924 while not End_Of_File
(File
) loop
925 Get_Line
(File
, Line
, Last
);
928 Unit
:= Units_Htable
.Get_First
(Project_Tree
.Units_HT
);
929 while Unit
/= No_Unit_Index
loop
930 if Unit
.File_Names
(Spec
) /= null
932 Get_Name_String
(Unit
.File_Names
(Spec
).File
) =
935 Path
:= Unit
.File_Names
(Spec
).Path
.Name
;
938 elsif Unit
.File_Names
(Impl
) /= null
940 Get_Name_String
(Unit
.File_Names
(Impl
).File
) =
943 Path
:= Unit
.File_Names
(Impl
).Path
.Name
;
947 Unit
:= Units_Htable
.Get_Next
(Project_Tree
.Units_HT
);
950 if Path
/= No_Path
then
951 Put_Line
(Files_File
, Get_Name_String
(Path
));
954 Put_Line
(Files_File
, Line
(1 .. Last
));
961 if not Keep_Temporary_Files
then
967 -- Don't crash if it is not possible to delete or close the file,
968 -- just ignore the situation.
981 function Mapping_File
return Path_Name_Type
is
982 Result
: Path_Name_Type
;
984 Prj
.Env
.Create_Mapping_File
986 Language
=> Name_Ada
,
987 In_Tree
=> Project_Tree
,
996 procedure Non_VMS_Usage
is
1000 Put_Line
("List of available commands");
1003 for C
in Command_List
'Range loop
1005 -- No usage for VMS only command or for Sync
1007 if not Command_List
(C
).VMS_Only
and then C
/= Sync
then
1008 if Targparm
.AAMP_On_Target
then
1014 Put
(To_Lower
(Command_List
(C
).Cname
.all));
1017 -- Never call gnatstack with a prefix
1020 Put
(Command_List
(C
).Unixcmd
.all);
1022 Put
(Program_Name
(Command_List
(C
).Unixcmd
.all, "gnat").all);
1026 Sws
: Argument_List_Access
renames Command_List
(C
).Unixsws
;
1029 for J
in Sws
'Range loop
1041 Put_Line
("All commands except chop, krunch and preprocess " &
1042 "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
1397 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1398 Prj.Env.Initialize_Default_Project_Path
1399 (Root_Environment.Project_Path,
1400 Target_Name => Sdefault.Target_Name.all);
1402 Project_Node_Tree := new Project_Node_Tree_Data;
1403 Prj.Tree.Initialize (Project_Node_Tree);
1405 Prj.Initialize (Project_Tree);
1408 Last_Switches.Set_Last (0);
1410 First_Switches.Init;
1411 First_Switches.Set_Last (0);
1413 Carg_Switches.Set_Last (0);
1414 Rules_Switches.Init;
1415 Rules_Switches.Set_Last (0);
1417 VMS_Conv.Initialize;
1419 -- Add the default search directories, to be able to find system.ads in the
1420 -- subsequent call to Targparm.Get_Target_Parameters.
1422 Add_Default_Search_Dirs;
1424 -- Get target parameters so that AAMP_On_Target will be set, for testing in
1425 -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
1427 Targparm.Get_Target_Parameters;
1429 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1430 -- so that the spawned tool may know the way the GNAT driver was invoked.
1433 Add_Str_To_Name_Buffer (Command_Name);
1435 for J in 1 .. Argument_Count loop
1436 Add_Char_To_Name_Buffer (' ');
1437 Add_Str_To_Name_Buffer (Argument (J));
1440 -- On OpenVMS, setenv creates a logical whose length is limited to
1443 if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
1444 Name_Buffer (Max_OpenVMS_Logical_Length - 2
1445 .. Max_OpenVMS_Logical_Length) := "...";
1446 Name_Len := Max_OpenVMS_Logical_Length;
1449 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1451 -- Add the directory where the GNAT driver is invoked in front of the path,
1452 -- if the GNAT driver is invoked with directory information. Do not do this
1453 -- for VMS, where the notion of path does not really exist.
1457 Command : constant String := Command_Name;
1460 for Index in reverse Command'Range loop
1461 if Command (Index) = Directory_Separator then
1463 Absolute_Dir : constant String :=
1465 (Command (Command'First .. Index));
1467 PATH : constant String :=
1468 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1471 Setenv ("PATH", PATH);
1480 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1481 -- filenames and pathnames to Unix style.
1484 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1486 VMS_Conversion (The_Command);
1488 B_Start := new String'("b__");
1490 -- If not on VMS, scan the command line directly
1493 if Argument_Count
= 0 then
1499 if Argument_Count
> Command_Arg
1500 and then Argument
(Command_Arg
) = "-v"
1502 Verbose_Mode
:= True;
1503 Command_Arg
:= Command_Arg
+ 1;
1505 elsif Argument_Count
> Command_Arg
1506 and then Argument
(Command_Arg
) = "-dn"
1508 Keep_Temporary_Files
:= True;
1509 Command_Arg
:= Command_Arg
+ 1;
1516 The_Command
:= Real_Command_Type
'Value (Argument
(Command_Arg
));
1518 if Command_List
(The_Command
).VMS_Only
then
1522 & Command_List
(The_Command
).Cname
.all
1523 & """ can only be used on VMS");
1527 when Constraint_Error
=>
1529 -- Check if it is an alternate command
1532 Alternate
: Alternate_Command
;
1535 Alternate
:= Alternate_Command
'Value
1536 (Argument
(Command_Arg
));
1537 The_Command
:= Corresponding_To
(Alternate
);
1540 when Constraint_Error
=>
1542 Fail
("Unknown command: " & Argument
(Command_Arg
));
1546 -- Get the arguments from the command line and from the eventual
1547 -- argument file(s) specified on the command line.
1549 for Arg
in Command_Arg
+ 1 .. Argument_Count
loop
1551 The_Arg
: constant String := Argument
(Arg
);
1554 -- Check if an argument file is specified
1556 if The_Arg
(The_Arg
'First) = '@' then
1558 Arg_File
: Ada
.Text_IO
.File_Type
;
1559 Line
: String (1 .. 256);
1563 -- Open the file and fail if the file cannot be found
1568 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1573 (Standard_Error
, "Cannot open argument file """);
1576 The_Arg
(The_Arg
'First + 1 .. The_Arg
'Last));
1578 Put_Line
(Standard_Error
, """");
1582 -- Read line by line and put the content of each non-
1583 -- empty line in the Last_Switches table.
1585 while not End_Of_File
(Arg_File
) loop
1586 Get_Line
(Arg_File
, Line
, Last
);
1589 Last_Switches
.Increment_Last
;
1590 Last_Switches
.Table
(Last_Switches
.Last
) :=
1591 new String'(Line (1 .. Last));
1599 -- It is not an argument file; just put the argument in
1600 -- the Last_Switches table.
1602 Last_Switches.Increment_Last;
1603 Last_Switches.Table (Last_Switches.Last) :=
1604 new String'(The_Arg
);
1612 Program
: String_Access
;
1613 Exec_Path
: String_Access
;
1616 if The_Command
= Stack
then
1618 -- Never call gnatstack with a prefix
1620 Program
:= new String'(Command_List (The_Command).Unixcmd.all);
1624 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1627 -- For the tools where the GNAT driver processes the project files,
1628 -- allow shared library projects to import projects that are not shared
1629 -- library projects, to avoid adding a switch for these tools. For the
1630 -- builder (gnatmake), if a shared library project imports a project
1631 -- that is not a shared library project and the appropriate switch is
1632 -- not specified, the invocation of gnatmake will fail.
1634 Opt.Unchecked_Shared_Lib_Imports := True;
1636 -- Locate the executable for the command
1638 Exec_Path := Locate_Exec_On_Path (Program.all);
1640 if Exec_Path = null then
1641 Put_Line (Standard_Error, "could not locate " & Program.all);
1645 -- If there are switches for the executable, put them as first switches
1647 if Command_List (The_Command).Unixsws /= null then
1648 for J in Command_List (The_Command).Unixsws'Range loop
1649 First_Switches.Increment_Last;
1650 First_Switches.Table (First_Switches.Last) :=
1651 Command_List (The_Command).Unixsws (J);
1655 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1656 -- SYNC and XREF, look for project file related switches.
1660 Tool_Package_Name := Name_Binder;
1661 Packages_To_Check := Packages_To_Check_By_Binder;
1663 Tool_Package_Name := Name_Check;
1664 Packages_To_Check := Packages_To_Check_By_Check;
1666 Tool_Package_Name := Name_Eliminate;
1667 Packages_To_Check := Packages_To_Check_By_Eliminate;
1669 Tool_Package_Name := Name_Finder;
1670 Packages_To_Check := Packages_To_Check_By_Finder;
1672 Tool_Package_Name := Name_Linker;
1673 Packages_To_Check := Packages_To_Check_By_Linker;
1675 Tool_Package_Name := Name_Gnatls;
1676 Packages_To_Check := Packages_To_Check_By_Gnatls;
1678 Tool_Package_Name := Name_Metrics;
1679 Packages_To_Check := Packages_To_Check_By_Metric;
1681 Tool_Package_Name := Name_Pretty_Printer;
1682 Packages_To_Check := Packages_To_Check_By_Pretty;
1684 Tool_Package_Name := Name_Stack;
1685 Packages_To_Check := Packages_To_Check_By_Stack;
1687 Tool_Package_Name := Name_Gnatstub;
1688 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1690 Tool_Package_Name := Name_Synchronize;
1691 Packages_To_Check := Packages_To_Check_By_Sync;
1693 Tool_Package_Name := Name_Cross_Reference;
1694 Packages_To_Check := Packages_To_Check_By_Xref;
1696 Tool_Package_Name := No_Name;
1699 if Tool_Package_Name /= No_Name then
1701 -- Check that the switches are consistent. Detect project file
1702 -- related switches.
1704 Inspect_Switches : declare
1705 Arg_Num : Positive := 1;
1706 Argv : String_Access;
1708 procedure Remove_Switch (Num : Positive);
1709 -- Remove a project related switch from table Last_Switches
1715 procedure Remove_Switch (Num : Positive) is
1717 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1718 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1719 Last_Switches.Decrement_Last;
1722 -- Start of processing for Inspect_Switches
1725 while Arg_Num <= Last_Switches.Last loop
1726 Argv := Last_Switches.Table (Arg_Num);
1728 if Argv (Argv'First) = '-' then
1729 if Argv'Length = 1 then
1731 ("switch character cannot be followed by a blank");
1734 -- The two style project files (-p and -P) cannot be used
1737 if (The_Command = Find or else The_Command = Xref)
1738 and then Argv (2) = 'p
'
1740 Old_Project_File_Used := True;
1741 if Project_File /= null then
1742 Fail ("-P and -p cannot be used together");
1746 -- --subdirs=... Specify Subdirs
1748 if Argv'Length > Makeutl.Subdirs_Option'Length
1752 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1753 Makeutl.Subdirs_Option
1758 (Argv
'First + Makeutl
.Subdirs_Option
'Length ..
1761 Remove_Switch
(Arg_Num
);
1763 -- -aPdir Add dir to the project search path
1765 elsif Argv
'Length > 3
1766 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "aP"
1768 Prj
.Env
.Add_Directories
1769 (Root_Environment
.Project_Path
,
1770 Argv
(Argv
'First + 3 .. Argv
'Last));
1772 Remove_Switch
(Arg_Num
);
1774 -- -eL Follow links for files
1776 elsif Argv
.all = "-eL" then
1777 Follow_Links_For_Files
:= True;
1778 Follow_Links_For_Dirs
:= True;
1780 Remove_Switch
(Arg_Num
);
1782 -- -vPx Specify verbosity while parsing project files
1784 elsif Argv
'Length >= 3
1785 and then Argv
(Argv
'First + 1 .. Argv
'First + 2) = "vP"
1788 and then Argv
(Argv
'Last) in '0' .. '2'
1790 case Argv
(Argv
'Last) is
1792 Current_Verbosity
:= Prj
.Default
;
1794 Current_Verbosity
:= Prj
.Medium
;
1796 Current_Verbosity
:= Prj
.High
;
1801 raise Program_Error
;
1804 Fail
("invalid verbosity level: "
1805 & Argv
(Argv
'First + 3 .. Argv
'Last));
1808 Remove_Switch
(Arg_Num
);
1810 -- -Pproject_file Specify project file to be used
1812 elsif Argv
(Argv
'First + 1) = 'P' then
1814 -- Only one -P switch can be used
1816 if Project_File
/= null then
1819 & ": second project file forbidden (first is """
1823 -- The two style project files (-p and -P) cannot be
1826 elsif Old_Project_File_Used
then
1827 Fail
("-p and -P cannot be used together");
1829 elsif Argv
'Length = 2 then
1831 -- There is space between -P and the project file
1832 -- name. -P cannot be the last option.
1834 if Arg_Num
= Last_Switches
.Last
then
1835 Fail
("project file name missing after -P");
1838 Remove_Switch
(Arg_Num
);
1839 Argv
:= Last_Switches
.Table
(Arg_Num
);
1841 -- After -P, there must be a project file name,
1842 -- not another switch.
1844 if Argv
(Argv
'First) = '-' then
1845 Fail
("project file name missing after -P");
1848 Project_File
:= new String'(Argv.all);
1853 -- No space between -P and project file name
1856 new String'(Argv
(Argv
'First + 2 .. Argv
'Last));
1859 Remove_Switch
(Arg_Num
);
1861 -- -Xexternal=value Specify an external reference to be
1862 -- used in project files
1864 elsif Argv
'Length >= 5
1865 and then Argv
(Argv
'First + 1) = 'X'
1867 if not Check
(Root_Environment
.External
,
1868 Argv
(Argv
'First + 2 .. Argv
'Last))
1871 & " is not a valid external assignment.");
1874 Remove_Switch
(Arg_Num
);
1877 (The_Command
= Check
or else
1878 The_Command
= Sync
or else
1879 The_Command
= Pretty
or else
1880 The_Command
= Metric
or else
1881 The_Command
= Stack
or else
1883 and then Argv
'Length = 2
1884 and then Argv
(2) = 'U'
1886 All_Projects
:= True;
1887 Remove_Switch
(Arg_Num
);
1890 Arg_Num
:= Arg_Num
+ 1;
1893 elsif ((The_Command
= Check
and then Argv
(Argv
'First) /= '+')
1894 or else The_Command
= Sync
1895 or else The_Command
= Metric
1896 or else The_Command
= Pretty
)
1897 and then Project_File
/= null
1898 and then All_Projects
1900 if ASIS_Main
/= null then
1901 Fail
("cannot specify more than one main after -U");
1904 Remove_Switch
(Arg_Num
);
1908 Arg_Num
:= Arg_Num
+ 1;
1911 end Inspect_Switches
;
1914 -- If there is a project file specified, parse it, get the switches
1915 -- for the tool and setup PATH environment variables.
1917 if Project_File
/= null then
1918 Prj
.Pars
.Set_Verbosity
(To
=> Current_Verbosity
);
1921 (Project
=> Project
,
1922 In_Tree
=> Project_Tree
,
1923 In_Node_Tree
=> Project_Node_Tree
,
1924 Project_File_Name
=> Project_File
.all,
1925 Env
=> Root_Environment
,
1926 Packages_To_Check
=> Packages_To_Check
);
1928 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1932 if Project
= Prj
.No_Project
then
1933 Fail
("""" & Project_File
.all & """ processing failed");
1936 -- Check if a package with the name of the tool is in the project
1937 -- file and if there is one, get the switches, if any, and scan them.
1940 Pkg
: constant Prj
.Package_Id
:=
1942 (Name
=> Tool_Package_Name
,
1943 In_Packages
=> Project
.Decl
.Packages
,
1944 Shared
=> Project_Tree
.Shared
);
1946 Element
: Package_Element
;
1948 Switches_Array
: Array_Element_Id
;
1950 The_Switches
: Prj
.Variable_Value
;
1951 Current
: Prj
.String_List_Id
;
1952 The_String
: String_Element
;
1954 Main
: String_Access
:= null;
1957 if Pkg
/= No_Package
then
1958 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
1960 -- Packages Gnatls and Gnatstack have a single attribute
1961 -- Switches, that is not an associative array.
1963 if The_Command
= List
or else The_Command
= Stack
then
1966 (Variable_Name
=> Snames
.Name_Switches
,
1967 In_Variables
=> Element
.Decl
.Attributes
,
1968 Shared
=> Project_Tree
.Shared
);
1970 -- Packages Binder (for gnatbind), Cross_Reference (for
1971 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1972 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1973 -- (for gnatcheck), and Metric (for gnatmetric) have an
1974 -- attributed Switches, an associative array, indexed by the
1975 -- name of the file.
1977 -- They also have an attribute Default_Switches, indexed by the
1978 -- name of the programming language.
1981 -- First check if there is a single main
1983 for J
in 1 .. Last_Switches
.Last
loop
1984 if Last_Switches
.Table
(J
) (1) /= '-' then
1986 Main
:= Last_Switches
.Table
(J
);
1995 if Main
/= null then
1998 (Name
=> Name_Switches
,
1999 In_Arrays
=> Element
.Decl
.Arrays
,
2000 Shared
=> Project_Tree
.Shared
);
2002 Add_Str_To_Name_Buffer
(Main
.all);
2003 The_Switches
:= Prj
.Util
.Value_Of
2004 (Index
=> Name_Find
,
2006 In_Array
=> Switches_Array
,
2007 Shared
=> Project_Tree
.Shared
);
2010 if The_Switches
.Kind
= Prj
.Undefined
then
2013 (Name
=> Name_Default_Switches
,
2014 In_Arrays
=> Element
.Decl
.Arrays
,
2015 Shared
=> Project_Tree
.Shared
);
2016 The_Switches
:= Prj
.Util
.Value_Of
2019 In_Array
=> Switches_Array
,
2020 Shared
=> Project_Tree
.Shared
);
2024 -- If there are switches specified in the package of the
2025 -- project file corresponding to the tool, scan them.
2027 case The_Switches
.Kind
is
2028 when Prj
.Undefined
=>
2033 Switch
: constant String :=
2034 Get_Name_String
(The_Switches
.Value
);
2037 if Switch
'Length > 0 then
2038 First_Switches
.Increment_Last
;
2039 First_Switches
.Table
(First_Switches
.Last
) :=
2040 new String'(Switch);
2045 Current := The_Switches.Values;
2046 while Current /= Prj.Nil_String loop
2047 The_String := Project_Tree.Shared.String_Elements.
2051 Switch : constant String :=
2052 Get_Name_String (The_String.Value);
2055 if Switch'Length > 0 then
2056 First_Switches.Increment_Last;
2057 First_Switches.Table (First_Switches.Last) :=
2058 new String'(Switch
);
2062 Current
:= The_String
.Next
;
2068 if The_Command
= Bind
2069 or else The_Command
= Link
2070 or else The_Command
= Elim
2072 if Project
.Object_Directory
.Name
= No_Path
then
2073 Fail
("project " & Get_Name_String
(Project
.Display_Name
) &
2074 " has no object directory");
2077 Change_Dir
(Get_Name_String
(Project
.Object_Directory
.Name
));
2080 -- Set up the env vars for project path files
2082 Prj
.Env
.Set_Ada_Paths
2083 (Project
, Project_Tree
, Including_Libraries
=> False);
2085 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2086 -- a configuration pragmas file, if necessary.
2088 if The_Command
= Pretty
2089 or else The_Command
= Metric
2090 or else The_Command
= Stub
2091 or else The_Command
= Elim
2092 or else The_Command
= Check
2093 or else The_Command
= Sync
2095 -- If there are switches in package Compiler, put them in the
2096 -- Carg_Switches table.
2099 Pkg
: constant Prj
.Package_Id
:=
2101 (Name
=> Name_Compiler
,
2102 In_Packages
=> Project
.Decl
.Packages
,
2103 Shared
=> Project_Tree
.Shared
);
2105 Element
: Package_Element
;
2107 Switches_Array
: Array_Element_Id
;
2109 The_Switches
: Prj
.Variable_Value
;
2110 Current
: Prj
.String_List_Id
;
2111 The_String
: String_Element
;
2113 Main
: String_Access
:= null;
2117 if Pkg
/= No_Package
then
2119 -- First, check if there is a single main specified
2121 for J
in 1 .. Last_Switches
.Last
loop
2122 if Last_Switches
.Table
(J
) (1) /= '-' then
2124 Main
:= Last_Switches
.Table
(J
);
2133 Element
:= Project_Tree
.Shared
.Packages
.Table
(Pkg
);
2135 -- If there is a single main and there is compilation
2136 -- switches specified in the project file, use them.
2138 if Main
/= null and then not All_Projects
then
2139 Name_Len
:= Main
'Length;
2140 Name_Buffer
(1 .. Name_Len
) := Main
.all;
2141 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2142 Main_Id
:= Name_Find
;
2146 (Name
=> Name_Switches
,
2147 In_Arrays
=> Element
.Decl
.Arrays
,
2148 Shared
=> Project_Tree
.Shared
);
2149 The_Switches
:= Prj
.Util
.Value_Of
2152 In_Array
=> Switches_Array
,
2153 Shared
=> Project_Tree
.Shared
);
2156 -- Otherwise, get the Default_Switches ("Ada")
2158 if The_Switches
.Kind
= Undefined
then
2161 (Name
=> Name_Default_Switches
,
2162 In_Arrays
=> Element
.Decl
.Arrays
,
2163 Shared
=> Project_Tree
.Shared
);
2164 The_Switches
:= Prj
.Util
.Value_Of
2167 In_Array
=> Switches_Array
,
2168 Shared
=> Project_Tree
.Shared
);
2171 -- If there are switches specified, put them in the
2172 -- Carg_Switches table.
2174 case The_Switches
.Kind
is
2175 when Prj
.Undefined
=>
2180 Switch
: constant String :=
2181 Get_Name_String
(The_Switches
.Value
);
2183 if Switch
'Length > 0 then
2184 Add_To_Carg_Switches
(new String'(Switch));
2189 Current := The_Switches.Values;
2190 while Current /= Prj.Nil_String loop
2191 The_String := Project_Tree.Shared.String_Elements
2195 Switch : constant String :=
2196 Get_Name_String (The_String.Value);
2198 if Switch'Length > 0 then
2199 Add_To_Carg_Switches (new String'(Switch
));
2203 Current
:= The_String
.Next
;
2209 -- If -cargs is one of the switches, move the following switches
2210 -- to the Carg_Switches table.
2212 for J
in 1 .. First_Switches
.Last
loop
2213 if First_Switches
.Table
(J
).all = "-cargs" then
2219 -- Move the switches that are before -rules when the
2220 -- command is CHECK.
2223 while K
<= First_Switches
.Last
2225 (The_Command
/= Check
2226 or else First_Switches
.Table
(K
).all /= "-rules")
2228 Add_To_Carg_Switches
(First_Switches
.Table
(K
));
2232 if K
> First_Switches
.Last
then
2233 First_Switches
.Set_Last
(J
- 1);
2237 while K
<= First_Switches
.Last
loop
2239 First_Switches
.Table
(Last
) :=
2240 First_Switches
.Table
(K
);
2244 First_Switches
.Set_Last
(Last
);
2252 for J
in 1 .. Last_Switches
.Last
loop
2253 if Last_Switches
.Table
(J
).all = "-cargs" then
2259 -- Move the switches that are before -rules when the
2260 -- command is CHECK.
2263 while K
<= Last_Switches
.Last
2265 (The_Command
/= Check
2266 or else Last_Switches
.Table
(K
).all /= "-rules")
2268 Add_To_Carg_Switches
(Last_Switches
.Table
(K
));
2272 if K
> Last_Switches
.Last
then
2273 Last_Switches
.Set_Last
(J
- 1);
2277 while K
<= Last_Switches
.Last
loop
2279 Last_Switches
.Table
(Last
) :=
2280 Last_Switches
.Table
(K
);
2284 Last_Switches
.Set_Last
(Last
);
2293 CP_File
: constant Path_Name_Type
:= Configuration_Pragmas_File
;
2294 M_File
: constant Path_Name_Type
:= Mapping_File
;
2297 if CP_File
/= No_Path
then
2298 if The_Command
= Elim
then
2299 First_Switches
.Increment_Last
;
2300 First_Switches
.Table
(First_Switches
.Last
) :=
2301 new String'("-C" & Get_Name_String (CP_File));
2304 Add_To_Carg_Switches
2305 (new String'("-gnatec=" & Get_Name_String
(CP_File
)));
2309 if M_File
/= No_Path
then
2310 Add_To_Carg_Switches
2311 (new String'("-gnatem=" & Get_Name_String (M_File)));
2314 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2315 -- indicate a global configuration pragmas file and, if -U
2316 -- is not used, a local one.
2318 if The_Command = Check or else
2319 The_Command = Pretty or else
2320 The_Command = Stub or else
2321 The_Command = Metric
2324 Pkg : constant Prj.Package_Id :=
2326 (Name => Name_Builder,
2327 In_Packages => Project.Decl.Packages,
2328 Shared => Project_Tree.Shared);
2330 Variable : Variable_Value :=
2333 Attribute_Or_Array_Name =>
2334 Name_Global_Configuration_Pragmas,
2336 Shared => Project_Tree.Shared);
2339 if (Variable = Nil_Variable_Value
2340 or else Length_Of_Name (Variable.Value) = 0)
2341 and then Pkg /= No_Package
2346 Attribute_Or_Array_Name =>
2347 Name_Global_Config_File,
2349 Shared => Project_Tree.Shared);
2352 if Variable /= Nil_Variable_Value
2353 and then Length_Of_Name (Variable.Value) /= 0
2356 Path : constant String :=
2358 (Path_Name_Type (Variable.Value), Project);
2360 Add_To_Carg_Switches
2361 (new String'("-gnatec=" & Path
));
2366 if not All_Projects
then
2368 Pkg
: constant Prj
.Package_Id
:=
2370 (Name
=> Name_Compiler
,
2371 In_Packages
=> Project
.Decl
.Packages
,
2372 Shared
=> Project_Tree
.Shared
);
2374 Variable
: Variable_Value
:=
2377 Attribute_Or_Array_Name
=>
2378 Name_Local_Configuration_Pragmas
,
2380 Shared
=> Project_Tree
.Shared
);
2383 if (Variable
= Nil_Variable_Value
2384 or else Length_Of_Name
(Variable
.Value
) = 0)
2385 and then Pkg
/= No_Package
2390 Attribute_Or_Array_Name
=>
2391 Name_Local_Config_File
,
2394 Project_Tree
.Shared
);
2397 if Variable
/= Nil_Variable_Value
2398 and then Length_Of_Name
(Variable
.Value
) /= 0
2401 Path
: constant String :=
2403 (Path_Name_Type
(Variable
.Value
), Project
);
2405 Add_To_Carg_Switches
2406 (new String'("-gnatec=" & Path));
2415 if The_Command = Link then
2419 if The_Command = Link or else The_Command = Bind then
2421 -- For files that are specified as relative paths with directory
2422 -- information, we convert them to absolute paths, with parent
2423 -- being the current working directory if specified on the command
2424 -- line and the project directory if specified in the project
2425 -- file. This is what gnatmake is doing for linker and binder
2428 for J in 1 .. Last_Switches.Last loop
2429 GNATCmd.Ensure_Absolute_Path
2430 (Last_Switches.Table (J), Current_Work_Dir);
2433 Get_Name_String (Project.Directory.Name);
2436 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2438 for J in 1 .. First_Switches.Last loop
2439 GNATCmd.Ensure_Absolute_Path
2440 (First_Switches.Table (J), Project_Dir);
2444 elsif The_Command = Stub then
2446 File_Index : Integer := 0;
2447 Dir_Index : Integer := 0;
2448 Last : constant Integer := Last_Switches.Last;
2449 Lang : constant Language_Ptr :=
2450 Get_Language_From_Name (Project, "ada");
2453 for Index in 1 .. Last loop
2454 if Last_Switches.Table (Index)
2455 (Last_Switches.Table (Index)'First) /= '-'
2457 File_Index := Index;
2462 -- If the project file naming scheme is not standard, and if
2463 -- the file name ends with the spec suffix, then indicate to
2464 -- gnatstub the name of the body file with a -o switch.
2466 if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
2467 if File_Index /= 0 then
2469 Spec : constant String :=
2471 (Last_Switches.Table (File_Index).all);
2472 Last : Natural := Spec'Last;
2475 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2477 if Spec'Length > Name_Len
2478 and then Spec (Last - Name_Len + 1 .. Last) =
2479 Name_Buffer (1 .. Name_Len)
2481 Last := Last - Name_Len;
2483 (Lang.Config.Naming_Data.Body_Suffix);
2484 Last_Switches.Increment_Last;
2485 Last_Switches.Table (Last_Switches.Last) :=
2487 Last_Switches
.Increment_Last
;
2488 Last_Switches
.Table
(Last_Switches
.Last
) :=
2489 new String'(Spec (Spec'First .. Last) &
2490 Name_Buffer (1 .. Name_Len));
2496 -- Add the directory of the spec as the destination directory
2497 -- of the body, if there is no destination directory already
2500 if File_Index /= 0 then
2501 for Index in File_Index + 1 .. Last loop
2502 if Last_Switches.Table (Index)
2503 (Last_Switches.Table (Index)'First) /= '-'
2510 if Dir_Index = 0 then
2511 Last_Switches.Increment_Last;
2512 Last_Switches.Table (Last_Switches.Last) :=
2514 (Dir_Name
(Last_Switches
.Table
(File_Index
).all));
2520 -- For gnatmetric, the generated files should be put in the object
2521 -- directory. This must be the first switch, because it may be
2522 -- overridden by a switch in package Metrics in the project file or
2523 -- by a command line option. Note that we don't add the -d= switch
2524 -- if there is no object directory available.
2526 if The_Command
= Metric
2527 and then Project
.Object_Directory
/= No_Path_Information
2529 First_Switches
.Increment_Last
;
2530 First_Switches
.Table
(2 .. First_Switches
.Last
) :=
2531 First_Switches
.Table
(1 .. First_Switches
.Last
- 1);
2532 First_Switches
.Table
(1) :=
2534 Get_Name_String (Project.Object_Directory.Name));
2537 -- For gnat check, -rules and the following switches need to be the
2538 -- last options, so move all these switches to table Rules_Switches.
2540 if The_Command = Check then
2543 -- Set to rank of options preceding "-rules"
2545 In_Rules_Switches : Boolean;
2546 -- Set to True when options "-rules" is found
2549 New_Last := First_Switches.Last;
2550 In_Rules_Switches := False;
2552 for J in 1 .. First_Switches.Last loop
2553 if In_Rules_Switches then
2554 Add_To_Rules_Switches (First_Switches.Table (J));
2556 elsif First_Switches.Table (J).all = "-rules" then
2558 In_Rules_Switches := True;
2562 if In_Rules_Switches then
2563 First_Switches.Set_Last (New_Last);
2566 New_Last := Last_Switches.Last;
2567 In_Rules_Switches := False;
2569 for J in 1 .. Last_Switches.Last loop
2570 if In_Rules_Switches then
2571 Add_To_Rules_Switches (Last_Switches.Table (J));
2573 elsif Last_Switches.Table (J).all = "-rules" then
2575 In_Rules_Switches := True;
2579 if In_Rules_Switches then
2580 Last_Switches.Set_Last (New_Last);
2585 -- For gnat check, sync, metric or pretty with -U + a main, get the
2586 -- list of sources from the closure and add them to the arguments.
2588 if ASIS_Main /= null then
2591 -- On VMS, set up the env var again for source dirs file. This is
2592 -- because the call to gnatmake has set this env var to another
2593 -- file that has now been deleted.
2595 if Hostparm.OpenVMS then
2597 -- First make sure that the recorded file names are empty
2599 Prj.Env.Initialize (Project_Tree);
2601 Prj.Env.Set_Ada_Paths
2602 (Project, Project_Tree, Including_Libraries => False);
2605 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2606 -- and gnat stack, if no file has been put on the command line, call
2607 -- tool with all the sources of the main project.
2609 elsif The_Command = Check or else
2610 The_Command = Sync or else
2611 The_Command = Pretty or else
2612 The_Command = Metric or else
2613 The_Command = List or else
2620 -- Gather all the arguments and invoke the executable
2623 The_Args : Argument_List
2624 (1 .. First_Switches.Last +
2625 Last_Switches.Last +
2626 Carg_Switches.Last +
2627 Rules_Switches.Last);
2628 Arg_Num : Natural := 0;
2631 for J in 1 .. First_Switches.Last loop
2632 Arg_Num := Arg_Num + 1;
2633 The_Args (Arg_Num) := First_Switches.Table (J);
2636 for J in 1 .. Last_Switches.Last loop
2637 Arg_Num := Arg_Num + 1;
2638 The_Args (Arg_Num) := Last_Switches.Table (J);
2641 for J in 1 .. Carg_Switches.Last loop
2642 Arg_Num := Arg_Num + 1;
2643 The_Args (Arg_Num) := Carg_Switches.Table (J);
2646 for J in 1 .. Rules_Switches.Last loop
2647 Arg_Num := Arg_Num + 1;
2648 The_Args (Arg_Num) := Rules_Switches.Table (J);
2651 -- If Display_Command is on, only display the generated command
2653 if Display_Command then
2654 Put (Standard_Error, "generated command -->");
2655 Put (Standard_Error, Exec_Path.all);
2657 for Arg in The_Args'Range loop
2658 Put (Standard_Error, " ");
2659 Put (Standard_Error, The_Args (Arg).all);
2662 Put (Standard_Error, "<--");
2663 New_Line (Standard_Error);
2667 if Verbose_Mode then
2668 Output.Write_Str (Exec_Path.all);
2670 for Arg in The_Args'Range loop
2671 Output.Write_Char (' ');
2672 Output.Write_Str (The_Args (Arg).all);
2679 Exit_Status (Spawn (Exec_Path.all, The_Args));
2686 if not Keep_Temporary_Files then
2687 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2688 Delete_Temp_Config_Files;
2691 Set_Exit_Status (Failure);
2694 if not Keep_Temporary_Files then
2695 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2696 Delete_Temp_Config_Files;
2699 -- Since GNATCmd is normally called from DCL (the VMS shell), it must
2700 -- return an understandable VMS exit status. However the exit status
2701 -- returned *to* GNATCmd is a Posix style code, so we test it and return
2702 -- just a simple success or failure on VMS.
2704 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
2705 Set_Exit_Status (Failure);
2707 Set_Exit_Status (My_Exit_Status);