?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR target/60039
[official-gcc.git] / gcc / ada / gnatcmd.adb
blob494fd4d9ceb7b5d21fce1355d9ebdf21c4cd4297
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T C M D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
27
28 with Csets;
29 with Hostparm; use Hostparm;
30 with Makeutl; use Makeutl;
31 with MLib.Tgt; use MLib.Tgt;
32 with MLib.Utl;
33 with MLib.Fil;
34 with Namet; use Namet;
35 with Opt; use Opt;
36 with Osint; use Osint;
37 with Output; use Output;
38 with Prj; use Prj;
39 with Prj.Env;
40 with Prj.Ext; use Prj.Ext;
41 with Prj.Pars;
42 with Prj.Tree; use Prj.Tree;
43 with Prj.Util; use Prj.Util;
44 with Sdefault;
45 with Sinput.P;
46 with Snames; use Snames;
47 with Stringt;
48 with Table;
49 with Targparm;
50 with Tempdir;
51 with Types; use Types;
52 with VMS_Conv; use VMS_Conv;
53 with VMS_Cmds; use VMS_Cmds;
54
55 with Ada.Characters.Handling; use Ada.Characters.Handling;
56 with Ada.Command_Line; use Ada.Command_Line;
57 with Ada.Text_IO; use Ada.Text_IO;
58
59 with GNAT.OS_Lib; use GNAT.OS_Lib;
60
61 procedure GNATCmd is
62 Project_Node_Tree : Project_Node_Tree_Ref;
63 Project_File : String_Access;
64 Project : Prj.Project_Id;
65 Current_Verbosity : Prj.Verbosity := Prj.Default;
66 Tool_Package_Name : Name_Id := No_Name;
67
68 B_Start : String_Ptr := new String'("b~");
69 -- Prefix of binder generated file, changed to b__ for VMS
70
71 Project_Tree : constant Project_Tree_Ref :=
72 new Project_Tree_Data (Is_Root_Tree => True);
73 -- The project tree
74
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
78 -- with -P.
79
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.
83
84 ASIS_Main : String_Access := null;
85 -- Main for commands Check, Metric and Pretty, when -U is used
86
87 package First_Switches is new Table.Table
88 (Table_Component_Type => String_Access,
89 Table_Index_Type => Integer,
90 Table_Low_Bound => 1,
91 Table_Initial => 20,
92 Table_Increment => 100,
93 Table_Name => "Gnatcmd.First_Switches");
94 -- A table to keep the switches from the project file
95
96 package Carg_Switches is new Table.Table
97 (Table_Component_Type => String_Access,
98 Table_Index_Type => Integer,
99 Table_Low_Bound => 1,
100 Table_Initial => 20,
101 Table_Increment => 100,
102 Table_Name => "Gnatcmd.Carg_Switches");
103 -- A table to keep the switches following -cargs for ASIS tools
104
105 package Rules_Switches is new Table.Table
106 (Table_Component_Type => String_Access,
107 Table_Index_Type => Integer,
108 Table_Low_Bound => 1,
109 Table_Initial => 20,
110 Table_Increment => 100,
111 Table_Name => "Gnatcmd.Rules_Switches");
112 -- A table to keep the switches following -rules for gnatcheck
113
114 package Library_Paths is new Table.Table (
115 Table_Component_Type => String_Access,
116 Table_Index_Type => Integer,
117 Table_Low_Bound => 1,
118 Table_Initial => 20,
119 Table_Increment => 100,
120 Table_Name => "Make.Library_Path");
121
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.
125
126 subtype SA is String_Access;
127
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");
143
144 Packages_To_Check_By_Binder : constant String_List_Access :=
145 new String_List'((Naming_String, Binder_String));
146
147 Packages_To_Check_By_Check : constant String_List_Access :=
148 new String_List'
149 ((Naming_String, Builder_String, Check_String, Compiler_String));
150
151 Packages_To_Check_By_Sync : constant String_List_Access :=
152 new String_List'((Naming_String, Synchronize_String, Compiler_String));
153
154 Packages_To_Check_By_Eliminate : constant String_List_Access :=
155 new String_List'((Naming_String, Eliminate_String, Compiler_String));
156
157 Packages_To_Check_By_Finder : constant String_List_Access :=
158 new String_List'((Naming_String, Finder_String));
159
160 Packages_To_Check_By_Linker : constant String_List_Access :=
161 new String_List'((Naming_String, Linker_String));
162
163 Packages_To_Check_By_Gnatls : constant String_List_Access :=
164 new String_List'((Naming_String, Gnatls_String));
165
166 Packages_To_Check_By_Pretty : constant String_List_Access :=
167 new String_List'((Naming_String, Pretty_String, Compiler_String));
168
169 Packages_To_Check_By_Stack : constant String_List_Access :=
170 new String_List'((Naming_String, Stack_String));
171
172 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
173 new String_List'((Naming_String, Gnatstub_String, Compiler_String));
174
175 Packages_To_Check_By_Metric : constant String_List_Access :=
176 new String_List'((Naming_String, Metric_String, Compiler_String));
177
178 Packages_To_Check_By_Xref : constant String_List_Access :=
179 new String_List'((Naming_String, Xref_String));
180
181 Packages_To_Check : String_List_Access := Prj.All_Packages;
182
183 ----------------------------------
184 -- Declarations for GNATCMD use --
185 ----------------------------------
186
187 The_Command : Command_Type;
188 -- The command specified in the invocation of the GNAT driver
189
190 Command_Arg : Positive := 1;
191 -- The index of the command in the arguments of the GNAT driver
192
193 My_Exit_Status : Exit_Status := Success;
194 -- The exit status of the spawned tool. Used to set the correct VMS
195 -- exit status.
196
197 Current_Work_Dir : constant String := Get_Current_Dir;
198 -- The path of the working directory
199
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.
204
205 Max_OpenVMS_Logical_Length : constant Integer := 255;
206 -- The maximum length of OpenVMS logicals
207
208 -----------------------
209 -- Local Subprograms --
210 -----------------------
211
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.
215
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.
219
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.
225
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.
232
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.
238
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
243 -- (GNAT METRIC).
244
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.
248
249 procedure Ensure_Absolute_Path
250 (Switch : in out String_Access;
251 Parent : String);
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.
255
256 procedure Get_Closure;
257 -- Get the sources in the closure of the ASIS_Main and add them to the
258 -- list of arguments.
259
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
263 -- (GNAT METRIC).
264
265 procedure Non_VMS_Usage;
266 -- Display usage for platforms other than VMS
267
268 procedure Process_Link;
269 -- Process GNAT LINK, when there is a project file specified
270
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.
277
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
281
282 --------------------------
283 -- Add_To_Carg_Switches --
284 --------------------------
285
286 procedure Add_To_Carg_Switches (Switch : String_Access) is
287 begin
288 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
289
290 if Carg_Switches.Last = 0 then
291 Carg_Switches.Increment_Last;
292 Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
293 end if;
294
295 Carg_Switches.Increment_Last;
296 Carg_Switches.Table (Carg_Switches.Last) := Switch;
297 end Add_To_Carg_Switches;
298
299 ---------------------------
300 -- Add_To_Rules_Switches --
301 ---------------------------
302
303 procedure Add_To_Rules_Switches (Switch : String_Access) is
304 begin
305 -- If the Rules_Switches table is empty, put "-rules" at the beginning
306
307 if Rules_Switches.Last = 0 then
308 Rules_Switches.Increment_Last;
309 Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
310 end if;
311
312 Rules_Switches.Increment_Last;
313 Rules_Switches.Table (Rules_Switches.Last) := Switch;
314 end Add_To_Rules_Switches;
315
316 -----------------
317 -- Check_Files --
318 -----------------
319
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;
325 Status : Integer;
326 Success : Boolean;
327
328 procedure Add_To_Response_File
329 (File_Name : String;
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.
336
337 --------------------------
338 -- Add_To_Response_File --
339 --------------------------
340
341 procedure Add_To_Response_File
342 (File_Name : String;
343 Check_File : Boolean := True)
344 is
345 begin
346 Name_Len := 0;
347
348 Add_Str_To_Name_Buffer (File_Name);
349
350 if not Check_File or else
351 Is_Regular_File (Name_Buffer (1 .. Name_Len))
352 then
353 if FD /= Invalid_FD then
354 Name_Len := Name_Len + 1;
355 Name_Buffer (Name_Len) := ASCII.LF;
356
357 Status := Write (FD, Name_Buffer (1)'Address, Name_Len);
358
359 if Status /= Name_Len then
360 Osint.Fail ("disk full");
361 end if;
362 else
363 Last_Switches.Increment_Last;
364 Last_Switches.Table (Last_Switches.Last) :=
365 new String'(File_Name);
366 end if;
367 end if;
368 end Add_To_Response_File;
369
370 -- Start of processing for Check_Files
371
372 begin
373 -- Check if there is at least one argument that is not a switch or if
374 -- there is a -files= switch.
375
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="
379 then
380 Add_Sources := False;
381 exit;
382
383 elsif Last_Switches.Table (Index) (1) /= '-' then
384 if Index = 1
385 or else
386 (The_Command = Check
387 and then Last_Switches.Table (Index - 1).all /= "-o")
388 or else
389 (The_Command = Pretty
390 and then Last_Switches.Table (Index - 1).all /= "-o"
391 and then Last_Switches.Table (Index - 1).all /= "-of")
392 or else
393 (The_Command = Metric
394 and then
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")
399 or else
400 (The_Command /= Check and then
401 The_Command /= Pretty and then
402 The_Command /= Metric)
403 then
404 Add_Sources := False;
405 exit;
406 end if;
407 end if;
408 end loop;
409
410 -- If all arguments are switches and there is no switch -files=, add the
411 -- path names of all the sources of the main project.
412
413 if Add_Sources then
414
415 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file and
416 -- put the list of sources in it. For gnatstack create a temporary
417 -- file with the list of .ci files.
418
419 if The_Command = Check or else
420 The_Command = Pretty or else
421 The_Command = Metric or else
422 The_Command = List or else
423 The_Command = Stack
424 then
425 Tempdir.Create_Temp_File (FD, Temp_File_Name);
426 Last_Switches.Increment_Last;
427 Last_Switches.Table (Last_Switches.Last) :=
428 new String'("-files=" & Get_Name_String (Temp_File_Name));
429 end if;
430
431 declare
432 Proj : Project_List;
433
434 begin
435 -- Gnatstack needs to add the .ci file for the binder generated
436 -- files corresponding to all of the library projects and main
437 -- units belonging to the application.
438
439 if The_Command = Stack then
440 Proj := Project_Tree.Projects;
441 while Proj /= null loop
442 if Check_Project (Proj.Project, Project) then
443 declare
444 Main : String_List_Id;
445
446 begin
447 -- Include binder generated files for main programs
448
449 Main := Proj.Project.Mains;
450 while Main /= Nil_String loop
451 Add_To_Response_File
452 (Get_Name_String
453 (Proj.Project.Object_Directory.Name) &
454 B_Start.all &
455 MLib.Fil.Ext_To
456 (Get_Name_String
457 (Project_Tree.Shared.String_Elements.Table
458 (Main).Value),
459 "ci"));
460
461 -- When looking for the .ci file for a binder
462 -- generated file, look for both b~xxx and b__xxx
463 -- as gprbuild always uses b__ as the prefix of
464 -- such files.
465
466 if not Is_Regular_File (Name_Buffer (1 .. Name_Len))
467 and then B_Start.all /= "b__"
468 then
469 Add_To_Response_File
470 (Get_Name_String
471 (Proj.Project.Object_Directory.Name) &
472 "b__" &
473 MLib.Fil.Ext_To
474 (Get_Name_String
475 (Project_Tree.Shared
476 .String_Elements.Table (Main).Value),
477 "ci"));
478 end if;
479
480 Main := Project_Tree.Shared.String_Elements.Table
481 (Main).Next;
482 end loop;
483
484 if Proj.Project.Library then
485
486 -- Include the .ci file for the binder generated
487 -- files that contains the initialization and
488 -- finalization of the library.
489
490 Add_To_Response_File
491 (Get_Name_String
492 (Proj.Project.Object_Directory.Name) &
493 B_Start.all &
494 Get_Name_String (Proj.Project.Library_Name) &
495 ".ci");
496
497 -- When looking for the .ci file for a binder
498 -- generated file, look for both b~xxx and b__xxx
499 -- as gprbuild always uses b__ as the prefix of
500 -- such files.
501
502 if not Is_Regular_File (Name_Buffer (1 .. Name_Len))
503 and then B_Start.all /= "b__"
504 then
505 Add_To_Response_File
506 (Get_Name_String
507 (Proj.Project.Object_Directory.Name) &
508 "b__" &
509 Get_Name_String (Proj.Project.Library_Name) &
510 ".ci");
511 end if;
512 end if;
513 end;
514 end if;
515
516 Proj := Proj.Next;
517 end loop;
518 end if;
519
520 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
521 while Unit /= No_Unit_Index loop
522
523 -- For gnatls, we only need to put the library units, body or
524 -- spec, but not the subunits.
525
526 if The_Command = List then
527 if Unit.File_Names (Impl) /= null
528 and then not Unit.File_Names (Impl).Locally_Removed
529 then
530 -- There is a body, check if it is for this project
531
532 if All_Projects
533 or else Unit.File_Names (Impl).Project = Project
534 then
535 Subunit := False;
536
537 if Unit.File_Names (Spec) = null
538 or else Unit.File_Names (Spec).Locally_Removed
539 then
540 -- We have a body with no spec: we need to check if
541 -- this is a subunit, because gnatls will complain
542 -- about subunits.
543
544 declare
545 Src_Ind : constant Source_File_Index :=
546 Sinput.P.Load_Project_File
547 (Get_Name_String
548 (Unit.File_Names
549 (Impl).Path.Name));
550 begin
551 Subunit :=
552 Sinput.P.Source_File_Is_Subunit (Src_Ind);
553 end;
554 end if;
555
556 if not Subunit then
557 Add_To_Response_File
558 (Get_Name_String
559 (Unit.File_Names (Impl).Display_File),
560 Check_File => False);
561 end if;
562 end if;
563
564 elsif Unit.File_Names (Spec) /= null
565 and then not Unit.File_Names (Spec).Locally_Removed
566 then
567 -- We have a spec with no body. Check if it is for this
568 -- project.
569
570 if All_Projects or else
571 Unit.File_Names (Spec).Project = Project
572 then
573 Add_To_Response_File
574 (Get_Name_String
575 (Unit.File_Names (Spec).Display_File),
576 Check_File => False);
577 end if;
578 end if;
579
580 -- For gnatstack, we put the .ci files corresponding to the
581 -- different units, including the binder generated files. We
582 -- only need to do that for the library units, body or spec,
583 -- but not the subunits.
584
585 elsif The_Command = Stack then
586 if Unit.File_Names (Impl) /= null
587 and then not Unit.File_Names (Impl).Locally_Removed
588 then
589 -- There is a body. Check if .ci files for this project
590 -- must be added.
591
592 if Check_Project
593 (Unit.File_Names (Impl).Project, Project)
594 then
595 Subunit := False;
596
597 if Unit.File_Names (Spec) = null
598 or else Unit.File_Names (Spec).Locally_Removed
599 then
600 -- We have a body with no spec: we need to check
601 -- if this is a subunit, because .ci files are not
602 -- generated for subunits.
603
604 declare
605 Src_Ind : constant Source_File_Index :=
606 Sinput.P.Load_Project_File
607 (Get_Name_String
608 (Unit.File_Names
609 (Impl).Path.Name));
610 begin
611 Subunit :=
612 Sinput.P.Source_File_Is_Subunit (Src_Ind);
613 end;
614 end if;
615
616 if not Subunit then
617 Add_To_Response_File
618 (Get_Name_String
619 (Unit.File_Names
620 (Impl).Project. Object_Directory.Name) &
621 MLib.Fil.Ext_To
622 (Get_Name_String
623 (Unit.File_Names (Impl).Display_File),
624 "ci"));
625 end if;
626 end if;
627
628 elsif Unit.File_Names (Spec) /= null
629 and then not Unit.File_Names (Spec).Locally_Removed
630 then
631 -- Spec with no body, check if it is for this project
632
633 if Check_Project
634 (Unit.File_Names (Spec).Project, Project)
635 then
636 Add_To_Response_File
637 (Get_Name_String
638 (Unit.File_Names
639 (Spec).Project. Object_Directory.Name) &
640 Dir_Separator &
641 MLib.Fil.Ext_To
642 (Get_Name_String (Unit.File_Names (Spec).File),
643 "ci"));
644 end if;
645 end if;
646
647 else
648 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
649 -- sources of the project, or of all projects if -U was
650 -- specified.
651
652 for Kind in Spec_Or_Body loop
653 if Unit.File_Names (Kind) /= null
654 and then Check_Project
655 (Unit.File_Names (Kind).Project, Project)
656 and then not Unit.File_Names (Kind).Locally_Removed
657 then
658 Add_To_Response_File
659 ("""" &
660 Get_Name_String
661 (Unit.File_Names (Kind).Path.Display_Name) &
662 """",
663 Check_File => False);
664 end if;
665 end loop;
666 end if;
667
668 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
669 end loop;
670 end;
671
672 if FD /= Invalid_FD then
673 Close (FD, Success);
674
675 if not Success then
676 Osint.Fail ("disk full");
677 end if;
678 end if;
679 end if;
680 end Check_Files;
681
682 -------------------
683 -- Check_Project --
684 -------------------
685
686 function Check_Project
687 (Project : Project_Id;
688 Root_Project : Project_Id) return Boolean
689 is
690 Proj : Project_Id;
691
692 begin
693 if Project = No_Project then
694 return False;
695
696 elsif All_Projects or else Project = Root_Project then
697 return True;
698
699 elsif The_Command = Metric then
700 Proj := Root_Project;
701 while Proj.Extends /= No_Project loop
702 if Project = Proj.Extends then
703 return True;
704 end if;
705
706 Proj := Proj.Extends;
707 end loop;
708 end if;
709
710 return False;
711 end Check_Project;
712
713 -------------------------------
714 -- Check_Relative_Executable --
715 -------------------------------
716
717 procedure Check_Relative_Executable (Name : in out String_Access) is
718 Exec_File_Name : constant String := Name.all;
719
720 begin
721 if not Is_Absolute_Path (Exec_File_Name) then
722 for Index in Exec_File_Name'Range loop
723 if Exec_File_Name (Index) = Directory_Separator then
724 Fail ("relative executable (""" &
725 Exec_File_Name &
726 """) with directory part not allowed " &
727 "when using project files");
728 end if;
729 end loop;
730
731 Get_Name_String (Project.Exec_Directory.Name);
732
733 if Name_Buffer (Name_Len) /= Directory_Separator then
734 Name_Len := Name_Len + 1;
735 Name_Buffer (Name_Len) := Directory_Separator;
736 end if;
737
738 Name_Buffer (Name_Len + 1 ..
739 Name_Len + Exec_File_Name'Length) :=
740 Exec_File_Name;
741 Name_Len := Name_Len + Exec_File_Name'Length;
742 Name := new String'(Name_Buffer (1 .. Name_Len));
743 end if;
744 end Check_Relative_Executable;
745
746 --------------------------------
747 -- Configuration_Pragmas_File --
748 --------------------------------
749
750 function Configuration_Pragmas_File return Path_Name_Type is
751 begin
752 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
753 return Project.Config_File_Name;
754 end Configuration_Pragmas_File;
755
756 ------------------------------
757 -- Delete_Temp_Config_Files --
758 ------------------------------
759
760 procedure Delete_Temp_Config_Files is
761 Success : Boolean;
762 Proj : Project_List;
763 pragma Warnings (Off, Success);
764
765 begin
766 -- This should only be called if Keep_Temporary_Files is False
767
768 pragma Assert (not Keep_Temporary_Files);
769
770 if Project /= No_Project then
771 Proj := Project_Tree.Projects;
772 while Proj /= null loop
773 if Proj.Project.Config_File_Temp then
774 Delete_Temporary_File
775 (Project_Tree.Shared, Proj.Project.Config_File_Name);
776 end if;
777
778 Proj := Proj.Next;
779 end loop;
780 end if;
781
782 -- If a temporary text file that contains a list of files for a tool
783 -- has been created, delete this temporary file.
784
785 if Temp_File_Name /= No_Path then
786 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
787 end if;
788 end Delete_Temp_Config_Files;
789
790 ---------------------------
791 -- Ensure_Absolute_Path --
792 ---------------------------
793
794 procedure Ensure_Absolute_Path
795 (Switch : in out String_Access;
796 Parent : String)
797 is
798 begin
799 Makeutl.Ensure_Absolute_Path
800 (Switch, Parent,
801 Do_Fail => Osint.Fail'Access,
802 Including_Non_Switch => False,
803 Including_RTS => True);
804 end Ensure_Absolute_Path;
805
806 -----------------
807 -- Get_Closure --
808 -----------------
809
810 procedure Get_Closure is
811 Args : constant Argument_List :=
812 (1 => new String'("-q"),
813 2 => new String'("-b"),
814 3 => new String'("-P"),
815 4 => Project_File,
816 5 => ASIS_Main,
817 6 => new String'("-bargs"),
818 7 => new String'("-R"),
819 8 => new String'("-Z"));
820 -- Arguments for the invocation of gnatmake which are added to the
821 -- Last_Arguments list by this procedure.
822
823 FD : File_Descriptor;
824 -- File descriptor for the temp file that will get the output of the
825 -- invocation of gnatmake.
826
827 Name : Path_Name_Type;
828 -- Path of the file FD
829
830 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
831 -- Name for gnatmake
832
833 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
834 -- Path of gnatmake
835
836 Return_Code : Integer;
837
838 Unused : Boolean;
839 pragma Warnings (Off, Unused);
840
841 File : Ada.Text_IO.File_Type;
842 Line : String (1 .. 250);
843 Last : Natural;
844 -- Used to read file if there is an error, it is good enough to display
845 -- just 250 characters if the first line of the file is very long.
846
847 Unit : Unit_Index;
848 Path : Path_Name_Type;
849
850 Files_File : Ada.Text_IO.File_Type;
851 Temp_File_Name : Path_Name_Type;
852
853 begin
854 if GN_Path = null then
855 Put_Line (Standard_Error, "could not locate " & GN_Name);
856 raise Error_Exit;
857 end if;
858
859 -- Create the temp file
860
861 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
862
863 -- And close it, because on VMS Spawn with a file descriptor created
864 -- with Create_Temp_File does not redirect output.
865
866 Close (FD);
867
868 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
869
870 Spawn
871 (Program_Name => GN_Path.all,
872 Args => Args,
873 Output_File => Get_Name_String (Name),
874 Success => Unused,
875 Return_Code => Return_Code,
876 Err_To_Out => True);
877
878 -- Read the output of the invocation of gnatmake
879
880 Open (File, In_File, Get_Name_String (Name));
881
882 -- If it was unsuccessful, display the first line in the file and exit
883 -- with error.
884
885 if Return_Code /= 0 then
886 Get_Line (File, Line, Last);
887
888 begin
889 if not Keep_Temporary_Files then
890 Delete (File);
891 else
892 Close (File);
893 end if;
894
895 -- Don't crash if it is not possible to delete or close the file,
896 -- just ignore the situation.
897
898 exception
899 when others =>
900 null;
901 end;
902
903 Put_Line (Standard_Error, Line (1 .. Last));
904 Put_Line
905 (Standard_Error, "could not get closure of " & ASIS_Main.all);
906 raise Error_Exit;
907
908 else
909 -- Create a temporary file to put the list of files in the closure
910
911 Tempdir.Create_Temp_File (FD, Temp_File_Name);
912 Last_Switches.Increment_Last;
913 Last_Switches.Table (Last_Switches.Last) :=
914 new String'("-files=" & Get_Name_String (Temp_File_Name));
915
916 Close (FD);
917
918 Open (Files_File, Out_File, Get_Name_String (Temp_File_Name));
919
920 -- Get each file name in the file, find its path and add it the list
921 -- of arguments.
922
923 while not End_Of_File (File) loop
924 Get_Line (File, Line, Last);
925 Path := No_Path;
926
927 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
928 while Unit /= No_Unit_Index loop
929 if Unit.File_Names (Spec) /= null
930 and then
931 Get_Name_String (Unit.File_Names (Spec).File) =
932 Line (1 .. Last)
933 then
934 Path := Unit.File_Names (Spec).Path.Name;
935 exit;
936
937 elsif Unit.File_Names (Impl) /= null
938 and then
939 Get_Name_String (Unit.File_Names (Impl).File) =
940 Line (1 .. Last)
941 then
942 Path := Unit.File_Names (Impl).Path.Name;
943 exit;
944 end if;
945
946 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
947 end loop;
948
949 if Path /= No_Path then
950 Put_Line (Files_File, Get_Name_String (Path));
951
952 else
953 Put_Line (Files_File, Line (1 .. Last));
954 end if;
955 end loop;
956
957 Close (Files_File);
958
959 begin
960 if not Keep_Temporary_Files then
961 Delete (File);
962 else
963 Close (File);
964 end if;
965
966 -- Don't crash if it is not possible to delete or close the file,
967 -- just ignore the situation.
968
969 exception
970 when others =>
971 null;
972 end;
973 end if;
974 end Get_Closure;
975
976 ------------------
977 -- Mapping_File --
978 ------------------
979
980 function Mapping_File return Path_Name_Type is
981 Result : Path_Name_Type;
982 begin
983 Prj.Env.Create_Mapping_File
984 (Project => Project,
985 Language => Name_Ada,
986 In_Tree => Project_Tree,
987 Name => Result);
988 return Result;
989 end Mapping_File;
990
991 -------------------
992 -- Non_VMS_Usage --
993 -------------------
994
995 procedure Non_VMS_Usage is
996 begin
997 Output_Version;
998 New_Line;
999 Put_Line ("List of available commands");
1000 New_Line;
1001
1002 for C in Command_List'Range loop
1003
1004 -- No usage for VMS only command or for Sync
1005
1006 if not Command_List (C).VMS_Only and then C /= Sync then
1007 if Targparm.AAMP_On_Target then
1008 Put ("gnaampcmd ");
1009 else
1010 Put ("gnat ");
1011 end if;
1012
1013 Put (To_Lower (Command_List (C).Cname.all));
1014 Set_Col (25);
1015
1016 -- Never call gnatstack with a prefix
1017
1018 if C = Stack then
1019 Put (Command_List (C).Unixcmd.all);
1020 else
1021 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
1022 end if;
1023
1024 declare
1025 Sws : Argument_List_Access renames Command_List (C).Unixsws;
1026 begin
1027 if Sws /= null then
1028 for J in Sws'Range loop
1029 Put (' ');
1030 Put (Sws (J).all);
1031 end loop;
1032 end if;
1033 end;
1034
1035 New_Line;
1036 end if;
1037 end loop;
1038
1039 New_Line;
1040 Put_Line ("All commands except chop, krunch and preprocess " &
1041 "accept project file switches -vPx, -Pprj and -Xnam=val");
1042 New_Line;
1043 end Non_VMS_Usage;
1044
1045 ------------------
1046 -- Process_Link --
1047 ------------------
1048
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;
1058
1059 begin
1060 -- Add the default search directories, to be able to find
1061 -- libgnat in call to MLib.Utl.Lib_Directory.
1062
1063 Add_Default_Search_Dirs;
1064
1065 Library_Paths.Set_Last (0);
1066
1067 -- Check if there are library project files
1068
1069 if MLib.Tgt.Support_For_Libraries /= None then
1070 Set_Libraries (Project, Project_Tree, Libraries_Present);
1071 end if;
1072
1073 -- If there are, add the necessary additional switches
1074
1075 if Libraries_Present then
1076
1077 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
1078
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");
1088
1089 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
1090 -- equivalent) with all the library dirs plus the standard GNAT
1091 -- library dir.
1092
1093 if Path_Option /= null then
1094 declare
1095 Option : String_Access;
1096 Length : Natural := Path_Option'Length;
1097 Current : Natural;
1098
1099 begin
1100 if MLib.Separate_Run_Path_Options then
1101
1102 -- We are going to create one switch of the form
1103 -- "-Wl,-rpath,dir_N" for each directory to consider.
1104
1105 -- One switch for each library directory
1106
1107 for Index in
1108 Library_Paths.First .. Library_Paths.Last
1109 loop
1110 Last_Switches.Increment_Last;
1111 Last_Switches.Table
1112 (Last_Switches.Last) := new String'
1113 (Path_Option.all &
1114 Last_Switches.Table (Index).all);
1115 end loop;
1116
1117 -- One switch for the standard GNAT library dir
1118
1119 Last_Switches.Increment_Last;
1120 Last_Switches.Table
1121 (Last_Switches.Last) := new String'
1122 (Path_Option.all & MLib.Utl.Lib_Directory);
1123
1124 else
1125 -- First, compute the exact length for the switch
1126
1127 for Index in
1128 Library_Paths.First .. Library_Paths.Last
1129 loop
1130 -- Add the length of the library dir plus one for the
1131 -- directory separator.
1132
1133 Length :=
1134 Length +
1135 Library_Paths.Table (Index)'Length + 1;
1136 end loop;
1137
1138 -- Finally, add the length of the standard GNAT library dir
1139
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;
1144
1145 -- Put each library dir followed by a dir separator
1146
1147 for Index in
1148 Library_Paths.First .. Library_Paths.Last
1149 loop
1150 Option
1151 (Current + 1 ..
1152 Current +
1153 Library_Paths.Table (Index)'Length) :=
1154 Library_Paths.Table (Index).all;
1155 Current :=
1156 Current +
1157 Library_Paths.Table (Index)'Length + 1;
1158 Option (Current) := Path_Separator;
1159 end loop;
1160
1161 -- Finally put the standard GNAT library dir
1162
1163 Option
1164 (Current + 1 ..
1165 Current + MLib.Utl.Lib_Directory'Length) :=
1166 MLib.Utl.Lib_Directory;
1167
1168 -- And add the switch to the last switches
1169
1170 Last_Switches.Increment_Last;
1171 Last_Switches.Table (Last_Switches.Last) :=
1172 Option;
1173 end if;
1174 end;
1175 end if;
1176 end if;
1177
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.
1182
1183 Skip_Executable := False;
1184
1185 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1186
1187 -- If we have an executable just reset the flag
1188
1189 if Skip_Executable then
1190 Skip_Executable := False;
1191
1192 -- If -o, set flag so that next switch is not processed
1193
1194 elsif Last_Switches.Table (J).all = "-o" then
1195 Skip_Executable := True;
1196
1197 -- Normal case
1198
1199 else
1200 declare
1201 Switch : constant String :=
1202 Last_Switches.Table (J).all;
1203 ALI_File : constant String (1 .. Switch'Length + 4) :=
1204 Switch & ".ali";
1205
1206 Test_Existence : Boolean := False;
1207
1208 begin
1209 Last := Switch'Length;
1210
1211 -- Skip real switches
1212
1213 if Switch'Length /= 0
1214 and then Switch (Switch'First) /= '-'
1215 then
1216 -- Append ".ali" if file name does not end with it
1217
1218 if Switch'Length <= 4
1219 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1220 then
1221 Last := ALI_File'Last;
1222 end if;
1223
1224 -- If file name includes directory information, stop if ALI
1225 -- file exists.
1226
1227 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1228 Test_Existence := True;
1229
1230 else
1231 for K in Switch'Range loop
1232 if Switch (K) = '/'
1233 or else Switch (K) = Directory_Separator
1234 then
1235 Test_Existence := True;
1236 exit;
1237 end if;
1238 end loop;
1239 end if;
1240
1241 if Test_Existence then
1242 if Is_Regular_File (ALI_File (1 .. Last)) then
1243 exit Switch_Loop;
1244 end if;
1245
1246 -- Look in object directories if ALI file exists
1247
1248 else
1249 Project_Loop : loop
1250 declare
1251 Dir : constant String :=
1252 Get_Name_String (Prj.Object_Directory.Name);
1253 begin
1254 if Is_Regular_File
1255 (Dir &
1256 ALI_File (1 .. Last))
1257 then
1258 -- We have found the correct project, so we
1259 -- replace the file with the absolute path.
1260
1261 Last_Switches.Table (J) :=
1262 new String'(Dir & ALI_File (1 .. Last));
1263
1264 -- And we are done
1265
1266 exit Switch_Loop;
1267 end if;
1268 end;
1269
1270 -- Go to the project being extended, if any
1271
1272 Prj := Prj.Extends;
1273 exit Project_Loop when Prj = No_Project;
1274 end loop Project_Loop;
1275 end if;
1276 end if;
1277 end;
1278 end if;
1279 end loop Switch_Loop;
1280
1281 -- If a relative path output file has been specified, we add the exec
1282 -- directory.
1283
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;
1289 exit;
1290 end if;
1291 end loop;
1292
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));
1299 exit;
1300 end if;
1301 end loop;
1302 end if;
1303
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.
1307
1308 if Look_For_Executable then
1309 for J in 1 .. Last_Switches.Last loop
1310 Arg := Last_Switches.Table (J);
1311 Last := 0;
1312
1313 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
1314 if Arg'Length > 4
1315 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
1316 then
1317 Last := Arg'Last - 4;
1318
1319 elsif Is_Regular_File (Arg.all & ".ali") then
1320 Last := Arg'Last;
1321 end if;
1322
1323 if Last /= 0 then
1324 Last_Switches.Increment_Last;
1325 Last_Switches.Table (Last_Switches.Last) :=
1326 new String'("-o");
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) &
1331 Executable_Name
1332 (Base_Name (Arg (Arg'First .. Last))));
1333 exit;
1334 end if;
1335 end if;
1336 end loop;
1337 end if;
1338 end Process_Link;
1339
1340 ---------------------
1341 -- Set_Library_For --
1342 ---------------------
1343
1344 procedure Set_Library_For
1345 (Project : Project_Id;
1346 Tree : Project_Tree_Ref;
1347 Libraries_Present : in out Boolean)
1348 is
1349 pragma Unreferenced (Tree);
1350
1351 Path_Option : constant String_Access :=
1352 MLib.Linker_Library_Path_Option;
1353
1354 begin
1355 -- Case of library project
1356
1357 if Project.Library then
1358 Libraries_Present := True;
1359
1360 -- Add the -L switch
1361
1362 Last_Switches.Increment_Last;
1363 Last_Switches.Table (Last_Switches.Last) :=
1364 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1365
1366 -- Add the -l switch
1367
1368 Last_Switches.Increment_Last;
1369 Last_Switches.Table (Last_Switches.Last) :=
1370 new String'("-l" & Get_Name_String (Project.Library_Name));
1371
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.
1374
1375 if Project.Library_Kind /= Static
1376 and then Path_Option /= null
1377 then
1378 Library_Paths.Increment_Last;
1379 Library_Paths.Table (Library_Paths.Last) :=
1380 new String'(Get_Name_String (Project.Library_Dir.Name));
1381 end if;
1382 end if;
1383 end Set_Library_For;
1384
1385 -- Start of processing for GNATCmd
1386
1387 begin
1388 -- All output from GNATCmd is debugging or error output: send to stderr
1389
1390 Set_Standard_Error;
1391
1392 -- Initializations
1393
1394 Csets.Initialize;
1395 Snames.Initialize;
1396 Stringt.Initialize;
1397
1398 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1399
1400 Project_Node_Tree := new Project_Node_Tree_Data;
1401 Prj.Tree.Initialize (Project_Node_Tree);
1402
1403 Prj.Initialize (Project_Tree);
1404
1405 Last_Switches.Init;
1406 Last_Switches.Set_Last (0);
1407
1408 First_Switches.Init;
1409 First_Switches.Set_Last (0);
1410 Carg_Switches.Init;
1411 Carg_Switches.Set_Last (0);
1412 Rules_Switches.Init;
1413 Rules_Switches.Set_Last (0);
1414
1415 VMS_Conv.Initialize;
1416
1417 -- Add the default search directories, to be able to find system.ads in the
1418 -- subsequent call to Targparm.Get_Target_Parameters.
1419
1420 Add_Default_Search_Dirs;
1421
1422 -- Get target parameters so that AAMP_On_Target will be set, for testing in
1423 -- Osint.Program_Name to handle the mapping of GNAAMP tool names.
1424
1425 Targparm.Get_Target_Parameters;
1426
1427 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1428 -- so that the spawned tool may know the way the GNAT driver was invoked.
1429
1430 Name_Len := 0;
1431 Add_Str_To_Name_Buffer (Command_Name);
1432
1433 for J in 1 .. Argument_Count loop
1434 Add_Char_To_Name_Buffer (' ');
1435 Add_Str_To_Name_Buffer (Argument (J));
1436 end loop;
1437
1438 -- On OpenVMS, setenv creates a logical whose length is limited to
1439 -- 255 bytes.
1440
1441 if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
1442 Name_Buffer (Max_OpenVMS_Logical_Length - 2
1443 .. Max_OpenVMS_Logical_Length) := "...";
1444 Name_Len := Max_OpenVMS_Logical_Length;
1445 end if;
1446
1447 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1448
1449 -- Add the directory where the GNAT driver is invoked in front of the path,
1450 -- if the GNAT driver is invoked with directory information. Do not do this
1451 -- for VMS, where the notion of path does not really exist.
1452
1453 if not OpenVMS then
1454 declare
1455 Command : constant String := Command_Name;
1456
1457 begin
1458 for Index in reverse Command'Range loop
1459 if Command (Index) = Directory_Separator then
1460 declare
1461 Absolute_Dir : constant String :=
1462 Normalize_Pathname
1463 (Command (Command'First .. Index));
1464
1465 PATH : constant String :=
1466 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1467
1468 begin
1469 Setenv ("PATH", PATH);
1470 end;
1471
1472 exit;
1473 end if;
1474 end loop;
1475 end;
1476 end if;
1477
1478 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1479 -- filenames and pathnames to Unix style.
1480
1481 if Hostparm.OpenVMS
1482 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1483 then
1484 VMS_Conversion (The_Command);
1485
1486 B_Start := new String'("b__");
1487
1488 -- If not on VMS, scan the command line directly
1489
1490 else
1491 if Argument_Count = 0 then
1492 Non_VMS_Usage;
1493 return;
1494 else
1495 begin
1496 loop
1497 if Argument_Count > Command_Arg
1498 and then Argument (Command_Arg) = "-v"
1499 then
1500 Verbose_Mode := True;
1501 Command_Arg := Command_Arg + 1;
1502
1503 elsif Argument_Count > Command_Arg
1504 and then Argument (Command_Arg) = "-dn"
1505 then
1506 Keep_Temporary_Files := True;
1507 Command_Arg := Command_Arg + 1;
1508
1509 else
1510 exit;
1511 end if;
1512 end loop;
1513
1514 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1515
1516 if Command_List (The_Command).VMS_Only then
1517 Non_VMS_Usage;
1518 Fail
1519 ("Command """
1520 & Command_List (The_Command).Cname.all
1521 & """ can only be used on VMS");
1522 end if;
1523
1524 exception
1525 when Constraint_Error =>
1526
1527 -- Check if it is an alternate command
1528
1529 declare
1530 Alternate : Alternate_Command;
1531
1532 begin
1533 Alternate := Alternate_Command'Value
1534 (Argument (Command_Arg));
1535 The_Command := Corresponding_To (Alternate);
1536
1537 exception
1538 when Constraint_Error =>
1539 Non_VMS_Usage;
1540 Fail ("Unknown command: " & Argument (Command_Arg));
1541 end;
1542 end;
1543
1544 -- Get the arguments from the command line and from the eventual
1545 -- argument file(s) specified on the command line.
1546
1547 for Arg in Command_Arg + 1 .. Argument_Count loop
1548 declare
1549 The_Arg : constant String := Argument (Arg);
1550
1551 begin
1552 -- Check if an argument file is specified
1553
1554 if The_Arg (The_Arg'First) = '@' then
1555 declare
1556 Arg_File : Ada.Text_IO.File_Type;
1557 Line : String (1 .. 256);
1558 Last : Natural;
1559
1560 begin
1561 -- Open the file and fail if the file cannot be found
1562
1563 begin
1564 Open
1565 (Arg_File, In_File,
1566 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1567
1568 exception
1569 when others =>
1570 Put
1571 (Standard_Error, "Cannot open argument file """);
1572 Put
1573 (Standard_Error,
1574 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1575
1576 Put_Line (Standard_Error, """");
1577 raise Error_Exit;
1578 end;
1579
1580 -- Read line by line and put the content of each non-
1581 -- empty line in the Last_Switches table.
1582
1583 while not End_Of_File (Arg_File) loop
1584 Get_Line (Arg_File, Line, Last);
1585
1586 if Last /= 0 then
1587 Last_Switches.Increment_Last;
1588 Last_Switches.Table (Last_Switches.Last) :=
1589 new String'(Line (1 .. Last));
1590 end if;
1591 end loop;
1592
1593 Close (Arg_File);
1594 end;
1595
1596 else
1597 -- It is not an argument file; just put the argument in
1598 -- the Last_Switches table.
1599
1600 Last_Switches.Increment_Last;
1601 Last_Switches.Table (Last_Switches.Last) :=
1602 new String'(The_Arg);
1603 end if;
1604 end;
1605 end loop;
1606 end if;
1607 end if;
1608
1609 declare
1610 Program : String_Access;
1611 Exec_Path : String_Access;
1612
1613 begin
1614 if The_Command = Stack then
1615
1616 -- Never call gnatstack with a prefix
1617
1618 Program := new String'(Command_List (The_Command).Unixcmd.all);
1619
1620 else
1621 Program :=
1622 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1623 end if;
1624
1625 -- For the tools where the GNAT driver processes the project files,
1626 -- allow shared library projects to import projects that are not shared
1627 -- library projects, to avoid adding a switch for these tools. For the
1628 -- builder (gnatmake), if a shared library project imports a project
1629 -- that is not a shared library project and the appropriate switch is
1630 -- not specified, the invocation of gnatmake will fail.
1631
1632 Opt.Unchecked_Shared_Lib_Imports := True;
1633
1634 -- Locate the executable for the command
1635
1636 Exec_Path := Locate_Exec_On_Path (Program.all);
1637
1638 if Exec_Path = null then
1639 Put_Line (Standard_Error, "could not locate " & Program.all);
1640 raise Error_Exit;
1641 end if;
1642
1643 -- If there are switches for the executable, put them as first switches
1644
1645 if Command_List (The_Command).Unixsws /= null then
1646 for J in Command_List (The_Command).Unixsws'Range loop
1647 First_Switches.Increment_Last;
1648 First_Switches.Table (First_Switches.Last) :=
1649 Command_List (The_Command).Unixsws (J);
1650 end loop;
1651 end if;
1652
1653 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1654 -- SYNC and XREF, look for project file related switches.
1655
1656 case The_Command is
1657 when Bind =>
1658 Tool_Package_Name := Name_Binder;
1659 Packages_To_Check := Packages_To_Check_By_Binder;
1660 when Check =>
1661 Tool_Package_Name := Name_Check;
1662 Packages_To_Check := Packages_To_Check_By_Check;
1663 when Elim =>
1664 Tool_Package_Name := Name_Eliminate;
1665 Packages_To_Check := Packages_To_Check_By_Eliminate;
1666 when Find =>
1667 Tool_Package_Name := Name_Finder;
1668 Packages_To_Check := Packages_To_Check_By_Finder;
1669 when Link =>
1670 Tool_Package_Name := Name_Linker;
1671 Packages_To_Check := Packages_To_Check_By_Linker;
1672 when List =>
1673 Tool_Package_Name := Name_Gnatls;
1674 Packages_To_Check := Packages_To_Check_By_Gnatls;
1675 when Metric =>
1676 Tool_Package_Name := Name_Metrics;
1677 Packages_To_Check := Packages_To_Check_By_Metric;
1678 when Pretty =>
1679 Tool_Package_Name := Name_Pretty_Printer;
1680 Packages_To_Check := Packages_To_Check_By_Pretty;
1681 when Stack =>
1682 Tool_Package_Name := Name_Stack;
1683 Packages_To_Check := Packages_To_Check_By_Stack;
1684 when Stub =>
1685 Tool_Package_Name := Name_Gnatstub;
1686 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1687 when Sync =>
1688 Tool_Package_Name := Name_Synchronize;
1689 Packages_To_Check := Packages_To_Check_By_Sync;
1690 when Xref =>
1691 Tool_Package_Name := Name_Cross_Reference;
1692 Packages_To_Check := Packages_To_Check_By_Xref;
1693 when others =>
1694 Tool_Package_Name := No_Name;
1695 end case;
1696
1697 if Tool_Package_Name /= No_Name then
1698
1699 -- Check that the switches are consistent. Detect project file
1700 -- related switches.
1701
1702 Inspect_Switches : declare
1703 Arg_Num : Positive := 1;
1704 Argv : String_Access;
1705
1706 procedure Remove_Switch (Num : Positive);
1707 -- Remove a project related switch from table Last_Switches
1708
1709 -------------------
1710 -- Remove_Switch --
1711 -------------------
1712
1713 procedure Remove_Switch (Num : Positive) is
1714 begin
1715 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1716 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1717 Last_Switches.Decrement_Last;
1718 end Remove_Switch;
1719
1720 -- Start of processing for Inspect_Switches
1721
1722 begin
1723 while Arg_Num <= Last_Switches.Last loop
1724 Argv := Last_Switches.Table (Arg_Num);
1725
1726 if Argv (Argv'First) = '-' then
1727 if Argv'Length = 1 then
1728 Fail
1729 ("switch character cannot be followed by a blank");
1730 end if;
1731
1732 -- The two style project files (-p and -P) cannot be used
1733 -- together
1734
1735 if (The_Command = Find or else The_Command = Xref)
1736 and then Argv (2) = 'p'
1737 then
1738 Old_Project_File_Used := True;
1739 if Project_File /= null then
1740 Fail ("-P and -p cannot be used together");
1741 end if;
1742 end if;
1743
1744 -- --subdirs=... Specify Subdirs
1745
1746 if Argv'Length > Makeutl.Subdirs_Option'Length
1747 and then
1748 Argv
1749 (Argv'First ..
1750 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1751 Makeutl.Subdirs_Option
1752 then
1753 Subdirs :=
1754 new String'
1755 (Argv
1756 (Argv'First + Makeutl.Subdirs_Option'Length ..
1757 Argv'Last));
1758
1759 Remove_Switch (Arg_Num);
1760
1761 -- -aPdir Add dir to the project search path
1762
1763 elsif Argv'Length > 3
1764 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
1765 then
1766 Prj.Env.Add_Directories
1767 (Root_Environment.Project_Path,
1768 Argv (Argv'First + 3 .. Argv'Last));
1769
1770 -- Pass -aPdir to gnatls, but not to other tools
1771
1772 if The_Command = List then
1773 Arg_Num := Arg_Num + 1;
1774 else
1775 Remove_Switch (Arg_Num);
1776 end if;
1777
1778 -- -eL Follow links for files
1779
1780 elsif Argv.all = "-eL" then
1781 Follow_Links_For_Files := True;
1782 Follow_Links_For_Dirs := True;
1783
1784 Remove_Switch (Arg_Num);
1785
1786 -- -vPx Specify verbosity while parsing project files
1787
1788 elsif Argv'Length >= 3
1789 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1790 then
1791 if Argv'Length = 4
1792 and then Argv (Argv'Last) in '0' .. '2'
1793 then
1794 case Argv (Argv'Last) is
1795 when '0' =>
1796 Current_Verbosity := Prj.Default;
1797 when '1' =>
1798 Current_Verbosity := Prj.Medium;
1799 when '2' =>
1800 Current_Verbosity := Prj.High;
1801 when others =>
1802
1803 -- Cannot happen
1804
1805 raise Program_Error;
1806 end case;
1807 else
1808 Fail ("invalid verbosity level: "
1809 & Argv (Argv'First + 3 .. Argv'Last));
1810 end if;
1811
1812 Remove_Switch (Arg_Num);
1813
1814 -- -Pproject_file Specify project file to be used
1815
1816 elsif Argv (Argv'First + 1) = 'P' then
1817
1818 -- Only one -P switch can be used
1819
1820 if Project_File /= null then
1821 Fail
1822 (Argv.all
1823 & ": second project file forbidden (first is """
1824 & Project_File.all
1825 & """)");
1826
1827 -- The two style project files (-p and -P) cannot be
1828 -- used together.
1829
1830 elsif Old_Project_File_Used then
1831 Fail ("-p and -P cannot be used together");
1832
1833 elsif Argv'Length = 2 then
1834
1835 -- There is space between -P and the project file
1836 -- name. -P cannot be the last option.
1837
1838 if Arg_Num = Last_Switches.Last then
1839 Fail ("project file name missing after -P");
1840
1841 else
1842 Remove_Switch (Arg_Num);
1843 Argv := Last_Switches.Table (Arg_Num);
1844
1845 -- After -P, there must be a project file name,
1846 -- not another switch.
1847
1848 if Argv (Argv'First) = '-' then
1849 Fail ("project file name missing after -P");
1850
1851 else
1852 Project_File := new String'(Argv.all);
1853 end if;
1854 end if;
1855
1856 else
1857 -- No space between -P and project file name
1858
1859 Project_File :=
1860 new String'(Argv (Argv'First + 2 .. Argv'Last));
1861 end if;
1862
1863 Remove_Switch (Arg_Num);
1864
1865 -- -Xexternal=value Specify an external reference to be
1866 -- used in project files
1867
1868 elsif Argv'Length >= 5
1869 and then Argv (Argv'First + 1) = 'X'
1870 then
1871 if not Check (Root_Environment.External,
1872 Argv (Argv'First + 2 .. Argv'Last))
1873 then
1874 Fail (Argv.all
1875 & " is not a valid external assignment.");
1876 end if;
1877
1878 Remove_Switch (Arg_Num);
1879
1880 elsif
1881 (The_Command = Check or else
1882 The_Command = Sync or else
1883 The_Command = Pretty or else
1884 The_Command = Metric or else
1885 The_Command = Stack or else
1886 The_Command = List)
1887 and then Argv'Length = 2
1888 and then Argv (2) = 'U'
1889 then
1890 All_Projects := True;
1891 Remove_Switch (Arg_Num);
1892
1893 else
1894 Arg_Num := Arg_Num + 1;
1895 end if;
1896
1897 elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
1898 or else The_Command = Sync
1899 or else The_Command = Metric
1900 or else The_Command = Pretty)
1901 and then Project_File /= null
1902 and then All_Projects
1903 then
1904 if ASIS_Main /= null then
1905 Fail ("cannot specify more than one main after -U");
1906 else
1907 ASIS_Main := Argv;
1908 Remove_Switch (Arg_Num);
1909 end if;
1910
1911 else
1912 Arg_Num := Arg_Num + 1;
1913 end if;
1914 end loop;
1915 end Inspect_Switches;
1916 end if;
1917
1918 -- Add the default project search directories now, after the directories
1919 -- that have been specified by switches -aP<dir>.
1920
1921 Prj.Env.Initialize_Default_Project_Path
1922 (Root_Environment.Project_Path,
1923 Target_Name => Sdefault.Target_Name.all);
1924
1925 -- If there is a project file specified, parse it, get the switches
1926 -- for the tool and setup PATH environment variables.
1927
1928 if Project_File /= null then
1929 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1930
1931 Prj.Pars.Parse
1932 (Project => Project,
1933 In_Tree => Project_Tree,
1934 In_Node_Tree => Project_Node_Tree,
1935 Project_File_Name => Project_File.all,
1936 Env => Root_Environment,
1937 Packages_To_Check => Packages_To_Check);
1938
1939 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1940
1941 Set_Standard_Error;
1942
1943 if Project = Prj.No_Project then
1944 Fail ("""" & Project_File.all & """ processing failed");
1945
1946 elsif Project.Qualifier = Aggregate then
1947 Fail ("aggregate projects are not supported");
1948
1949 elsif Aggregate_Libraries_In (Project_Tree) then
1950 Fail ("aggregate library projects are not supported");
1951 end if;
1952
1953 -- Check if a package with the name of the tool is in the project
1954 -- file and if there is one, get the switches, if any, and scan them.
1955
1956 declare
1957 Pkg : constant Prj.Package_Id :=
1958 Prj.Util.Value_Of
1959 (Name => Tool_Package_Name,
1960 In_Packages => Project.Decl.Packages,
1961 Shared => Project_Tree.Shared);
1962
1963 Element : Package_Element;
1964
1965 Switches_Array : Array_Element_Id;
1966
1967 The_Switches : Prj.Variable_Value;
1968 Current : Prj.String_List_Id;
1969 The_String : String_Element;
1970
1971 Main : String_Access := null;
1972
1973 begin
1974 if Pkg /= No_Package then
1975 Element := Project_Tree.Shared.Packages.Table (Pkg);
1976
1977 -- Packages Gnatls and Gnatstack have a single attribute
1978 -- Switches, that is not an associative array.
1979
1980 if The_Command = List or else The_Command = Stack then
1981 The_Switches :=
1982 Prj.Util.Value_Of
1983 (Variable_Name => Snames.Name_Switches,
1984 In_Variables => Element.Decl.Attributes,
1985 Shared => Project_Tree.Shared);
1986
1987 -- Packages Binder (for gnatbind), Cross_Reference (for
1988 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1989 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1990 -- (for gnatcheck), and Metric (for gnatmetric) have an
1991 -- attributed Switches, an associative array, indexed by the
1992 -- name of the file.
1993
1994 -- They also have an attribute Default_Switches, indexed by the
1995 -- name of the programming language.
1996
1997 else
1998 -- First check if there is a single main
1999
2000 for J in 1 .. Last_Switches.Last loop
2001 if Last_Switches.Table (J) (1) /= '-' then
2002 if Main = null then
2003 Main := Last_Switches.Table (J);
2004
2005 else
2006 Main := null;
2007 exit;
2008 end if;
2009 end if;
2010 end loop;
2011
2012 if Main /= null then
2013 Switches_Array :=
2014 Prj.Util.Value_Of
2015 (Name => Name_Switches,
2016 In_Arrays => Element.Decl.Arrays,
2017 Shared => Project_Tree.Shared);
2018 Name_Len := 0;
2019
2020 -- If the single main has been specified as an absolute
2021 -- path, use only the simple file name. If the absolute
2022 -- path is incorrect, an error will be reported by the
2023 -- underlying tool and it does not make a difference
2024 -- what switches are used.
2025
2026 if Is_Absolute_Path (Main.all) then
2027 Add_Str_To_Name_Buffer (File_Name (Main.all));
2028 else
2029 Add_Str_To_Name_Buffer (Main.all);
2030 end if;
2031
2032 The_Switches := Prj.Util.Value_Of
2033 (Index => Name_Find,
2034 Src_Index => 0,
2035 In_Array => Switches_Array,
2036 Shared => Project_Tree.Shared);
2037 end if;
2038
2039 if The_Switches.Kind = Prj.Undefined then
2040 Switches_Array :=
2041 Prj.Util.Value_Of
2042 (Name => Name_Default_Switches,
2043 In_Arrays => Element.Decl.Arrays,
2044 Shared => Project_Tree.Shared);
2045 The_Switches := Prj.Util.Value_Of
2046 (Index => Name_Ada,
2047 Src_Index => 0,
2048 In_Array => Switches_Array,
2049 Shared => Project_Tree.Shared);
2050 end if;
2051 end if;
2052
2053 -- If there are switches specified in the package of the
2054 -- project file corresponding to the tool, scan them.
2055
2056 case The_Switches.Kind is
2057 when Prj.Undefined =>
2058 null;
2059
2060 when Prj.Single =>
2061 declare
2062 Switch : constant String :=
2063 Get_Name_String (The_Switches.Value);
2064
2065 begin
2066 if Switch'Length > 0 then
2067 First_Switches.Increment_Last;
2068 First_Switches.Table (First_Switches.Last) :=
2069 new String'(Switch);
2070 end if;
2071 end;
2072
2073 when Prj.List =>
2074 Current := The_Switches.Values;
2075 while Current /= Prj.Nil_String loop
2076 The_String := Project_Tree.Shared.String_Elements.
2077 Table (Current);
2078
2079 declare
2080 Switch : constant String :=
2081 Get_Name_String (The_String.Value);
2082
2083 begin
2084 if Switch'Length > 0 then
2085 First_Switches.Increment_Last;
2086 First_Switches.Table (First_Switches.Last) :=
2087 new String'(Switch);
2088 end if;
2089 end;
2090
2091 Current := The_String.Next;
2092 end loop;
2093 end case;
2094 end if;
2095 end;
2096
2097 if The_Command = Bind
2098 or else The_Command = Link
2099 or else The_Command = Elim
2100 then
2101 if Project.Object_Directory.Name = No_Path then
2102 Fail ("project " & Get_Name_String (Project.Display_Name) &
2103 " has no object directory");
2104 end if;
2105
2106 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
2107 end if;
2108
2109 -- Set up the env vars for project path files
2110
2111 Prj.Env.Set_Ada_Paths
2112 (Project, Project_Tree, Including_Libraries => True);
2113
2114 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2115 -- a configuration pragmas file, if necessary.
2116
2117 if The_Command = Pretty
2118 or else The_Command = Metric
2119 or else The_Command = Stub
2120 or else The_Command = Elim
2121 or else The_Command = Check
2122 or else The_Command = Sync
2123 then
2124 -- If there are switches in package Compiler, put them in the
2125 -- Carg_Switches table.
2126
2127 declare
2128 Pkg : constant Prj.Package_Id :=
2129 Prj.Util.Value_Of
2130 (Name => Name_Compiler,
2131 In_Packages => Project.Decl.Packages,
2132 Shared => Project_Tree.Shared);
2133
2134 Element : Package_Element;
2135
2136 Switches_Array : Array_Element_Id;
2137
2138 The_Switches : Prj.Variable_Value;
2139 Current : Prj.String_List_Id;
2140 The_String : String_Element;
2141
2142 Main : String_Access := null;
2143 Main_Id : Name_Id;
2144
2145 begin
2146 if Pkg /= No_Package then
2147
2148 -- First, check if there is a single main specified
2149
2150 for J in 1 .. Last_Switches.Last loop
2151 if Last_Switches.Table (J) (1) /= '-' then
2152 if Main = null then
2153 Main := Last_Switches.Table (J);
2154
2155 else
2156 Main := null;
2157 exit;
2158 end if;
2159 end if;
2160 end loop;
2161
2162 Element := Project_Tree.Shared.Packages.Table (Pkg);
2163
2164 -- If there is a single main and there is compilation
2165 -- switches specified in the project file, use them.
2166
2167 if Main /= null and then not All_Projects then
2168 Name_Len := Main'Length;
2169 Name_Buffer (1 .. Name_Len) := Main.all;
2170 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2171 Main_Id := Name_Find;
2172
2173 Switches_Array :=
2174 Prj.Util.Value_Of
2175 (Name => Name_Switches,
2176 In_Arrays => Element.Decl.Arrays,
2177 Shared => Project_Tree.Shared);
2178 The_Switches := Prj.Util.Value_Of
2179 (Index => Main_Id,
2180 Src_Index => 0,
2181 In_Array => Switches_Array,
2182 Shared => Project_Tree.Shared);
2183 end if;
2184
2185 -- Otherwise, get the Default_Switches ("Ada")
2186
2187 if The_Switches.Kind = Undefined then
2188 Switches_Array :=
2189 Prj.Util.Value_Of
2190 (Name => Name_Default_Switches,
2191 In_Arrays => Element.Decl.Arrays,
2192 Shared => Project_Tree.Shared);
2193 The_Switches := Prj.Util.Value_Of
2194 (Index => Name_Ada,
2195 Src_Index => 0,
2196 In_Array => Switches_Array,
2197 Shared => Project_Tree.Shared);
2198 end if;
2199
2200 -- If there are switches specified, put them in the
2201 -- Carg_Switches table.
2202
2203 case The_Switches.Kind is
2204 when Prj.Undefined =>
2205 null;
2206
2207 when Prj.Single =>
2208 declare
2209 Switch : constant String :=
2210 Get_Name_String (The_Switches.Value);
2211 begin
2212 if Switch'Length > 0 then
2213 Add_To_Carg_Switches (new String'(Switch));
2214 end if;
2215 end;
2216
2217 when Prj.List =>
2218 Current := The_Switches.Values;
2219 while Current /= Prj.Nil_String loop
2220 The_String := Project_Tree.Shared.String_Elements
2221 .Table (Current);
2222
2223 declare
2224 Switch : constant String :=
2225 Get_Name_String (The_String.Value);
2226 begin
2227 if Switch'Length > 0 then
2228 Add_To_Carg_Switches (new String'(Switch));
2229 end if;
2230 end;
2231
2232 Current := The_String.Next;
2233 end loop;
2234 end case;
2235 end if;
2236 end;
2237
2238 -- If -cargs is one of the switches, move the following switches
2239 -- to the Carg_Switches table.
2240
2241 for J in 1 .. First_Switches.Last loop
2242 if First_Switches.Table (J).all = "-cargs" then
2243 declare
2244 K : Positive;
2245 Last : Natural;
2246
2247 begin
2248 -- Move the switches that are before -rules when the
2249 -- command is CHECK.
2250
2251 K := J + 1;
2252 while K <= First_Switches.Last
2253 and then
2254 (The_Command /= Check
2255 or else First_Switches.Table (K).all /= "-rules")
2256 loop
2257 Add_To_Carg_Switches (First_Switches.Table (K));
2258 K := K + 1;
2259 end loop;
2260
2261 if K > First_Switches.Last then
2262 First_Switches.Set_Last (J - 1);
2263
2264 else
2265 Last := J - 1;
2266 while K <= First_Switches.Last loop
2267 Last := Last + 1;
2268 First_Switches.Table (Last) :=
2269 First_Switches.Table (K);
2270 K := K + 1;
2271 end loop;
2272
2273 First_Switches.Set_Last (Last);
2274 end if;
2275 end;
2276
2277 exit;
2278 end if;
2279 end loop;
2280
2281 for J in 1 .. Last_Switches.Last loop
2282 if Last_Switches.Table (J).all = "-cargs" then
2283 declare
2284 K : Positive;
2285 Last : Natural;
2286
2287 begin
2288 -- Move the switches that are before -rules when the
2289 -- command is CHECK.
2290
2291 K := J + 1;
2292 while K <= Last_Switches.Last
2293 and then
2294 (The_Command /= Check
2295 or else Last_Switches.Table (K).all /= "-rules")
2296 loop
2297 Add_To_Carg_Switches (Last_Switches.Table (K));
2298 K := K + 1;
2299 end loop;
2300
2301 if K > Last_Switches.Last then
2302 Last_Switches.Set_Last (J - 1);
2303
2304 else
2305 Last := J - 1;
2306 while K <= Last_Switches.Last loop
2307 Last := Last + 1;
2308 Last_Switches.Table (Last) :=
2309 Last_Switches.Table (K);
2310 K := K + 1;
2311 end loop;
2312
2313 Last_Switches.Set_Last (Last);
2314 end if;
2315 end;
2316
2317 exit;
2318 end if;
2319 end loop;
2320
2321 declare
2322 CP_File : constant Path_Name_Type := Configuration_Pragmas_File;
2323 M_File : constant Path_Name_Type := Mapping_File;
2324
2325 begin
2326 if CP_File /= No_Path then
2327 if The_Command = Elim then
2328 First_Switches.Increment_Last;
2329 First_Switches.Table (First_Switches.Last) :=
2330 new String'("-C" & Get_Name_String (CP_File));
2331
2332 else
2333 Add_To_Carg_Switches
2334 (new String'("-gnatec=" & Get_Name_String (CP_File)));
2335 end if;
2336 end if;
2337
2338 if M_File /= No_Path then
2339 Add_To_Carg_Switches
2340 (new String'("-gnatem=" & Get_Name_String (M_File)));
2341 end if;
2342
2343 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2344 -- indicate a global configuration pragmas file and, if -U
2345 -- is not used, a local one.
2346
2347 if The_Command = Check or else
2348 The_Command = Pretty or else
2349 The_Command = Stub or else
2350 The_Command = Metric
2351 then
2352 declare
2353 Pkg : constant Prj.Package_Id :=
2354 Prj.Util.Value_Of
2355 (Name => Name_Builder,
2356 In_Packages => Project.Decl.Packages,
2357 Shared => Project_Tree.Shared);
2358
2359 Variable : Variable_Value :=
2360 Prj.Util.Value_Of
2361 (Name => No_Name,
2362 Attribute_Or_Array_Name =>
2363 Name_Global_Configuration_Pragmas,
2364 In_Package => Pkg,
2365 Shared => Project_Tree.Shared);
2366
2367 begin
2368 if (Variable = Nil_Variable_Value
2369 or else Length_Of_Name (Variable.Value) = 0)
2370 and then Pkg /= No_Package
2371 then
2372 Variable :=
2373 Prj.Util.Value_Of
2374 (Name => Name_Ada,
2375 Attribute_Or_Array_Name =>
2376 Name_Global_Config_File,
2377 In_Package => Pkg,
2378 Shared => Project_Tree.Shared);
2379 end if;
2380
2381 if Variable /= Nil_Variable_Value
2382 and then Length_Of_Name (Variable.Value) /= 0
2383 then
2384 declare
2385 Path : constant String :=
2386 Absolute_Path
2387 (Path_Name_Type (Variable.Value),
2388 Variable.Project);
2389 begin
2390 Add_To_Carg_Switches
2391 (new String'("-gnatec=" & Path));
2392 end;
2393 end if;
2394 end;
2395
2396 if not All_Projects then
2397 declare
2398 Pkg : constant Prj.Package_Id :=
2399 Prj.Util.Value_Of
2400 (Name => Name_Compiler,
2401 In_Packages => Project.Decl.Packages,
2402 Shared => Project_Tree.Shared);
2403
2404 Variable : Variable_Value :=
2405 Prj.Util.Value_Of
2406 (Name => No_Name,
2407 Attribute_Or_Array_Name =>
2408 Name_Local_Configuration_Pragmas,
2409 In_Package => Pkg,
2410 Shared => Project_Tree.Shared);
2411
2412 begin
2413 if (Variable = Nil_Variable_Value
2414 or else Length_Of_Name (Variable.Value) = 0)
2415 and then Pkg /= No_Package
2416 then
2417 Variable :=
2418 Prj.Util.Value_Of
2419 (Name => Name_Ada,
2420 Attribute_Or_Array_Name =>
2421 Name_Local_Config_File,
2422 In_Package => Pkg,
2423 Shared =>
2424 Project_Tree.Shared);
2425 end if;
2426
2427 if Variable /= Nil_Variable_Value
2428 and then Length_Of_Name (Variable.Value) /= 0
2429 then
2430 declare
2431 Path : constant String :=
2432 Absolute_Path
2433 (Path_Name_Type (Variable.Value),
2434 Variable.Project);
2435 begin
2436 Add_To_Carg_Switches
2437 (new String'("-gnatec=" & Path));
2438 end;
2439 end if;
2440 end;
2441 end if;
2442 end if;
2443 end;
2444 end if;
2445
2446 if The_Command = Link then
2447 Process_Link;
2448 end if;
2449
2450 if The_Command = Link or else The_Command = Bind then
2451
2452 -- For files that are specified as relative paths with directory
2453 -- information, we convert them to absolute paths, with parent
2454 -- being the current working directory if specified on the command
2455 -- line and the project directory if specified in the project
2456 -- file. This is what gnatmake is doing for linker and binder
2457 -- arguments.
2458
2459 for J in 1 .. Last_Switches.Last loop
2460 GNATCmd.Ensure_Absolute_Path
2461 (Last_Switches.Table (J), Current_Work_Dir);
2462 end loop;
2463
2464 Get_Name_String (Project.Directory.Name);
2465
2466 declare
2467 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2468 begin
2469 for J in 1 .. First_Switches.Last loop
2470 GNATCmd.Ensure_Absolute_Path
2471 (First_Switches.Table (J), Project_Dir);
2472 end loop;
2473 end;
2474
2475 elsif The_Command = Stub then
2476 declare
2477 File_Index : Integer := 0;
2478 Dir_Index : Integer := 0;
2479 Last : constant Integer := Last_Switches.Last;
2480 Lang : constant Language_Ptr :=
2481 Get_Language_From_Name (Project, "ada");
2482
2483 begin
2484 for Index in 1 .. Last loop
2485 if Last_Switches.Table (Index)
2486 (Last_Switches.Table (Index)'First) /= '-'
2487 then
2488 File_Index := Index;
2489 exit;
2490 end if;
2491 end loop;
2492
2493 -- If the project file naming scheme is not standard, and if
2494 -- the file name ends with the spec suffix, then indicate to
2495 -- gnatstub the name of the body file with a -o switch.
2496
2497 if Lang /= No_Language_Index
2498 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data)
2499 then
2500 if File_Index /= 0 then
2501 declare
2502 Spec : constant String :=
2503 Base_Name
2504 (Last_Switches.Table (File_Index).all);
2505 Last : Natural := Spec'Last;
2506
2507 begin
2508 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2509
2510 if Spec'Length > Name_Len
2511 and then Spec (Last - Name_Len + 1 .. Last) =
2512 Name_Buffer (1 .. Name_Len)
2513 then
2514 Last := Last - Name_Len;
2515 Get_Name_String
2516 (Lang.Config.Naming_Data.Body_Suffix);
2517 Last_Switches.Increment_Last;
2518 Last_Switches.Table (Last_Switches.Last) :=
2519 new String'("-o");
2520 Last_Switches.Increment_Last;
2521 Last_Switches.Table (Last_Switches.Last) :=
2522 new String'(Spec (Spec'First .. Last) &
2523 Name_Buffer (1 .. Name_Len));
2524 end if;
2525 end;
2526 end if;
2527 end if;
2528
2529 -- Add the directory of the spec as the destination directory
2530 -- of the body, if there is no destination directory already
2531 -- specified.
2532
2533 if File_Index /= 0 then
2534 for Index in File_Index + 1 .. Last loop
2535 if Last_Switches.Table (Index)
2536 (Last_Switches.Table (Index)'First) /= '-'
2537 then
2538 Dir_Index := Index;
2539 exit;
2540 end if;
2541 end loop;
2542
2543 if Dir_Index = 0 then
2544 Last_Switches.Increment_Last;
2545 Last_Switches.Table (Last_Switches.Last) :=
2546 new String'
2547 (Dir_Name (Last_Switches.Table (File_Index).all));
2548 end if;
2549 end if;
2550 end;
2551 end if;
2552
2553 -- For gnatmetric, the generated files should be put in the object
2554 -- directory. This must be the first switch, because it may be
2555 -- overridden by a switch in package Metrics in the project file or
2556 -- by a command line option. Note that we don't add the -d= switch
2557 -- if there is no object directory available.
2558
2559 if The_Command = Metric
2560 and then Project.Object_Directory /= No_Path_Information
2561 then
2562 First_Switches.Increment_Last;
2563 First_Switches.Table (2 .. First_Switches.Last) :=
2564 First_Switches.Table (1 .. First_Switches.Last - 1);
2565 First_Switches.Table (1) :=
2566 new String'("-d=" &
2567 Get_Name_String (Project.Object_Directory.Name));
2568 end if;
2569
2570 -- For gnat check, -rules and the following switches need to be the
2571 -- last options, so move all these switches to table Rules_Switches.
2572
2573 if The_Command = Check then
2574 declare
2575 New_Last : Natural;
2576 -- Set to rank of options preceding "-rules"
2577
2578 In_Rules_Switches : Boolean;
2579 -- Set to True when options "-rules" is found
2580
2581 begin
2582 New_Last := First_Switches.Last;
2583 In_Rules_Switches := False;
2584
2585 for J in 1 .. First_Switches.Last loop
2586 if In_Rules_Switches then
2587 Add_To_Rules_Switches (First_Switches.Table (J));
2588
2589 elsif First_Switches.Table (J).all = "-rules" then
2590 New_Last := J - 1;
2591 In_Rules_Switches := True;
2592 end if;
2593 end loop;
2594
2595 if In_Rules_Switches then
2596 First_Switches.Set_Last (New_Last);
2597 end if;
2598
2599 New_Last := Last_Switches.Last;
2600 In_Rules_Switches := False;
2601
2602 for J in 1 .. Last_Switches.Last loop
2603 if In_Rules_Switches then
2604 Add_To_Rules_Switches (Last_Switches.Table (J));
2605
2606 elsif Last_Switches.Table (J).all = "-rules" then
2607 New_Last := J - 1;
2608 In_Rules_Switches := True;
2609 end if;
2610 end loop;
2611
2612 if In_Rules_Switches then
2613 Last_Switches.Set_Last (New_Last);
2614 end if;
2615 end;
2616 end if;
2617
2618 -- For gnat check, sync, metric or pretty with -U + a main, get the
2619 -- list of sources from the closure and add them to the arguments.
2620
2621 if ASIS_Main /= null then
2622 Get_Closure;
2623
2624 -- On VMS, set up the env var again for source dirs file. This is
2625 -- because the call to gnatmake has set this env var to another
2626 -- file that has now been deleted.
2627
2628 if Hostparm.OpenVMS then
2629
2630 -- First make sure that the recorded file names are empty
2631
2632 Prj.Env.Initialize (Project_Tree);
2633
2634 Prj.Env.Set_Ada_Paths
2635 (Project, Project_Tree, Including_Libraries => False);
2636 end if;
2637
2638 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2639 -- and gnat stack, if no file has been put on the command line, call
2640 -- tool with all the sources of the main project.
2641
2642 elsif The_Command = Check or else
2643 The_Command = Sync or else
2644 The_Command = Pretty or else
2645 The_Command = Metric or else
2646 The_Command = List or else
2647 The_Command = Stack
2648 then
2649 Check_Files;
2650 end if;
2651 end if;
2652
2653 -- Gather all the arguments and invoke the executable
2654
2655 declare
2656 The_Args : Argument_List
2657 (1 .. First_Switches.Last +
2658 Last_Switches.Last +
2659 Carg_Switches.Last +
2660 Rules_Switches.Last);
2661 Arg_Num : Natural := 0;
2662
2663 begin
2664 for J in 1 .. First_Switches.Last loop
2665 Arg_Num := Arg_Num + 1;
2666 The_Args (Arg_Num) := First_Switches.Table (J);
2667 end loop;
2668
2669 for J in 1 .. Last_Switches.Last loop
2670 Arg_Num := Arg_Num + 1;
2671 The_Args (Arg_Num) := Last_Switches.Table (J);
2672 end loop;
2673
2674 for J in 1 .. Carg_Switches.Last loop
2675 Arg_Num := Arg_Num + 1;
2676 The_Args (Arg_Num) := Carg_Switches.Table (J);
2677 end loop;
2678
2679 for J in 1 .. Rules_Switches.Last loop
2680 Arg_Num := Arg_Num + 1;
2681 The_Args (Arg_Num) := Rules_Switches.Table (J);
2682 end loop;
2683
2684 -- If Display_Command is on, only display the generated command
2685
2686 if Display_Command then
2687 Put (Standard_Error, "generated command -->");
2688 Put (Standard_Error, Exec_Path.all);
2689
2690 for Arg in The_Args'Range loop
2691 Put (Standard_Error, " ");
2692 Put (Standard_Error, The_Args (Arg).all);
2693 end loop;
2694
2695 Put (Standard_Error, "<--");
2696 New_Line (Standard_Error);
2697 raise Normal_Exit;
2698 end if;
2699
2700 if Verbose_Mode then
2701 Output.Write_Str (Exec_Path.all);
2702
2703 for Arg in The_Args'Range loop
2704 Output.Write_Char (' ');
2705 Output.Write_Str (The_Args (Arg).all);
2706 end loop;
2707
2708 Output.Write_Eol;
2709 end if;
2710
2711 My_Exit_Status :=
2712 Exit_Status (Spawn (Exec_Path.all, The_Args));
2713 raise Normal_Exit;
2714 end;
2715 end;
2716
2717 exception
2718 when Error_Exit =>
2719 if not Keep_Temporary_Files then
2720 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2721 Delete_Temp_Config_Files;
2722 end if;
2723
2724 Set_Exit_Status (Failure);
2725
2726 when Normal_Exit =>
2727 if not Keep_Temporary_Files then
2728 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2729 Delete_Temp_Config_Files;
2730 end if;
2731
2732 -- Since GNATCmd is normally called from DCL (the VMS shell), it must
2733 -- return an understandable VMS exit status. However the exit status
2734 -- returned *to* GNATCmd is a Posix style code, so we test it and return
2735 -- just a simple success or failure on VMS.
2736
2737 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
2738 Set_Exit_Status (Failure);
2739 else
2740 Set_Exit_Status (My_Exit_Status);
2741 end if;
2742 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org