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