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