?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* arm.c (FL_WBUF): Define.
[official-gcc.git] / gcc / ada / gnatcmd.adb
blob31646586e592ad93d8b4fde21280a90874f40e6b
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-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
28
29 with Csets;
30 with MLib.Tgt; use MLib.Tgt;
31 with MLib.Utl;
32 with Namet; use Namet;
33 with Opt; use Opt;
34 with Osint; use Osint;
35 with Output;
36 with Prj; use Prj;
37 with Prj.Env;
38 with Prj.Ext; use Prj.Ext;
39 with Prj.Pars;
40 with Prj.Util; use Prj.Util;
41 with Sinput.P;
42 with Snames; use Snames;
43 with Table;
44 with Types; use Types;
45 with Hostparm; use Hostparm;
46 -- Used to determine if we are in VMS or not for error message purposes
47
48 with Ada.Characters.Handling; use Ada.Characters.Handling;
49 with Ada.Command_Line; use Ada.Command_Line;
50 with Ada.Text_IO; use Ada.Text_IO;
51
52 with GNAT.OS_Lib; use GNAT.OS_Lib;
53
54 with Table;
55
56 with VMS_Conv; use VMS_Conv;
57
58 procedure GNATCmd is
59 Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data;
60 Project_File : String_Access;
61 Project : Prj.Project_Id;
62 Current_Verbosity : Prj.Verbosity := Prj.Default;
63 Tool_Package_Name : Name_Id := No_Name;
64
65 Old_Project_File_Used : Boolean := False;
66 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
67 -- an old fashioned project file. -p cannot be used in conjonction
68 -- with -P.
69
70 Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary
71
72 Temp_File_Name : String_Access := null;
73 -- The name of the temporary text file to put a list of source/object
74 -- files to pass to a tool, when there are more than
75 -- Max_Files_On_The_Command_Line files.
76
77 package First_Switches is new Table.Table
78 (Table_Component_Type => String_Access,
79 Table_Index_Type => Integer,
80 Table_Low_Bound => 1,
81 Table_Initial => 20,
82 Table_Increment => 100,
83 Table_Name => "Gnatcmd.First_Switches");
84 -- A table to keep the switches from the project file
85
86 package Carg_Switches is new Table.Table
87 (Table_Component_Type => String_Access,
88 Table_Index_Type => Integer,
89 Table_Low_Bound => 1,
90 Table_Initial => 20,
91 Table_Increment => 100,
92 Table_Name => "Gnatcmd.Carg_Switches");
93 -- A table to keep the switches following -cargs for ASIS tools
94
95 package Library_Paths is new Table.Table (
96 Table_Component_Type => String_Access,
97 Table_Index_Type => Integer,
98 Table_Low_Bound => 1,
99 Table_Initial => 20,
100 Table_Increment => 100,
101 Table_Name => "Make.Library_Path");
102
103 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
104 -- tool. We allocate objects because we cannot declare aliased objects
105 -- as we are in a procedure, not a library level package.
106
107 Naming_String : constant String_Access := new String'("naming");
108 Binder_String : constant String_Access := new String'("binder");
109 Eliminate_String : constant String_Access := new String'("eliminate");
110 Finder_String : constant String_Access := new String'("finder");
111 Linker_String : constant String_Access := new String'("linker");
112 Gnatls_String : constant String_Access := new String'("gnatls");
113 Pretty_String : constant String_Access := new String'("pretty_printer");
114 Gnatstub_String : constant String_Access := new String'("gnatstub");
115 Metric_String : constant String_Access := new String'("metrics");
116 Xref_String : constant String_Access := new String'("cross_reference");
117
118 Packages_To_Check_By_Binder : constant String_List_Access :=
119 new String_List'((Naming_String, Binder_String));
120
121 Packages_To_Check_By_Eliminate : constant String_List_Access :=
122 new String_List'((Naming_String, Eliminate_String));
123
124 Packages_To_Check_By_Finder : constant String_List_Access :=
125 new String_List'((Naming_String, Finder_String));
126
127 Packages_To_Check_By_Linker : constant String_List_Access :=
128 new String_List'((Naming_String, Linker_String));
129
130 Packages_To_Check_By_Gnatls : constant String_List_Access :=
131 new String_List'((Naming_String, Gnatls_String));
132
133 Packages_To_Check_By_Pretty : constant String_List_Access :=
134 new String_List'((Naming_String, Pretty_String));
135
136 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
137 new String_List'((Naming_String, Gnatstub_String));
138
139 Packages_To_Check_By_Metric : constant String_List_Access :=
140 new String_List'((Naming_String, Metric_String));
141
142 Packages_To_Check_By_Xref : constant String_List_Access :=
143 new String_List'((Naming_String, Xref_String));
144
145 Packages_To_Check : String_List_Access := Prj.All_Packages;
146
147 ----------------------------------
148 -- Declarations for GNATCMD use --
149 ----------------------------------
150
151 The_Command : Command_Type;
152
153 Command_Arg : Positive := 1;
154
155 My_Exit_Status : Exit_Status := Success;
156
157 Current_Work_Dir : constant String := Get_Current_Dir;
158
159 -----------------------
160 -- Local Subprograms --
161 -----------------------
162
163 procedure Add_To_Carg_Switches (Switch : String_Access);
164 -- Add a switch to the Carg_Switches table. If it is the first one,
165 -- put the switch "-cargs" at the beginning of the table.
166
167 procedure Check_Files;
168 -- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project
169 -- file is specified, without any file arguments. If it is the case,
170 -- invoke the GNAT tool with the proper list of files, derived from
171 -- the sources of the project.
172
173 function Check_Project
174 (Project : Project_Id;
175 Root_Project : Project_Id) return Boolean;
176 -- Returns True if Project = Root_Project.
177 -- For GNAT METRIC, also returns True if Project is extended by
178 -- Root_Project.
179
180 procedure Check_Relative_Executable (Name : in out String_Access);
181 -- Check if an executable is specified as a relative path.
182 -- If it is, and the path contains directory information, fail.
183 -- Otherwise, prepend the exec directory.
184 -- This procedure is only used for GNAT LINK when a project file
185 -- is specified.
186
187 function Configuration_Pragmas_File return Name_Id;
188 -- Return an argument, if there is a configuration pragmas file to be
189 -- specified for Project, otherwise return No_Name.
190 -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim
191 -- (GNAT ELIM), and gnatmetric (GNAT METRIC).
192
193 procedure Delete_Temp_Config_Files;
194 -- Delete all temporary config files
195
196 function Index (Char : Character; Str : String) return Natural;
197 -- Returns the first occurrence of Char in Str.
198 -- Returns 0 if Char is not in Str.
199
200 procedure Non_VMS_Usage;
201 -- Display usage for platforms other than VMS
202
203 procedure Process_Link;
204 -- Process GNAT LINK, when there is a project file specified.
205
206 procedure Set_Library_For
207 (Project : Project_Id;
208 There_Are_Libraries : in out Boolean);
209 -- If Project is a library project, add the correct
210 -- -L and -l switches to the linker invocation.
211
212 procedure Set_Libraries is
213 new For_Every_Project_Imported (Boolean, Set_Library_For);
214 -- Add the -L and -l switches to the linker for all
215 -- of the library projects.
216
217 procedure Test_If_Relative_Path
218 (Switch : in out String_Access;
219 Parent : String);
220 -- Test if Switch is a relative search path switch.
221 -- If it is and it includes directory information, prepend the path with
222 -- Parent.This subprogram is only called when using project files.
223
224 --------------------------
225 -- Add_To_Carg_Switches --
226 --------------------------
227
228 procedure Add_To_Carg_Switches (Switch : String_Access) is
229 begin
230 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
231
232 if Carg_Switches.Last = 0 then
233 Carg_Switches.Increment_Last;
234 Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
235 end if;
236
237 Carg_Switches.Increment_Last;
238 Carg_Switches.Table (Carg_Switches.Last) := Switch;
239 end Add_To_Carg_Switches;
240
241 -----------------
242 -- Check_Files --
243 -----------------
244
245 procedure Check_Files is
246 Add_Sources : Boolean := True;
247 Unit_Data : Prj.Unit_Data;
248 Subunit : Boolean := False;
249
250 begin
251 -- Check if there is at least one argument that is not a switch
252
253 for Index in 1 .. Last_Switches.Last loop
254 if Last_Switches.Table (Index) (1) /= '-' then
255 Add_Sources := False;
256 exit;
257 end if;
258 end loop;
259
260 -- If all arguments were switches, add the path names of
261 -- all the sources of the main project.
262
263 if Add_Sources then
264 declare
265 Current_Last : constant Integer := Last_Switches.Last;
266 begin
267 for Unit in Unit_Table.First ..
268 Unit_Table.Last (Project_Tree.Units)
269 loop
270 Unit_Data := Project_Tree.Units.Table (Unit);
271
272 -- For gnatls, we only need to put the library units,
273 -- body or spec, but not the subunits.
274
275 if The_Command = List then
276 if
277 Unit_Data.File_Names (Body_Part).Name /= No_Name
278 then
279 -- There is a body; check if it is for this
280 -- project.
281
282 if Unit_Data.File_Names (Body_Part).Project =
283 Project
284 then
285 Subunit := False;
286
287 if Unit_Data.File_Names (Specification).Name =
288 No_Name
289 then
290 -- We have a body with no spec: we need
291 -- to check if this is a subunit, because
292 -- gnatls will complain about subunits.
293
294 declare
295 Src_Ind : Source_File_Index;
296
297 begin
298 Src_Ind := Sinput.P.Load_Project_File
299 (Get_Name_String
300 (Unit_Data.File_Names
301 (Body_Part).Path));
302
303 Subunit :=
304 Sinput.P.Source_File_Is_Subunit
305 (Src_Ind);
306 end;
307 end if;
308
309 if not Subunit then
310 Last_Switches.Increment_Last;
311 Last_Switches.Table (Last_Switches.Last) :=
312 new String'
313 (Get_Name_String
314 (Unit_Data.File_Names
315 (Body_Part).Display_Name));
316 end if;
317 end if;
318
319 elsif Unit_Data.File_Names (Specification).Name /=
320 No_Name
321 then
322 -- We have a spec with no body; check if it is
323 -- for this project.
324
325 if Unit_Data.File_Names (Specification).Project =
326 Project
327 then
328 Last_Switches.Increment_Last;
329 Last_Switches.Table (Last_Switches.Last) :=
330 new String'
331 (Get_Name_String
332 (Unit_Data.File_Names
333 (Specification).Display_Name));
334 end if;
335 end if;
336
337 else
338 -- For gnatpp and gnatmetric, put all sources
339 -- of the project.
340
341 for Kind in Spec_Or_Body loop
342
343 -- Put only sources that belong to the main
344 -- project.
345
346 if Check_Project
347 (Unit_Data.File_Names (Kind).Project, Project)
348 then
349 Last_Switches.Increment_Last;
350 Last_Switches.Table (Last_Switches.Last) :=
351 new String'
352 (Get_Name_String
353 (Unit_Data.File_Names
354 (Kind).Display_Path));
355 end if;
356 end loop;
357 end if;
358 end loop;
359
360 -- If the list of files is too long, create a temporary
361 -- text file that lists these files, and pass this temp
362 -- file to gnatpp or gnatmetric using switch -files=.
363
364 if Last_Switches.Last - Current_Last >
365 Max_Files_On_The_Command_Line
366 then
367 declare
368 Temp_File_FD : File_Descriptor;
369 Buffer : String (1 .. 1_000);
370 Len : Natural;
371 OK : Boolean := True;
372
373 begin
374 Create_Temp_File (Temp_File_FD, Temp_File_Name);
375
376 if Temp_File_Name /= null then
377 for Index in Current_Last + 1 ..
378 Last_Switches.Last
379 loop
380 Len := Last_Switches.Table (Index)'Length;
381 Buffer (1 .. Len) :=
382 Last_Switches.Table (Index).all;
383 Len := Len + 1;
384 Buffer (Len) := ASCII.LF;
385 Buffer (Len + 1) := ASCII.NUL;
386 OK :=
387 Write (Temp_File_FD,
388 Buffer (1)'Address,
389 Len) = Len;
390 exit when not OK;
391 end loop;
392
393 if OK then
394 Close (Temp_File_FD, OK);
395 else
396 Close (Temp_File_FD, OK);
397 OK := False;
398 end if;
399
400 -- If there were any problem creating the temp
401 -- file, then pass the list of files.
402
403 if OK then
404
405 -- Replace the list of files with
406 -- "-files=<temp file name>".
407
408 Last_Switches.Set_Last (Current_Last + 1);
409 Last_Switches.Table (Last_Switches.Last) :=
410 new String'("-files=" & Temp_File_Name.all);
411 end if;
412 end if;
413 end;
414 end if;
415 end;
416 end if;
417 end Check_Files;
418
419 -------------------
420 -- Check_Project --
421 -------------------
422
423 function Check_Project
424 (Project : Project_Id;
425 Root_Project : Project_Id) return Boolean
426 is
427 begin
428 if Project = Root_Project then
429 return True;
430
431 elsif The_Command = Metric then
432 declare
433 Data : Project_Data :=
434 Project_Tree.Projects.Table (Root_Project);
435
436 begin
437 while Data.Extends /= No_Project loop
438 if Project = Data.Extends then
439 return True;
440 end if;
441
442 Data := Project_Tree.Projects.Table (Data.Extends);
443 end loop;
444 end;
445 end if;
446
447 return False;
448 end Check_Project;
449
450 -------------------------------
451 -- Check_Relative_Executable --
452 -------------------------------
453
454 procedure Check_Relative_Executable (Name : in out String_Access) is
455 Exec_File_Name : constant String := Name.all;
456
457 begin
458 if not Is_Absolute_Path (Exec_File_Name) then
459 for Index in Exec_File_Name'Range loop
460 if Exec_File_Name (Index) = Directory_Separator then
461 Fail ("relative executable (""" &
462 Exec_File_Name &
463 """) with directory part not allowed " &
464 "when using project files");
465 end if;
466 end loop;
467
468 Get_Name_String (Project_Tree.Projects.Table
469 (Project).Exec_Directory);
470
471 if Name_Buffer (Name_Len) /= Directory_Separator then
472 Name_Len := Name_Len + 1;
473 Name_Buffer (Name_Len) := Directory_Separator;
474 end if;
475
476 Name_Buffer (Name_Len + 1 ..
477 Name_Len + Exec_File_Name'Length) :=
478 Exec_File_Name;
479 Name_Len := Name_Len + Exec_File_Name'Length;
480 Name := new String'(Name_Buffer (1 .. Name_Len));
481 end if;
482 end Check_Relative_Executable;
483
484 --------------------------------
485 -- Configuration_Pragmas_File --
486 --------------------------------
487
488 function Configuration_Pragmas_File return Name_Id is
489 begin
490 Prj.Env.Create_Config_Pragmas_File
491 (Project, Project, Project_Tree, Include_Config_Files => False);
492 return Project_Tree.Projects.Table (Project).Config_File_Name;
493 end Configuration_Pragmas_File;
494
495 ------------------------------
496 -- Delete_Temp_Config_Files --
497 ------------------------------
498
499 procedure Delete_Temp_Config_Files is
500 Success : Boolean;
501
502 begin
503 if not Keep_Temporary_Files then
504 if Project /= No_Project then
505 for Prj in Project_Table.First ..
506 Project_Table.Last (Project_Tree.Projects)
507 loop
508 if
509 Project_Tree.Projects.Table (Prj).Config_File_Temp
510 then
511 if Verbose_Mode then
512 Output.Write_Str ("Deleting temp configuration file """);
513 Output.Write_Str
514 (Get_Name_String
515 (Project_Tree.Projects.Table
516 (Prj).Config_File_Name));
517 Output.Write_Line ("""");
518 end if;
519
520 Delete_File
521 (Name => Get_Name_String
522 (Project_Tree.Projects.Table
523 (Prj).Config_File_Name),
524 Success => Success);
525 end if;
526 end loop;
527 end if;
528
529 -- If a temporary text file that contains a list of files for a tool
530 -- has been created, delete this temporary file.
531
532 if Temp_File_Name /= null then
533 Delete_File (Temp_File_Name.all, Success);
534 end if;
535 end if;
536 end Delete_Temp_Config_Files;
537
538 -----------
539 -- Index --
540 -----------
541
542 function Index (Char : Character; Str : String) return Natural is
543 begin
544 for Index in Str'Range loop
545 if Str (Index) = Char then
546 return Index;
547 end if;
548 end loop;
549
550 return 0;
551 end Index;
552
553 ------------------
554 -- Process_Link --
555 ------------------
556
557 procedure Process_Link is
558 Look_For_Executable : Boolean := True;
559 There_Are_Libraries : Boolean := False;
560 Path_Option : constant String_Access :=
561 MLib.Linker_Library_Path_Option;
562 Prj : Project_Id := Project;
563 Arg : String_Access;
564 Last : Natural := 0;
565 Skip_Executable : Boolean := False;
566
567 begin
568 -- Add the default search directories, to be able to find
569 -- libgnat in call to MLib.Utl.Lib_Directory.
570
571 Add_Default_Search_Dirs;
572
573 Library_Paths.Set_Last (0);
574
575 -- Check if there are library project files
576
577 if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
578 Set_Libraries (Project, Project_Tree, There_Are_Libraries);
579 end if;
580
581 -- If there are, add the necessary additional switches
582
583 if There_Are_Libraries then
584
585 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
586
587 Last_Switches.Increment_Last;
588 Last_Switches.Table (Last_Switches.Last) :=
589 new String'("-L" & MLib.Utl.Lib_Directory);
590 Last_Switches.Increment_Last;
591 Last_Switches.Table (Last_Switches.Last) :=
592 new String'("-lgnarl");
593 Last_Switches.Increment_Last;
594 Last_Switches.Table (Last_Switches.Last) :=
595 new String'("-lgnat");
596
597 -- If Path_Option is not null, create the switch
598 -- ("-Wl,-rpath," or equivalent) with all the library dirs
599 -- plus the standard GNAT library dir.
600
601 if Path_Option /= null then
602 declare
603 Option : String_Access;
604 Length : Natural := Path_Option'Length;
605 Current : Natural;
606
607 begin
608 -- First, compute the exact length for the switch
609
610 for Index in
611 Library_Paths.First .. Library_Paths.Last
612 loop
613 -- Add the length of the library dir plus one
614 -- for the directory separator.
615
616 Length :=
617 Length +
618 Library_Paths.Table (Index)'Length + 1;
619 end loop;
620
621 -- Finally, add the length of the standard GNAT
622 -- library dir.
623
624 Length := Length + MLib.Utl.Lib_Directory'Length;
625 Option := new String (1 .. Length);
626 Option (1 .. Path_Option'Length) := Path_Option.all;
627 Current := Path_Option'Length;
628
629 -- Put each library dir followed by a dir separator
630
631 for Index in
632 Library_Paths.First .. Library_Paths.Last
633 loop
634 Option
635 (Current + 1 ..
636 Current +
637 Library_Paths.Table (Index)'Length) :=
638 Library_Paths.Table (Index).all;
639 Current :=
640 Current +
641 Library_Paths.Table (Index)'Length + 1;
642 Option (Current) := Path_Separator;
643 end loop;
644
645 -- Finally put the standard GNAT library dir
646
647 Option
648 (Current + 1 ..
649 Current + MLib.Utl.Lib_Directory'Length) :=
650 MLib.Utl.Lib_Directory;
651
652 -- And add the switch to the last switches
653
654 Last_Switches.Increment_Last;
655 Last_Switches.Table (Last_Switches.Last) :=
656 Option;
657 end;
658 end if;
659 end if;
660
661 -- Check if the first ALI file specified can be found, either
662 -- in the object directory of the main project or in an object
663 -- directory of a project file extended by the main project.
664 -- If the ALI file can be found, replace its name with its
665 -- absolute path.
666
667 Skip_Executable := False;
668
669 Switch_Loop : for J in 1 .. Last_Switches.Last loop
670
671 -- If we have an executable just reset the flag
672
673 if Skip_Executable then
674 Skip_Executable := False;
675
676 -- If -o, set flag so that next switch is not processed
677
678 elsif Last_Switches.Table (J).all = "-o" then
679 Skip_Executable := True;
680
681 -- Normal case
682
683 else
684 declare
685 Switch : constant String :=
686 Last_Switches.Table (J).all;
687
688 ALI_File : constant String (1 .. Switch'Length + 4) :=
689 Switch & ".ali";
690
691 Test_Existence : Boolean := False;
692
693 begin
694 Last := Switch'Length;
695
696 -- Skip real switches
697
698 if Switch'Length /= 0
699 and then Switch (Switch'First) /= '-'
700 then
701 -- Append ".ali" if file name does not end with it
702
703 if Switch'Length <= 4
704 or else Switch (Switch'Last - 3 .. Switch'Last)
705 /= ".ali"
706 then
707 Last := ALI_File'Last;
708 end if;
709
710 -- If file name includes directory information,
711 -- stop if ALI file exists.
712
713 if Is_Absolute_Path (ALI_File (1 .. Last)) then
714 Test_Existence := True;
715
716 else
717 for K in Switch'Range loop
718 if Switch (K) = '/' or else
719 Switch (K) = Directory_Separator
720 then
721 Test_Existence := True;
722 exit;
723 end if;
724 end loop;
725 end if;
726
727 if Test_Existence then
728 if Is_Regular_File (ALI_File (1 .. Last)) then
729 exit Switch_Loop;
730 end if;
731
732 -- Look in object directories if ALI file exists
733
734 else
735 Project_Loop : loop
736 declare
737 Dir : constant String :=
738 Get_Name_String
739 (Project_Tree.Projects.Table
740 (Prj).Object_Directory);
741 begin
742 if Is_Regular_File
743 (Dir &
744 Directory_Separator &
745 ALI_File (1 .. Last))
746 then
747 -- We have found the correct project, so we
748 -- replace the file with the absolute path.
749
750 Last_Switches.Table (J) :=
751 new String'
752 (Dir & Directory_Separator &
753 ALI_File (1 .. Last));
754
755 -- And we are done
756
757 exit Switch_Loop;
758 end if;
759 end;
760
761 -- Go to the project being extended,
762 -- if any.
763
764 Prj :=
765 Project_Tree.Projects.Table (Prj).Extends;
766 exit Project_Loop when Prj = No_Project;
767 end loop Project_Loop;
768 end if;
769 end if;
770 end;
771 end if;
772 end loop Switch_Loop;
773
774 -- If a relative path output file has been specified, we add
775 -- the exec directory.
776
777 for J in reverse 1 .. Last_Switches.Last - 1 loop
778 if Last_Switches.Table (J).all = "-o" then
779 Check_Relative_Executable
780 (Name => Last_Switches.Table (J + 1));
781 Look_For_Executable := False;
782 exit;
783 end if;
784 end loop;
785
786 if Look_For_Executable then
787 for J in reverse 1 .. First_Switches.Last - 1 loop
788 if First_Switches.Table (J).all = "-o" then
789 Look_For_Executable := False;
790 Check_Relative_Executable
791 (Name => First_Switches.Table (J + 1));
792 exit;
793 end if;
794 end loop;
795 end if;
796
797 -- If no executable is specified, then find the name
798 -- of the first ALI file on the command line and issue
799 -- a -o switch with the absolute path of the executable
800 -- in the exec directory.
801
802 if Look_For_Executable then
803 for J in 1 .. Last_Switches.Last loop
804 Arg := Last_Switches.Table (J);
805 Last := 0;
806
807 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
808 if Arg'Length > 4
809 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
810 then
811 Last := Arg'Last - 4;
812
813 elsif Is_Regular_File (Arg.all & ".ali") then
814 Last := Arg'Last;
815 end if;
816
817 if Last /= 0 then
818 Last_Switches.Increment_Last;
819 Last_Switches.Table (Last_Switches.Last) :=
820 new String'("-o");
821 Get_Name_String
822 (Project_Tree.Projects.Table
823 (Project).Exec_Directory);
824 Last_Switches.Increment_Last;
825 Last_Switches.Table (Last_Switches.Last) :=
826 new String'(Name_Buffer (1 .. Name_Len) &
827 Directory_Separator &
828 Base_Name (Arg (Arg'First .. Last)) &
829 Get_Executable_Suffix.all);
830 exit;
831 end if;
832 end if;
833 end loop;
834 end if;
835 end Process_Link;
836
837 ---------------------
838 -- Set_Library_For --
839 ---------------------
840
841 procedure Set_Library_For
842 (Project : Project_Id;
843 There_Are_Libraries : in out Boolean)
844 is
845 Path_Option : constant String_Access :=
846 MLib.Linker_Library_Path_Option;
847
848 begin
849 -- Case of library project
850
851 if Project_Tree.Projects.Table (Project).Library then
852 There_Are_Libraries := True;
853
854 -- Add the -L switch
855
856 Last_Switches.Increment_Last;
857 Last_Switches.Table (Last_Switches.Last) :=
858 new String'("-L" &
859 Get_Name_String
860 (Project_Tree.Projects.Table
861 (Project).Library_Dir));
862
863 -- Add the -l switch
864
865 Last_Switches.Increment_Last;
866 Last_Switches.Table (Last_Switches.Last) :=
867 new String'("-l" &
868 Get_Name_String
869 (Project_Tree.Projects.Table
870 (Project).Library_Name));
871
872 -- Add the directory to table Library_Paths, to be processed later
873 -- if library is not static and if Path_Option is not null.
874
875 if Project_Tree.Projects.Table (Project).Library_Kind /=
876 Static
877 and then Path_Option /= null
878 then
879 Library_Paths.Increment_Last;
880 Library_Paths.Table (Library_Paths.Last) :=
881 new String'(Get_Name_String
882 (Project_Tree.Projects.Table
883 (Project).Library_Dir));
884 end if;
885 end if;
886 end Set_Library_For;
887
888 ---------------------------
889 -- Test_If_Relative_Path --
890 ---------------------------
891
892 procedure Test_If_Relative_Path
893 (Switch : in out String_Access;
894 Parent : String)
895 is
896 begin
897 if Switch /= null then
898
899 declare
900 Sw : String (1 .. Switch'Length);
901 Start : Positive := 1;
902
903 begin
904 Sw := Switch.all;
905
906 if Sw (1) = '-' then
907 if Sw'Length >= 3
908 and then (Sw (2) = 'A' or else
909 Sw (2) = 'I' or else
910 Sw (2) = 'L')
911 then
912 Start := 3;
913
914 if Sw = "-I-" then
915 return;
916 end if;
917
918 elsif Sw'Length >= 4
919 and then (Sw (2 .. 3) = "aL" or else
920 Sw (2 .. 3) = "aO" or else
921 Sw (2 .. 3) = "aI")
922 then
923 Start := 4;
924
925 elsif Sw'Length >= 7
926 and then Sw (2 .. 6) = "-RTS="
927 then
928 Start := 7;
929 else
930 return;
931 end if;
932 end if;
933
934 -- If the path is relative, test if it includes directory
935 -- information. If it does, prepend Parent to the path.
936
937 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
938 for J in Start .. Sw'Last loop
939 if Sw (J) = Directory_Separator then
940 Switch :=
941 new String'
942 (Sw (1 .. Start - 1) &
943 Parent &
944 Directory_Separator &
945 Sw (Start .. Sw'Last));
946 return;
947 end if;
948 end loop;
949 end if;
950 end;
951 end if;
952 end Test_If_Relative_Path;
953
954 -------------------
955 -- Non_VMS_Usage --
956 -------------------
957
958 procedure Non_VMS_Usage is
959 begin
960 Output_Version;
961 New_Line;
962 Put_Line ("List of available commands");
963 New_Line;
964
965 for C in Command_List'Range loop
966 if not Command_List (C).VMS_Only then
967 Put ("gnat " & To_Lower (Command_List (C).Cname.all));
968 Set_Col (25);
969 Put (Command_List (C).Unixcmd.all);
970
971 declare
972 Sws : Argument_List_Access renames Command_List (C).Unixsws;
973 begin
974 if Sws /= null then
975 for J in Sws'Range loop
976 Put (' ');
977 Put (Sws (J).all);
978 end loop;
979 end if;
980 end;
981
982 New_Line;
983 end if;
984 end loop;
985
986 New_Line;
987 Put_Line ("Commands find, list, metric, pretty, stub and xref accept " &
988 "project file switches -vPx, -Pprj and -Xnam=val");
989 New_Line;
990 end Non_VMS_Usage;
991
992 -------------------------------------
993 -- Start of processing for GNATCmd --
994 -------------------------------------
995
996 begin
997 -- Initializations
998
999 Namet.Initialize;
1000 Csets.Initialize;
1001
1002 Snames.Initialize;
1003
1004 Prj.Initialize (Project_Tree);
1005
1006 Last_Switches.Init;
1007 Last_Switches.Set_Last (0);
1008
1009 First_Switches.Init;
1010 First_Switches.Set_Last (0);
1011 Carg_Switches.Init;
1012 Carg_Switches.Set_Last (0);
1013
1014 VMS_Conv.Initialize;
1015
1016 -- Add the directory where the GNAT driver is invoked in front of the
1017 -- path, if the GNAT driver is invoked with directory information.
1018 -- Only do this if the platform is not VMS, where the notion of path
1019 -- does not really exist.
1020
1021 if not OpenVMS then
1022 declare
1023 Command : constant String := Command_Name;
1024
1025 begin
1026 for Index in reverse Command'Range loop
1027 if Command (Index) = Directory_Separator then
1028 declare
1029 Absolute_Dir : constant String :=
1030 Normalize_Pathname
1031 (Command (Command'First .. Index));
1032
1033 PATH : constant String :=
1034 Absolute_Dir &
1035 Path_Separator &
1036 Getenv ("PATH").all;
1037
1038 begin
1039 Setenv ("PATH", PATH);
1040 end;
1041
1042 exit;
1043 end if;
1044 end loop;
1045 end;
1046 end if;
1047
1048 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1049 -- filenames and pathnames to Unix style.
1050
1051 if Hostparm.OpenVMS
1052 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1053 then
1054 VMS_Conversion (The_Command);
1055
1056 -- If not on VMS, scan the command line directly
1057
1058 else
1059 if Argument_Count = 0 then
1060 Non_VMS_Usage;
1061 return;
1062 else
1063 begin
1064 loop
1065 if Argument_Count > Command_Arg
1066 and then Argument (Command_Arg) = "-v"
1067 then
1068 Verbose_Mode := True;
1069 Command_Arg := Command_Arg + 1;
1070
1071 elsif Argument_Count > Command_Arg
1072 and then Argument (Command_Arg) = "-dn"
1073 then
1074 Keep_Temporary_Files := True;
1075 Command_Arg := Command_Arg + 1;
1076
1077 else
1078 exit;
1079 end if;
1080 end loop;
1081
1082 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1083
1084 if Command_List (The_Command).VMS_Only then
1085 Non_VMS_Usage;
1086 Fail
1087 ("Command """,
1088 Command_List (The_Command).Cname.all,
1089 """ can only be used on VMS");
1090 end if;
1091
1092 exception
1093 when Constraint_Error =>
1094
1095 -- Check if it is an alternate command
1096
1097 declare
1098 Alternate : Alternate_Command;
1099
1100 begin
1101 Alternate := Alternate_Command'Value
1102 (Argument (Command_Arg));
1103 The_Command := Corresponding_To (Alternate);
1104
1105 exception
1106 when Constraint_Error =>
1107 Non_VMS_Usage;
1108 Fail ("Unknown command: ", Argument (Command_Arg));
1109 end;
1110 end;
1111
1112 -- Get the arguments from the command line and from the eventual
1113 -- argument file(s) specified on the command line.
1114
1115 for Arg in Command_Arg + 1 .. Argument_Count loop
1116 declare
1117 The_Arg : constant String := Argument (Arg);
1118
1119 begin
1120 -- Check if an argument file is specified
1121
1122 if The_Arg (The_Arg'First) = '@' then
1123 declare
1124 Arg_File : Ada.Text_IO.File_Type;
1125 Line : String (1 .. 256);
1126 Last : Natural;
1127
1128 begin
1129 -- Open the file and fail if the file cannot be found
1130
1131 begin
1132 Open
1133 (Arg_File, In_File,
1134 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1135
1136 exception
1137 when others =>
1138 Put
1139 (Standard_Error, "Cannot open argument file """);
1140 Put
1141 (Standard_Error,
1142 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1143
1144 Put_Line (Standard_Error, """");
1145 raise Error_Exit;
1146 end;
1147
1148 -- Read line by line and put the content of each
1149 -- non empty line in the Last_Switches table.
1150
1151 while not End_Of_File (Arg_File) loop
1152 Get_Line (Arg_File, Line, Last);
1153
1154 if Last /= 0 then
1155 Last_Switches.Increment_Last;
1156 Last_Switches.Table (Last_Switches.Last) :=
1157 new String'(Line (1 .. Last));
1158 end if;
1159 end loop;
1160
1161 Close (Arg_File);
1162 end;
1163
1164 else
1165 -- It is not an argument file; just put the argument in
1166 -- the Last_Switches table.
1167
1168 Last_Switches.Increment_Last;
1169 Last_Switches.Table (Last_Switches.Last) :=
1170 new String'(The_Arg);
1171 end if;
1172 end;
1173 end loop;
1174 end if;
1175 end if;
1176
1177 declare
1178 Program : constant String :=
1179 Program_Name (Command_List (The_Command).Unixcmd.all).all;
1180
1181 Exec_Path : String_Access;
1182
1183 begin
1184 -- First deal with built-in command(s)
1185
1186 if The_Command = Setup then
1187 Process_Setup :
1188 declare
1189 Arg_Num : Positive := 1;
1190 Argv : String_Access;
1191
1192 begin
1193 while Arg_Num <= Last_Switches.Last loop
1194 Argv := Last_Switches.Table (Arg_Num);
1195
1196 if Argv (Argv'First) /= '-' then
1197 Fail ("invalid parameter """, Argv.all, """");
1198
1199 else
1200 if Argv'Length = 1 then
1201 Fail
1202 ("switch character cannot be followed by a blank");
1203 end if;
1204
1205 -- -vPx Specify verbosity while parsing project files
1206
1207 if Argv'Length = 4
1208 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1209 then
1210 case Argv (Argv'Last) is
1211 when '0' =>
1212 Current_Verbosity := Prj.Default;
1213 when '1' =>
1214 Current_Verbosity := Prj.Medium;
1215 when '2' =>
1216 Current_Verbosity := Prj.High;
1217 when others =>
1218 Fail ("Invalid switch: ", Argv.all);
1219 end case;
1220
1221 -- -Pproject_file Specify project file to be used
1222
1223 elsif Argv (Argv'First + 1) = 'P' then
1224
1225 -- Only one -P switch can be used
1226
1227 if Project_File /= null then
1228 Fail
1229 (Argv.all,
1230 ": second project file forbidden (first is """,
1231 Project_File.all & """)");
1232
1233 elsif Argv'Length = 2 then
1234
1235 -- There is space between -P and the project file
1236 -- name. -P cannot be the last option.
1237
1238 if Arg_Num = Last_Switches.Last then
1239 Fail ("project file name missing after -P");
1240
1241 else
1242 Arg_Num := Arg_Num + 1;
1243 Argv := Last_Switches.Table (Arg_Num);
1244
1245 -- After -P, there must be a project file name,
1246 -- not another switch.
1247
1248 if Argv (Argv'First) = '-' then
1249 Fail ("project file name missing after -P");
1250
1251 else
1252 Project_File := new String'(Argv.all);
1253 end if;
1254 end if;
1255
1256 else
1257 -- No space between -P and project file name
1258
1259 Project_File :=
1260 new String'(Argv (Argv'First + 2 .. Argv'Last));
1261 end if;
1262
1263 -- -Xexternal=value Specify an external reference to be
1264 -- used in project files
1265
1266 elsif Argv'Length >= 5
1267 and then Argv (Argv'First + 1) = 'X'
1268 then
1269 declare
1270 Equal_Pos : constant Natural :=
1271 Index ('=', Argv (Argv'First + 2 .. Argv'Last));
1272 begin
1273 if Equal_Pos >= Argv'First + 3 and then
1274 Equal_Pos /= Argv'Last then
1275 Add
1276 (External_Name =>
1277 Argv (Argv'First + 2 .. Equal_Pos - 1),
1278 Value => Argv (Equal_Pos + 1 .. Argv'Last));
1279 else
1280 Fail
1281 (Argv.all,
1282 " is not a valid external assignment.");
1283 end if;
1284 end;
1285
1286 elsif Argv.all = "-v" then
1287 Verbose_Mode := True;
1288
1289 elsif Argv.all = "-q" then
1290 Quiet_Output := True;
1291
1292 else
1293 Fail ("invalid parameter """, Argv.all, """");
1294 end if;
1295 end if;
1296
1297 Arg_Num := Arg_Num + 1;
1298 end loop;
1299
1300 if Project_File = null then
1301 Fail ("no project file specified");
1302 end if;
1303
1304 Setup_Projects := True;
1305
1306 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1307
1308 -- Missing directories are created during processing of the
1309 -- project tree.
1310
1311 Prj.Pars.Parse
1312 (Project => Project,
1313 In_Tree => Project_Tree,
1314 Project_File_Name => Project_File.all,
1315 Packages_To_Check => All_Packages);
1316
1317 if Project = Prj.No_Project then
1318 Fail ("""", Project_File.all, """ processing failed");
1319 end if;
1320
1321 -- Processing is done
1322
1323 return;
1324 end Process_Setup;
1325 end if;
1326
1327 -- Locate the executable for the command
1328
1329 Exec_Path := Locate_Exec_On_Path (Program);
1330
1331 if Exec_Path = null then
1332 Put_Line (Standard_Error, "Couldn't locate " & Program);
1333 raise Error_Exit;
1334 end if;
1335
1336 -- If there are switches for the executable, put them as first switches
1337
1338 if Command_List (The_Command).Unixsws /= null then
1339 for J in Command_List (The_Command).Unixsws'Range loop
1340 First_Switches.Increment_Last;
1341 First_Switches.Table (First_Switches.Last) :=
1342 Command_List (The_Command).Unixsws (J);
1343 end loop;
1344 end if;
1345
1346 -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file
1347 -- related switches.
1348
1349 if The_Command = Bind
1350 or else The_Command = Elim
1351 or else The_Command = Find
1352 or else The_Command = Link
1353 or else The_Command = List
1354 or else The_Command = Xref
1355 or else The_Command = Pretty
1356 or else The_Command = Stub
1357 or else The_Command = Metric
1358 then
1359 case The_Command is
1360 when Bind =>
1361 Tool_Package_Name := Name_Binder;
1362 Packages_To_Check := Packages_To_Check_By_Binder;
1363 when Elim =>
1364 Tool_Package_Name := Name_Eliminate;
1365 Packages_To_Check := Packages_To_Check_By_Eliminate;
1366 when Find =>
1367 Tool_Package_Name := Name_Finder;
1368 Packages_To_Check := Packages_To_Check_By_Finder;
1369 when Link =>
1370 Tool_Package_Name := Name_Linker;
1371 Packages_To_Check := Packages_To_Check_By_Linker;
1372 when List =>
1373 Tool_Package_Name := Name_Gnatls;
1374 Packages_To_Check := Packages_To_Check_By_Gnatls;
1375 when Metric =>
1376 Tool_Package_Name := Name_Metrics;
1377 Packages_To_Check := Packages_To_Check_By_Metric;
1378 when Pretty =>
1379 Tool_Package_Name := Name_Pretty_Printer;
1380 Packages_To_Check := Packages_To_Check_By_Pretty;
1381 when Stub =>
1382 Tool_Package_Name := Name_Gnatstub;
1383 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1384 when Xref =>
1385 Tool_Package_Name := Name_Cross_Reference;
1386 Packages_To_Check := Packages_To_Check_By_Xref;
1387 when others =>
1388 null;
1389 end case;
1390
1391 -- Check that the switches are consistent.
1392 -- Detect project file related switches.
1393
1394 Inspect_Switches :
1395 declare
1396 Arg_Num : Positive := 1;
1397 Argv : String_Access;
1398
1399 procedure Remove_Switch (Num : Positive);
1400 -- Remove a project related switch from table Last_Switches
1401
1402 -------------------
1403 -- Remove_Switch --
1404 -------------------
1405
1406 procedure Remove_Switch (Num : Positive) is
1407 begin
1408 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1409 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1410 Last_Switches.Decrement_Last;
1411 end Remove_Switch;
1412
1413 -- Start of processing for Inspect_Switches
1414
1415 begin
1416 while Arg_Num <= Last_Switches.Last loop
1417 Argv := Last_Switches.Table (Arg_Num);
1418
1419 if Argv (Argv'First) = '-' then
1420 if Argv'Length = 1 then
1421 Fail
1422 ("switch character cannot be followed by a blank");
1423 end if;
1424
1425 -- The two style project files (-p and -P) cannot be used
1426 -- together
1427
1428 if (The_Command = Find or else The_Command = Xref)
1429 and then Argv (2) = 'p'
1430 then
1431 Old_Project_File_Used := True;
1432 if Project_File /= null then
1433 Fail ("-P and -p cannot be used together");
1434 end if;
1435 end if;
1436
1437 -- -vPx Specify verbosity while parsing project files
1438
1439 if Argv'Length = 4
1440 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1441 then
1442 case Argv (Argv'Last) is
1443 when '0' =>
1444 Current_Verbosity := Prj.Default;
1445 when '1' =>
1446 Current_Verbosity := Prj.Medium;
1447 when '2' =>
1448 Current_Verbosity := Prj.High;
1449 when others =>
1450 Fail ("Invalid switch: ", Argv.all);
1451 end case;
1452
1453 Remove_Switch (Arg_Num);
1454
1455 -- -Pproject_file Specify project file to be used
1456
1457 elsif Argv (Argv'First + 1) = 'P' then
1458
1459 -- Only one -P switch can be used
1460
1461 if Project_File /= null then
1462 Fail
1463 (Argv.all,
1464 ": second project file forbidden (first is """,
1465 Project_File.all & """)");
1466
1467 -- The two style project files (-p and -P) cannot be
1468 -- used together.
1469
1470 elsif Old_Project_File_Used then
1471 Fail ("-p and -P cannot be used together");
1472
1473 elsif Argv'Length = 2 then
1474
1475 -- There is space between -P and the project file
1476 -- name. -P cannot be the last option.
1477
1478 if Arg_Num = Last_Switches.Last then
1479 Fail ("project file name missing after -P");
1480
1481 else
1482 Remove_Switch (Arg_Num);
1483 Argv := Last_Switches.Table (Arg_Num);
1484
1485 -- After -P, there must be a project file name,
1486 -- not another switch.
1487
1488 if Argv (Argv'First) = '-' then
1489 Fail ("project file name missing after -P");
1490
1491 else
1492 Project_File := new String'(Argv.all);
1493 end if;
1494 end if;
1495
1496 else
1497 -- No space between -P and project file name
1498
1499 Project_File :=
1500 new String'(Argv (Argv'First + 2 .. Argv'Last));
1501 end if;
1502
1503 Remove_Switch (Arg_Num);
1504
1505 -- -Xexternal=value Specify an external reference to be
1506 -- used in project files
1507
1508 elsif Argv'Length >= 5
1509 and then Argv (Argv'First + 1) = 'X'
1510 then
1511 declare
1512 Equal_Pos : constant Natural :=
1513 Index ('=', Argv (Argv'First + 2 .. Argv'Last));
1514 begin
1515 if Equal_Pos >= Argv'First + 3 and then
1516 Equal_Pos /= Argv'Last then
1517 Add (External_Name =>
1518 Argv (Argv'First + 2 .. Equal_Pos - 1),
1519 Value => Argv (Equal_Pos + 1 .. Argv'Last));
1520 else
1521 Fail
1522 (Argv.all,
1523 " is not a valid external assignment.");
1524 end if;
1525 end;
1526
1527 Remove_Switch (Arg_Num);
1528
1529 else
1530 Arg_Num := Arg_Num + 1;
1531 end if;
1532
1533 else
1534 Arg_Num := Arg_Num + 1;
1535 end if;
1536 end loop;
1537 end Inspect_Switches;
1538 end if;
1539
1540 -- If there is a project file specified, parse it, get the switches
1541 -- for the tool and setup PATH environment variables.
1542
1543 if Project_File /= null then
1544 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1545
1546 Prj.Pars.Parse
1547 (Project => Project,
1548 In_Tree => Project_Tree,
1549 Project_File_Name => Project_File.all,
1550 Packages_To_Check => Packages_To_Check);
1551
1552 if Project = Prj.No_Project then
1553 Fail ("""", Project_File.all, """ processing failed");
1554 end if;
1555
1556 -- Check if a package with the name of the tool is in the project
1557 -- file and if there is one, get the switches, if any, and scan them.
1558
1559 declare
1560 Data : constant Prj.Project_Data :=
1561 Project_Tree.Projects.Table (Project);
1562
1563 Pkg : constant Prj.Package_Id :=
1564 Prj.Util.Value_Of
1565 (Name => Tool_Package_Name,
1566 In_Packages => Data.Decl.Packages,
1567 In_Tree => Project_Tree);
1568
1569 Element : Package_Element;
1570
1571 Default_Switches_Array : Array_Element_Id;
1572
1573 The_Switches : Prj.Variable_Value;
1574 Current : Prj.String_List_Id;
1575 The_String : String_Element;
1576
1577 begin
1578 if Pkg /= No_Package then
1579 Element := Project_Tree.Packages.Table (Pkg);
1580
1581 -- Packages Gnatls has a single attribute Switches, that is
1582 -- not an associative array.
1583
1584 if The_Command = List then
1585 The_Switches :=
1586 Prj.Util.Value_Of
1587 (Variable_Name => Snames.Name_Switches,
1588 In_Variables => Element.Decl.Attributes,
1589 In_Tree => Project_Tree);
1590
1591 -- Packages Binder (for gnatbind), Cross_Reference (for
1592 -- gnatxref), Linker (for gnatlink) Finder (for gnatfind),
1593 -- Pretty_Printer (for gnatpp) Eliminate (for gnatelim) and
1594 -- Metric (for gnatmetric) have an attributed Switches,
1595 -- an associative array, indexed by the name of the file.
1596
1597 -- They also have an attribute Default_Switches, indexed
1598 -- by the name of the programming language.
1599
1600 else
1601 if The_Switches.Kind = Prj.Undefined then
1602 Default_Switches_Array :=
1603 Prj.Util.Value_Of
1604 (Name => Name_Default_Switches,
1605 In_Arrays => Element.Decl.Arrays,
1606 In_Tree => Project_Tree);
1607 The_Switches := Prj.Util.Value_Of
1608 (Index => Name_Ada,
1609 Src_Index => 0,
1610 In_Array => Default_Switches_Array,
1611 In_Tree => Project_Tree);
1612 end if;
1613 end if;
1614
1615 -- If there are switches specified in the package of the
1616 -- project file corresponding to the tool, scan them.
1617
1618 case The_Switches.Kind is
1619 when Prj.Undefined =>
1620 null;
1621
1622 when Prj.Single =>
1623 declare
1624 Switch : constant String :=
1625 Get_Name_String (The_Switches.Value);
1626
1627 begin
1628 if Switch'Length > 0 then
1629 First_Switches.Increment_Last;
1630 First_Switches.Table (First_Switches.Last) :=
1631 new String'(Switch);
1632 end if;
1633 end;
1634
1635 when Prj.List =>
1636 Current := The_Switches.Values;
1637 while Current /= Prj.Nil_String loop
1638 The_String := Project_Tree.String_Elements.
1639 Table (Current);
1640
1641 declare
1642 Switch : constant String :=
1643 Get_Name_String (The_String.Value);
1644
1645 begin
1646 if Switch'Length > 0 then
1647 First_Switches.Increment_Last;
1648 First_Switches.Table (First_Switches.Last) :=
1649 new String'(Switch);
1650 end if;
1651 end;
1652
1653 Current := The_String.Next;
1654 end loop;
1655 end case;
1656 end if;
1657 end;
1658
1659 if The_Command = Bind
1660 or else The_Command = Link
1661 or else The_Command = Elim
1662 then
1663 Change_Dir
1664 (Get_Name_String
1665 (Project_Tree.Projects.Table
1666 (Project).Object_Directory));
1667 end if;
1668
1669 -- Set up the env vars for project path files
1670
1671 Prj.Env.Set_Ada_Paths
1672 (Project, Project_Tree, Including_Libraries => False);
1673
1674 -- For gnatstub, gnatmetric, gnatpp and gnatelim, create
1675 -- a configuration pragmas file, if necessary.
1676
1677 if The_Command = Pretty
1678 or else The_Command = Metric
1679 or else The_Command = Stub
1680 or else The_Command = Elim
1681 then
1682 -- If -cargs is one of the switches, move the following
1683 -- switches to the Carg_Switches table.
1684
1685 for J in 1 .. First_Switches.Last loop
1686 if First_Switches.Table (J).all = "-cargs" then
1687 for K in J + 1 .. First_Switches.Last loop
1688 Add_To_Carg_Switches (First_Switches.Table (K));
1689 end loop;
1690 First_Switches.Set_Last (J - 1);
1691 exit;
1692 end if;
1693 end loop;
1694
1695 for J in 1 .. Last_Switches.Last loop
1696 if Last_Switches.Table (J).all = "-cargs" then
1697 for K in J + 1 .. Last_Switches.Last loop
1698 Add_To_Carg_Switches (Last_Switches.Table (K));
1699 end loop;
1700 Last_Switches.Set_Last (J - 1);
1701 exit;
1702 end if;
1703 end loop;
1704
1705 declare
1706 CP_File : constant Name_Id := Configuration_Pragmas_File;
1707 begin
1708 if CP_File /= No_Name then
1709 if The_Command = Elim then
1710 First_Switches.Increment_Last;
1711 First_Switches.Table (First_Switches.Last) :=
1712 new String'("-C" & Get_Name_String (CP_File));
1713 else
1714 Add_To_Carg_Switches
1715 (new String'("-gnatec=" & Get_Name_String (CP_File)));
1716 end if;
1717 end if;
1718 end;
1719 end if;
1720
1721 if The_Command = Link then
1722 Process_Link;
1723 end if;
1724
1725 if The_Command = Link or The_Command = Bind then
1726
1727 -- For files that are specified as relative paths with directory
1728 -- information, we convert them to absolute paths, with parent
1729 -- being the current working directory if specified on the command
1730 -- line and the project directory if specified in the project
1731 -- file. This is what gnatmake is doing for linker and binder
1732 -- arguments.
1733
1734 for J in 1 .. Last_Switches.Last loop
1735 Test_If_Relative_Path
1736 (Last_Switches.Table (J), Current_Work_Dir);
1737 end loop;
1738
1739 Get_Name_String
1740 (Project_Tree.Projects.Table (Project).Directory);
1741
1742 declare
1743 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
1744
1745 begin
1746 for J in 1 .. First_Switches.Last loop
1747 Test_If_Relative_Path
1748 (First_Switches.Table (J), Project_Dir);
1749 end loop;
1750 end;
1751
1752 elsif The_Command = Stub then
1753 declare
1754 Data : constant Prj.Project_Data :=
1755 Project_Tree.Projects.Table (Project);
1756 File_Index : Integer := 0;
1757 Dir_Index : Integer := 0;
1758 Last : constant Integer := Last_Switches.Last;
1759
1760 begin
1761 for Index in 1 .. Last loop
1762 if Last_Switches.Table (Index)
1763 (Last_Switches.Table (Index)'First) /= '-'
1764 then
1765 File_Index := Index;
1766 exit;
1767 end if;
1768 end loop;
1769
1770 -- If the naming scheme of the project file is not standard,
1771 -- and if the file name ends with the spec suffix, then
1772 -- indicate to gnatstub the name of the body file with
1773 -- a -o switch.
1774
1775 if Data.Naming.Ada_Spec_Suffix /=
1776 Prj.Default_Ada_Spec_Suffix
1777 then
1778 if File_Index /= 0 then
1779 declare
1780 Spec : constant String :=
1781 Base_Name (Last_Switches.Table (File_Index).all);
1782 Last : Natural := Spec'Last;
1783
1784 begin
1785 Get_Name_String (Data.Naming.Ada_Spec_Suffix);
1786
1787 if Spec'Length > Name_Len
1788 and then Spec (Last - Name_Len + 1 .. Last) =
1789 Name_Buffer (1 .. Name_Len)
1790 then
1791 Last := Last - Name_Len;
1792 Get_Name_String (Data.Naming.Ada_Body_Suffix);
1793 Last_Switches.Increment_Last;
1794 Last_Switches.Table (Last_Switches.Last) :=
1795 new String'("-o");
1796 Last_Switches.Increment_Last;
1797 Last_Switches.Table (Last_Switches.Last) :=
1798 new String'(Spec (Spec'First .. Last) &
1799 Name_Buffer (1 .. Name_Len));
1800 end if;
1801 end;
1802 end if;
1803 end if;
1804
1805 -- Add the directory of the spec as the destination directory
1806 -- of the body, if there is no destination directory already
1807 -- specified.
1808
1809 if File_Index /= 0 then
1810 for Index in File_Index + 1 .. Last loop
1811 if Last_Switches.Table (Index)
1812 (Last_Switches.Table (Index)'First) /= '-'
1813 then
1814 Dir_Index := Index;
1815 exit;
1816 end if;
1817 end loop;
1818
1819 if Dir_Index = 0 then
1820 Last_Switches.Increment_Last;
1821 Last_Switches.Table (Last_Switches.Last) :=
1822 new String'
1823 (Dir_Name (Last_Switches.Table (File_Index).all));
1824 end if;
1825 end if;
1826 end;
1827 end if;
1828
1829 -- For gnatmetric, the generated files should be put in the
1830 -- object directory. This must be the first switch, because it may
1831 -- be overriden by a switch in package Metrics in the project file
1832 -- or by a command line option.
1833
1834 if The_Command = Metric then
1835 First_Switches.Increment_Last;
1836 First_Switches.Table (2 .. First_Switches.Last) :=
1837 First_Switches.Table (1 .. First_Switches.Last - 1);
1838 First_Switches.Table (1) :=
1839 new String'("-d=" &
1840 Get_Name_String
1841 (Project_Tree.Projects.Table
1842 (Project).Object_Directory));
1843 end if;
1844
1845 -- For gnat pretty and gnat metric, if no file has been put on the
1846 -- command line, call the tool with all the sources of the main
1847 -- project.
1848
1849 if The_Command = Pretty or else
1850 The_Command = Metric or else
1851 The_Command = List
1852 then
1853 Check_Files;
1854 end if;
1855 end if;
1856
1857 -- Gather all the arguments and invoke the executable
1858
1859 declare
1860 The_Args : Argument_List
1861 (1 .. First_Switches.Last +
1862 Last_Switches.Last +
1863 Carg_Switches.Last);
1864 Arg_Num : Natural := 0;
1865
1866 begin
1867 for J in 1 .. First_Switches.Last loop
1868 Arg_Num := Arg_Num + 1;
1869 The_Args (Arg_Num) := First_Switches.Table (J);
1870 end loop;
1871
1872 for J in 1 .. Last_Switches.Last loop
1873 Arg_Num := Arg_Num + 1;
1874 The_Args (Arg_Num) := Last_Switches.Table (J);
1875 end loop;
1876
1877 for J in 1 .. Carg_Switches.Last loop
1878 Arg_Num := Arg_Num + 1;
1879 The_Args (Arg_Num) := Carg_Switches.Table (J);
1880 end loop;
1881
1882 -- If Display_Command is on, only display the generated command
1883
1884 if Display_Command then
1885 Put (Standard_Error, "generated command -->");
1886 Put (Standard_Error, Exec_Path.all);
1887
1888 for Arg in The_Args'Range loop
1889 Put (Standard_Error, " ");
1890 Put (Standard_Error, The_Args (Arg).all);
1891 end loop;
1892
1893 Put (Standard_Error, "<--");
1894 New_Line (Standard_Error);
1895 raise Normal_Exit;
1896 end if;
1897
1898 if Verbose_Mode then
1899 Output.Write_Str (Exec_Path.all);
1900
1901 for Arg in The_Args'Range loop
1902 Output.Write_Char (' ');
1903 Output.Write_Str (The_Args (Arg).all);
1904 end loop;
1905
1906 Output.Write_Eol;
1907 end if;
1908
1909 My_Exit_Status :=
1910 Exit_Status (Spawn (Exec_Path.all, The_Args));
1911 raise Normal_Exit;
1912 end;
1913 end;
1914
1915 exception
1916 when Error_Exit =>
1917 Prj.Env.Delete_All_Path_Files (Project_Tree);
1918 Delete_Temp_Config_Files;
1919 Set_Exit_Status (Failure);
1920
1921 when Normal_Exit =>
1922 Prj.Env.Delete_All_Path_Files (Project_Tree);
1923 Delete_Temp_Config_Files;
1924
1925 -- Since GNATCmd is normally called from DCL (the VMS shell),
1926 -- it must return an understandable VMS exit status. However
1927 -- the exit status returned *to* GNATCmd is a Posix style code,
1928 -- so we test it and return just a simple success or failure on VMS.
1929
1930 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
1931 Set_Exit_Status (Failure);
1932 else
1933 Set_Exit_Status (My_Exit_Status);
1934 end if;
1935 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org