?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
gcc/ChangeLog:
[official-gcc.git] / gcc / ada / gnatcmd.adb
blobce880ca4cc68a23d08e3252822c98a21a2b832ed
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-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Csets;
27 with Gnatvsn;
28 with Makeutl; use Makeutl;
29 with Namet; use Namet;
30 with Opt; use Opt;
31 with Osint; use Osint;
32 with Output; use Output;
33 with Prj; use Prj;
34 with Prj.Env;
35 with Prj.Ext; use Prj.Ext;
36 with Prj.Pars;
37 with Prj.Tree; use Prj.Tree;
38 with Prj.Util; use Prj.Util;
39 with Sdefault;
40 with Sinput.P;
41 with Snames; use Snames;
42 with Stringt;
43 with Switch; use Switch;
44 with Table;
45 with Tempdir;
46 with Types; use Types;
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.Directory_Operations; use GNAT.Directory_Operations;
53 with GNAT.OS_Lib; use GNAT.OS_Lib;
54
55 procedure GNATCmd is
56 Gprbuild : constant String := "gprbuild";
57 Gprclean : constant String := "gprclean";
58 Gprname : constant String := "gprname";
59 Gprls : constant String := "gprls";
60
61 Error_Exit : exception;
62 -- Raise this exception if error detected
63
64 type Command_Type is
65 (Bind,
66 Chop,
67 Clean,
68 Compile,
69 Check,
70 Elim,
71 Find,
72 Krunch,
73 Link,
74 List,
75 Make,
76 Metric,
77 Name,
78 Preprocess,
79 Pretty,
80 Stack,
81 Stub,
82 Test,
83 Xref,
84 Undefined);
85
86 subtype Real_Command_Type is Command_Type range Bind .. Xref;
87 -- All real command types (excludes only Undefined).
88
89 type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
90 -- Alternate command label
91
92 Corresponding_To : constant array (Alternate_Command) of Command_Type :=
93 (Comp => Compile,
94 Ls => List,
95 Kr => Krunch,
96 Prep => Preprocess,
97 Pp => Pretty);
98 -- Mapping of alternate commands to commands
99
100 Call_GPR_Tool : Boolean := False;
101 -- True when a GPR tool should be called, if available
102
103 Project_Node_Tree : Project_Node_Tree_Ref;
104 Project_File : String_Access;
105 Project : Prj.Project_Id;
106 Current_Verbosity : Prj.Verbosity := Prj.Default;
107 Tool_Package_Name : Name_Id := No_Name;
108
109 Project_Tree : constant Project_Tree_Ref :=
110 new Project_Tree_Data (Is_Root_Tree => True);
111 -- The project tree
112
113 All_Projects : Boolean := False;
114
115 Temp_File_Name : Path_Name_Type := No_Path;
116 -- The name of the temporary text file to put a list of source/object
117 -- files to pass to a tool.
118
119 package First_Switches is new Table.Table
120 (Table_Component_Type => String_Access,
121 Table_Index_Type => Integer,
122 Table_Low_Bound => 1,
123 Table_Initial => 20,
124 Table_Increment => 100,
125 Table_Name => "Gnatcmd.First_Switches");
126 -- A table to keep the switches from the project file
127
128 package Last_Switches is new Table.Table
129 (Table_Component_Type => String_Access,
130 Table_Index_Type => Integer,
131 Table_Low_Bound => 1,
132 Table_Initial => 20,
133 Table_Increment => 100,
134 Table_Name => "Gnatcmd.Last_Switches");
135
136 ----------------------------------
137 -- Declarations for GNATCMD use --
138 ----------------------------------
139
140 The_Command : Command_Type;
141 -- The command specified in the invocation of the GNAT driver
142
143 Command_Arg : Positive := 1;
144 -- The index of the command in the arguments of the GNAT driver
145
146 My_Exit_Status : Exit_Status := Success;
147 -- The exit status of the spawned tool
148
149 type Command_Entry is record
150 Cname : String_Access;
151 -- Command name for GNAT xxx command
152
153 Unixcmd : String_Access;
154 -- Corresponding Unix command
155
156 Unixsws : Argument_List_Access;
157 -- List of switches to be used with the Unix command
158 end record;
159
160 Command_List : constant array (Real_Command_Type) of Command_Entry :=
161 (Bind =>
162 (Cname => new String'("BIND"),
163 Unixcmd => new String'("gnatbind"),
164 Unixsws => null),
165
166 Chop =>
167 (Cname => new String'("CHOP"),
168 Unixcmd => new String'("gnatchop"),
169 Unixsws => null),
170
171 Clean =>
172 (Cname => new String'("CLEAN"),
173 Unixcmd => new String'("gnatclean"),
174 Unixsws => null),
175
176 Compile =>
177 (Cname => new String'("COMPILE"),
178 Unixcmd => new String'("gnatmake"),
179 Unixsws => new Argument_List'(1 => new String'("-f"),
180 2 => new String'("-u"),
181 3 => new String'("-c"))),
182
183 Check =>
184 (Cname => new String'("CHECK"),
185 Unixcmd => new String'("gnatcheck"),
186 Unixsws => null),
187
188 Elim =>
189 (Cname => new String'("ELIM"),
190 Unixcmd => new String'("gnatelim"),
191 Unixsws => null),
192
193 Find =>
194 (Cname => new String'("FIND"),
195 Unixcmd => new String'("gnatfind"),
196 Unixsws => null),
197
198 Krunch =>
199 (Cname => new String'("KRUNCH"),
200 Unixcmd => new String'("gnatkr"),
201 Unixsws => null),
202
203 Link =>
204 (Cname => new String'("LINK"),
205 Unixcmd => new String'("gnatlink"),
206 Unixsws => null),
207
208 List =>
209 (Cname => new String'("LIST"),
210 Unixcmd => new String'("gnatls"),
211 Unixsws => null),
212
213 Make =>
214 (Cname => new String'("MAKE"),
215 Unixcmd => new String'("gnatmake"),
216 Unixsws => null),
217
218 Metric =>
219 (Cname => new String'("METRIC"),
220 Unixcmd => new String'("gnatmetric"),
221 Unixsws => null),
222
223 Name =>
224 (Cname => new String'("NAME"),
225 Unixcmd => new String'("gnatname"),
226 Unixsws => null),
227
228 Preprocess =>
229 (Cname => new String'("PREPROCESS"),
230 Unixcmd => new String'("gnatprep"),
231 Unixsws => null),
232
233 Pretty =>
234 (Cname => new String'("PRETTY"),
235 Unixcmd => new String'("gnatpp"),
236 Unixsws => null),
237
238 Stack =>
239 (Cname => new String'("STACK"),
240 Unixcmd => new String'("gnatstack"),
241 Unixsws => null),
242
243 Stub =>
244 (Cname => new String'("STUB"),
245 Unixcmd => new String'("gnatstub"),
246 Unixsws => null),
247
248 Test =>
249 (Cname => new String'("TEST"),
250 Unixcmd => new String'("gnattest"),
251 Unixsws => null),
252
253 Xref =>
254 (Cname => new String'("XREF"),
255 Unixcmd => new String'("gnatxref"),
256 Unixsws => null)
257 );
258
259 subtype SA is String_Access;
260
261 Naming_String : constant SA := new String'("naming");
262 Gnatls_String : constant SA := new String'("gnatls");
263
264 Packages_To_Check_By_Gnatls : constant String_List_Access :=
265 new String_List'((Naming_String, Gnatls_String));
266
267 Packages_To_Check : String_List_Access := Prj.All_Packages;
268
269 -----------------------
270 -- Local Subprograms --
271 -----------------------
272
273 procedure Check_Files;
274 -- For GNAT LIST -V, check if a project file is specified, without any file
275 -- arguments and without a switch -files=. If it is the case, invoke the
276 -- GNAT tool with the proper list of files, derived from the sources of
277 -- the project.
278
279 procedure Output_Version;
280 -- Output the version of this program
281
282 procedure Usage;
283 -- Display usage
284
285 -----------------
286 -- Check_Files --
287 -----------------
288
289 procedure Check_Files is
290 Add_Sources : Boolean := True;
291 Unit : Prj.Unit_Index;
292 Subunit : Boolean := False;
293 FD : File_Descriptor := Invalid_FD;
294 Status : Integer;
295 Success : Boolean;
296
297 procedure Add_To_Response_File
298 (File_Name : String;
299 Check_File : Boolean := True);
300 -- Include the file name passed as parameter in the response file for
301 -- the tool being called. If the response file can not be written then
302 -- the file name is passed in the parameter list of the tool. If the
303 -- Check_File parameter is True then the procedure verifies the
304 -- existence of the file before adding it to the response file.
305
306 --------------------------
307 -- Add_To_Response_File --
308 --------------------------
309
310 procedure Add_To_Response_File
311 (File_Name : String;
312 Check_File : Boolean := True)
313 is
314 begin
315 Name_Len := 0;
316
317 Add_Str_To_Name_Buffer (File_Name);
318
319 if not Check_File or else
320 Is_Regular_File (Name_Buffer (1 .. Name_Len))
321 then
322 if FD /= Invalid_FD then
323 Name_Len := Name_Len + 1;
324 Name_Buffer (Name_Len) := ASCII.LF;
325
326 Status := Write (FD, Name_Buffer (1)'Address, Name_Len);
327
328 if Status /= Name_Len then
329 Osint.Fail ("disk full");
330 end if;
331 else
332 Last_Switches.Increment_Last;
333 Last_Switches.Table (Last_Switches.Last) :=
334 new String'(File_Name);
335 end if;
336 end if;
337 end Add_To_Response_File;
338
339 -- Start of processing for Check_Files
340
341 begin
342 -- Check if there is at least one argument that is not a switch
343
344 for Index in 1 .. Last_Switches.Last loop
345 if Last_Switches.Table (Index) (1) /= '-'
346 or else (Last_Switches.Table (Index).all'Length > 7
347 and then Last_Switches.Table (Index) (1 .. 7) = "-files=")
348 then
349 Add_Sources := False;
350 exit;
351 end if;
352 end loop;
353
354 -- If all arguments are switches and there is no switch -files=, add the
355 -- path names of all the sources of the main project.
356
357 if Add_Sources then
358 Tempdir.Create_Temp_File (FD, Temp_File_Name);
359 Last_Switches.Increment_Last;
360 Last_Switches.Table (Last_Switches.Last) :=
361 new String'("-files=" & Get_Name_String (Temp_File_Name));
362
363 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
364 while Unit /= No_Unit_Index loop
365
366 -- We only need to put the library units, body or spec, but not
367 -- the subunits.
368
369 if Unit.File_Names (Impl) /= null
370 and then not Unit.File_Names (Impl).Locally_Removed
371 then
372 -- There is a body, check if it is for this project
373
374 if All_Projects
375 or else Unit.File_Names (Impl).Project = Project
376 then
377 Subunit := False;
378
379 if Unit.File_Names (Spec) = null
380 or else Unit.File_Names (Spec).Locally_Removed
381 then
382 -- We have a body with no spec: we need to check if
383 -- this is a subunit, because gnatls will complain
384 -- about subunits.
385
386 declare
387 Src_Ind : constant Source_File_Index :=
388 Sinput.P.Load_Project_File
389 (Get_Name_String
390 (Unit.File_Names (Impl).Path.Name));
391 begin
392 Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind);
393 end;
394 end if;
395
396 if not Subunit then
397 Add_To_Response_File
398 (Get_Name_String (Unit.File_Names (Impl).Display_File),
399 Check_File => False);
400 end if;
401 end if;
402
403 elsif Unit.File_Names (Spec) /= null
404 and then not Unit.File_Names (Spec).Locally_Removed
405 then
406 -- We have a spec with no body. Check if it is for this project
407
408 if All_Projects
409 or else Unit.File_Names (Spec).Project = Project
410 then
411 Add_To_Response_File
412 (Get_Name_String (Unit.File_Names (Spec).Display_File),
413 Check_File => False);
414 end if;
415 end if;
416
417 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
418 end loop;
419
420 if FD /= Invalid_FD then
421 Close (FD, Success);
422
423 if not Success then
424 Osint.Fail ("disk full");
425 end if;
426 end if;
427 end if;
428 end Check_Files;
429
430 --------------------
431 -- Output_Version --
432 --------------------
433
434 procedure Output_Version is
435 begin
436 Put ("GNAT ");
437 Put_Line (Gnatvsn.Gnat_Version_String);
438 Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
439 & ", Free Software Foundation, Inc.");
440 end Output_Version;
441
442 -----------
443 -- Usage --
444 -----------
445
446 procedure Usage is
447 begin
448 Output_Version;
449 New_Line;
450 Put_Line ("List of available commands");
451 New_Line;
452
453 for C in Command_List'Range loop
454 Put ("gnat ");
455 Put (To_Lower (Command_List (C).Cname.all));
456 Set_Col (25);
457 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
458
459 declare
460 Sws : Argument_List_Access renames Command_List (C).Unixsws;
461 begin
462 if Sws /= null then
463 for J in Sws'Range loop
464 Put (' ');
465 Put (Sws (J).all);
466 end loop;
467 end if;
468 end;
469
470 New_Line;
471 end loop;
472
473 New_Line;
474 end Usage;
475
476 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
477
478 -- Start of processing for GNATCmd
479
480 begin
481 -- All output from GNATCmd is debugging or error output: send to stderr
482
483 Set_Standard_Error;
484
485 -- Initializations
486
487 Csets.Initialize;
488 Snames.Initialize;
489 Stringt.Initialize;
490
491 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
492
493 Project_Node_Tree := new Project_Node_Tree_Data;
494 Prj.Tree.Initialize (Project_Node_Tree);
495
496 Prj.Initialize (Project_Tree);
497
498 Last_Switches.Init;
499 Last_Switches.Set_Last (0);
500
501 First_Switches.Init;
502 First_Switches.Set_Last (0);
503
504 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
505 -- so that the spawned tool may know the way the GNAT driver was invoked.
506
507 Name_Len := 0;
508 Add_Str_To_Name_Buffer (Command_Name);
509
510 for J in 1 .. Argument_Count loop
511 Add_Char_To_Name_Buffer (' ');
512 Add_Str_To_Name_Buffer (Argument (J));
513 end loop;
514
515 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
516
517 -- Add the directory where the GNAT driver is invoked in front of the path,
518 -- if the GNAT driver is invoked with directory information.
519
520 declare
521 Command : constant String := Command_Name;
522
523 begin
524 for Index in reverse Command'Range loop
525 if Command (Index) = Directory_Separator then
526 declare
527 Absolute_Dir : constant String :=
528 Normalize_Pathname (Command (Command'First .. Index));
529 PATH : constant String :=
530 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
531 begin
532 Setenv ("PATH", PATH);
533 end;
534
535 exit;
536 end if;
537 end loop;
538 end;
539
540 -- Scan the command line
541
542 -- First, scan to detect --version and/or --help
543
544 Check_Version_And_Help ("GNAT", "1996");
545
546 begin
547 loop
548 if Command_Arg <= Argument_Count
549 and then Argument (Command_Arg) = "-v"
550 then
551 Verbose_Mode := True;
552 Command_Arg := Command_Arg + 1;
553
554 elsif Command_Arg <= Argument_Count
555 and then Argument (Command_Arg) = "-dn"
556 then
557 Keep_Temporary_Files := True;
558 Command_Arg := Command_Arg + 1;
559
560 else
561 exit;
562 end if;
563 end loop;
564
565 -- If there is no command, just output the usage
566
567 if Command_Arg > Argument_Count then
568 Usage;
569 return;
570 end if;
571
572 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
573
574 exception
575 when Constraint_Error =>
576
577 -- Check if it is an alternate command
578
579 declare
580 Alternate : Alternate_Command;
581
582 begin
583 Alternate := Alternate_Command'Value (Argument (Command_Arg));
584 The_Command := Corresponding_To (Alternate);
585
586 exception
587 when Constraint_Error =>
588 Usage;
589 Fail ("unknown command: " & Argument (Command_Arg));
590 end;
591 end;
592
593 -- Get the arguments from the command line and from the eventual
594 -- argument file(s) specified on the command line.
595
596 for Arg in Command_Arg + 1 .. Argument_Count loop
597 declare
598 The_Arg : constant String := Argument (Arg);
599
600 begin
601 -- Check if an argument file is specified
602
603 if The_Arg (The_Arg'First) = '@' then
604 declare
605 Arg_File : Ada.Text_IO.File_Type;
606 Line : String (1 .. 256);
607 Last : Natural;
608
609 begin
610 -- Open the file and fail if the file cannot be found
611
612 begin
613 Open (Arg_File, In_File,
614 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
615
616 exception
617 when others =>
618 Put (Standard_Error, "Cannot open argument file """);
619 Put (Standard_Error,
620 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
621 Put_Line (Standard_Error, """");
622 raise Error_Exit;
623 end;
624
625 -- Read line by line and put the content of each non-
626 -- empty line in the Last_Switches table.
627
628 while not End_Of_File (Arg_File) loop
629 Get_Line (Arg_File, Line, Last);
630
631 if Last /= 0 then
632 Last_Switches.Increment_Last;
633 Last_Switches.Table (Last_Switches.Last) :=
634 new String'(Line (1 .. Last));
635 end if;
636 end loop;
637
638 Close (Arg_File);
639 end;
640
641 else
642 -- It is not an argument file; just put the argument in
643 -- the Last_Switches table.
644
645 Last_Switches.Increment_Last;
646 Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
647 end if;
648 end;
649 end loop;
650
651 declare
652 Program : String_Access;
653 Exec_Path : String_Access;
654 Get_Target : Boolean := False;
655
656 begin
657 if The_Command = Stack then
658
659 -- Never call gnatstack with a prefix
660
661 Program := new String'(Command_List (The_Command).Unixcmd.all);
662
663 else
664 Program :=
665 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
666
667 -- If we want to invoke gnatmake/gnatclean with -P, then check if
668 -- gprbuild/gprclean is available; if it is, use gprbuild/gprclean
669 -- instead of gnatmake/gnatclean.
670 -- Ditto for gnatname -> gprname and gnatls -> gprls.
671
672 if The_Command = Make
673 or else The_Command = Compile
674 or else The_Command = Bind
675 or else The_Command = Link
676 or else The_Command = Clean
677 or else The_Command = Name
678 or else The_Command = List
679 then
680 declare
681 Switch : String_Access;
682 Dash_V_Switch : constant String := "-V";
683
684 begin
685 for J in 1 .. Last_Switches.Last loop
686 Switch := Last_Switches.Table (J);
687
688 if The_Command = List and then Switch.all = Dash_V_Switch
689 then
690 Call_GPR_Tool := False;
691 exit;
692 end if;
693
694 if Switch'Length >= 2
695 and then Switch (Switch'First .. Switch'First + 1) = "-P"
696 then
697 Call_GPR_Tool := True;
698 end if;
699 end loop;
700
701 if Call_GPR_Tool then
702 case The_Command is
703 when Make | Compile | Bind | Link =>
704 if Locate_Exec_On_Path (Gprbuild) /= null then
705 Program := new String'(Gprbuild);
706 Get_Target := True;
707
708 if The_Command = Bind then
709 First_Switches.Append (new String'("-b"));
710 elsif The_Command = Link then
711 First_Switches.Append (new String'("-l"));
712 end if;
713
714 elsif The_Command = Bind then
715 Fail
716 ("'gnat bind -P' is no longer supported;" &
717 " use 'gprbuild -b' instead.");
718
719 elsif The_Command = Link then
720 Fail
721 ("'gnat Link -P' is no longer supported;" &
722 " use 'gprbuild -l' instead.");
723 end if;
724
725 when Clean =>
726 if Locate_Exec_On_Path (Gprclean) /= null then
727 Program := new String'(Gprclean);
728 Get_Target := True;
729 end if;
730
731 when Name =>
732 if Locate_Exec_On_Path (Gprname) /= null then
733 Program := new String'(Gprname);
734 Get_Target := True;
735 end if;
736
737 when List =>
738 if Locate_Exec_On_Path (Gprls) /= null then
739 Program := new String'(Gprls);
740 Get_Target := True;
741 end if;
742
743 when others =>
744 null;
745 end case;
746
747 if Get_Target then
748 Find_Program_Name;
749
750 if Name_Len > 5 then
751 First_Switches.Append
752 (new String'
753 ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
754 end if;
755 end if;
756 end if;
757 end;
758 end if;
759 end if;
760
761 -- Locate the executable for the command
762
763 Exec_Path := Locate_Exec_On_Path (Program.all);
764
765 if Exec_Path = null then
766 Put_Line (Standard_Error, "could not locate " & Program.all);
767 raise Error_Exit;
768 end if;
769
770 -- If there are switches for the executable, put them as first switches
771
772 if Command_List (The_Command).Unixsws /= null then
773 for J in Command_List (The_Command).Unixsws'Range loop
774 First_Switches.Increment_Last;
775 First_Switches.Table (First_Switches.Last) :=
776 Command_List (The_Command).Unixsws (J);
777 end loop;
778 end if;
779
780 -- For FIND and XREF, look for switch -P. If it is specified, then
781 -- report an error indicating that the command is no longer supporting
782 -- project files.
783
784 if The_Command = Find or else The_Command = Xref then
785 declare
786 Argv : String_Access;
787 begin
788 for Arg_Num in 1 .. Last_Switches.Last loop
789 Argv := Last_Switches.Table (Arg_Num);
790
791 if Argv'Length >= 2 and then
792 Argv (Argv'First .. Argv'First + 1) = "-P"
793 then
794 if The_Command = Find then
795 Fail ("'gnat find -P' is no longer supported;");
796 else
797 Fail ("'gnat xref -P' is no longer supported;");
798 end if;
799 end if;
800 end loop;
801 end;
802 end if;
803
804 if The_Command = List and then not Call_GPR_Tool then
805 Tool_Package_Name := Name_Gnatls;
806 Packages_To_Check := Packages_To_Check_By_Gnatls;
807
808 -- Check that the switches are consistent. Detect project file
809 -- related switches.
810
811 Inspect_Switches : declare
812 Arg_Num : Positive := 1;
813 Argv : String_Access;
814
815 procedure Remove_Switch (Num : Positive);
816 -- Remove a project related switch from table Last_Switches
817
818 -------------------
819 -- Remove_Switch --
820 -------------------
821
822 procedure Remove_Switch (Num : Positive) is
823 begin
824 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
825 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
826 Last_Switches.Decrement_Last;
827 end Remove_Switch;
828
829 -- Start of processing for Inspect_Switches
830
831 begin
832 while Arg_Num <= Last_Switches.Last loop
833 Argv := Last_Switches.Table (Arg_Num);
834
835 if Argv (Argv'First) = '-' then
836 if Argv'Length = 1 then
837 Fail ("switch character cannot be followed by a blank");
838 end if;
839
840 -- --subdirs=... Specify Subdirs
841
842 if Argv'Length > Makeutl.Subdirs_Option'Length
843 and then
844 Argv
845 (Argv'First ..
846 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
847 Makeutl.Subdirs_Option
848 then
849 Subdirs :=
850 new String'
851 (Argv (Argv'First + Makeutl.Subdirs_Option'Length ..
852 Argv'Last));
853
854 Remove_Switch (Arg_Num);
855
856 -- -aPdir Add dir to the project search path
857
858 elsif Argv'Length > 3
859 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
860 then
861 Prj.Env.Add_Directories
862 (Root_Environment.Project_Path,
863 Argv (Argv'First + 3 .. Argv'Last));
864
865 -- Pass -aPdir to gnatls, but not to other tools
866
867 if The_Command = List then
868 Arg_Num := Arg_Num + 1;
869 else
870 Remove_Switch (Arg_Num);
871 end if;
872
873 -- -eL Follow links for files
874
875 elsif Argv.all = "-eL" then
876 Follow_Links_For_Files := True;
877 Follow_Links_For_Dirs := True;
878
879 Remove_Switch (Arg_Num);
880
881 -- -vPx Specify verbosity while parsing project files
882
883 elsif Argv'Length >= 3
884 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
885 then
886 if Argv'Length = 4
887 and then Argv (Argv'Last) in '0' .. '2'
888 then
889 case Argv (Argv'Last) is
890 when '0' =>
891 Current_Verbosity := Prj.Default;
892 when '1' =>
893 Current_Verbosity := Prj.Medium;
894 when '2' =>
895 Current_Verbosity := Prj.High;
896 when others =>
897
898 -- Cannot happen
899
900 raise Program_Error;
901 end case;
902 else
903 Fail ("invalid verbosity level: "
904 & Argv (Argv'First + 3 .. Argv'Last));
905 end if;
906
907 Remove_Switch (Arg_Num);
908
909 -- -Pproject_file Specify project file to be used
910
911 elsif Argv (Argv'First + 1) = 'P' then
912
913 -- Only one -P switch can be used
914
915 if Project_File /= null then
916 Fail
917 (Argv.all
918 & ": second project file forbidden (first is """
919 & Project_File.all & """)");
920
921 elsif Argv'Length = 2 then
922
923 -- There is space between -P and the project file
924 -- name. -P cannot be the last option.
925
926 if Arg_Num = Last_Switches.Last then
927 Fail ("project file name missing after -P");
928
929 else
930 Remove_Switch (Arg_Num);
931 Argv := Last_Switches.Table (Arg_Num);
932
933 -- After -P, there must be a project file name,
934 -- not another switch.
935
936 if Argv (Argv'First) = '-' then
937 Fail ("project file name missing after -P");
938
939 else
940 Project_File := new String'(Argv.all);
941 end if;
942 end if;
943
944 else
945 -- No space between -P and project file name
946
947 Project_File :=
948 new String'(Argv (Argv'First + 2 .. Argv'Last));
949 end if;
950
951 Remove_Switch (Arg_Num);
952
953 -- -Xexternal=value Specify an external reference to be
954 -- used in project files
955
956 elsif Argv'Length >= 5
957 and then Argv (Argv'First + 1) = 'X'
958 then
959 if not Check (Root_Environment.External,
960 Argv (Argv'First + 2 .. Argv'Last))
961 then
962 Fail
963 (Argv.all & " is not a valid external assignment.");
964 end if;
965
966 Remove_Switch (Arg_Num);
967
968 -- --unchecked-shared-lib-imports
969
970 elsif Argv.all = "--unchecked-shared-lib-imports" then
971 Opt.Unchecked_Shared_Lib_Imports := True;
972 Remove_Switch (Arg_Num);
973
974 -- gnat list -U
975
976 elsif
977 The_Command = List
978 and then Argv'Length = 2
979 and then Argv (2) = 'U'
980 then
981 All_Projects := True;
982 Remove_Switch (Arg_Num);
983
984 else
985 Arg_Num := Arg_Num + 1;
986 end if;
987
988 else
989 Arg_Num := Arg_Num + 1;
990 end if;
991 end loop;
992 end Inspect_Switches;
993 end if;
994
995 -- Add the default project search directories now, after the directories
996 -- that have been specified by switches -aP<dir>.
997
998 Prj.Env.Initialize_Default_Project_Path
999 (Root_Environment.Project_Path,
1000 Target_Name => Sdefault.Target_Name.all);
1001
1002 -- If there is a project file specified, parse it, get the switches
1003 -- for the tool and setup PATH environment variables.
1004
1005 if Project_File /= null then
1006 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1007
1008 Prj.Pars.Parse
1009 (Project => Project,
1010 In_Tree => Project_Tree,
1011 In_Node_Tree => Project_Node_Tree,
1012 Project_File_Name => Project_File.all,
1013 Env => Root_Environment,
1014 Packages_To_Check => Packages_To_Check);
1015
1016 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1017
1018 Set_Standard_Error;
1019
1020 if Project = Prj.No_Project then
1021 Fail ("""" & Project_File.all & """ processing failed");
1022
1023 elsif Project.Qualifier = Aggregate then
1024 Fail ("aggregate projects are not supported");
1025
1026 elsif Aggregate_Libraries_In (Project_Tree) then
1027 Fail ("aggregate library projects are not supported");
1028 end if;
1029
1030 -- Check if a package with the name of the tool is in the project
1031 -- file and if there is one, get the switches, if any, and scan them.
1032
1033 declare
1034 Pkg : constant Prj.Package_Id :=
1035 Prj.Util.Value_Of
1036 (Name => Tool_Package_Name,
1037 In_Packages => Project.Decl.Packages,
1038 Shared => Project_Tree.Shared);
1039
1040 Element : Package_Element;
1041
1042 Switches_Array : Array_Element_Id;
1043
1044 The_Switches : Prj.Variable_Value;
1045 Current : Prj.String_List_Id;
1046 The_String : String_Element;
1047
1048 Main : String_Access := null;
1049
1050 begin
1051 if Pkg /= No_Package then
1052 Element := Project_Tree.Shared.Packages.Table (Pkg);
1053
1054 -- Package Gnatls has a single attribute Switches, that is not
1055 -- an associative array.
1056
1057 if The_Command = List then
1058 The_Switches :=
1059 Prj.Util.Value_Of
1060 (Variable_Name => Snames.Name_Switches,
1061 In_Variables => Element.Decl.Attributes,
1062 Shared => Project_Tree.Shared);
1063
1064 -- Packages Binder (for gnatbind), Cross_Reference (for
1065 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1066 -- have an attributed Switches, an associative array, indexed
1067 -- by the name of the file.
1068
1069 -- They also have an attribute Default_Switches, indexed by the
1070 -- name of the programming language.
1071
1072 else
1073 -- First check if there is a single main
1074
1075 for J in 1 .. Last_Switches.Last loop
1076 if Last_Switches.Table (J) (1) /= '-' then
1077 if Main = null then
1078 Main := Last_Switches.Table (J);
1079 else
1080 Main := null;
1081 exit;
1082 end if;
1083 end if;
1084 end loop;
1085
1086 if Main /= null then
1087 Switches_Array :=
1088 Prj.Util.Value_Of
1089 (Name => Name_Switches,
1090 In_Arrays => Element.Decl.Arrays,
1091 Shared => Project_Tree.Shared);
1092 Name_Len := 0;
1093
1094 -- If the single main has been specified as an absolute
1095 -- path, use only the simple file name. If the absolute
1096 -- path is incorrect, an error will be reported by the
1097 -- underlying tool and it does not make a difference
1098 -- what switches are used.
1099
1100 if Is_Absolute_Path (Main.all) then
1101 Add_Str_To_Name_Buffer (File_Name (Main.all));
1102 else
1103 Add_Str_To_Name_Buffer (Main.all);
1104 end if;
1105
1106 The_Switches := Prj.Util.Value_Of
1107 (Index => Name_Find,
1108 Src_Index => 0,
1109 In_Array => Switches_Array,
1110 Shared => Project_Tree.Shared);
1111 end if;
1112
1113 if The_Switches.Kind = Prj.Undefined then
1114 Switches_Array :=
1115 Prj.Util.Value_Of
1116 (Name => Name_Default_Switches,
1117 In_Arrays => Element.Decl.Arrays,
1118 Shared => Project_Tree.Shared);
1119 The_Switches := Prj.Util.Value_Of
1120 (Index => Name_Ada,
1121 Src_Index => 0,
1122 In_Array => Switches_Array,
1123 Shared => Project_Tree.Shared);
1124 end if;
1125 end if;
1126
1127 -- If there are switches specified in the package of the
1128 -- project file corresponding to the tool, scan them.
1129
1130 case The_Switches.Kind is
1131 when Prj.Undefined =>
1132 null;
1133
1134 when Prj.Single =>
1135 declare
1136 Switch : constant String :=
1137 Get_Name_String (The_Switches.Value);
1138 begin
1139 if Switch'Length > 0 then
1140 First_Switches.Increment_Last;
1141 First_Switches.Table (First_Switches.Last) :=
1142 new String'(Switch);
1143 end if;
1144 end;
1145
1146 when Prj.List =>
1147 Current := The_Switches.Values;
1148 while Current /= Prj.Nil_String loop
1149 The_String := Project_Tree.Shared.String_Elements.
1150 Table (Current);
1151
1152 declare
1153 Switch : constant String :=
1154 Get_Name_String (The_String.Value);
1155 begin
1156 if Switch'Length > 0 then
1157 First_Switches.Increment_Last;
1158 First_Switches.Table (First_Switches.Last) :=
1159 new String'(Switch);
1160 end if;
1161 end;
1162
1163 Current := The_String.Next;
1164 end loop;
1165 end case;
1166 end if;
1167 end;
1168
1169 if The_Command = Bind or else The_Command = Link then
1170 if Project.Object_Directory.Name = No_Path then
1171 Fail ("project " & Get_Name_String (Project.Display_Name)
1172 & " has no object directory");
1173 end if;
1174
1175 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
1176 end if;
1177
1178 -- Set up the env vars for project path files
1179
1180 Prj.Env.Set_Ada_Paths
1181 (Project, Project_Tree, Including_Libraries => True);
1182
1183 if The_Command = List then
1184 Check_Files;
1185 end if;
1186 end if;
1187
1188 -- Gather all the arguments and invoke the executable
1189
1190 declare
1191 The_Args : Argument_List
1192 (1 .. First_Switches.Last + Last_Switches.Last);
1193 Arg_Num : Natural := 0;
1194
1195 begin
1196 for J in 1 .. First_Switches.Last loop
1197 Arg_Num := Arg_Num + 1;
1198 The_Args (Arg_Num) := First_Switches.Table (J);
1199 end loop;
1200
1201 for J in 1 .. Last_Switches.Last loop
1202 Arg_Num := Arg_Num + 1;
1203 The_Args (Arg_Num) := Last_Switches.Table (J);
1204 end loop;
1205
1206 if Verbose_Mode then
1207 Put (Exec_Path.all);
1208
1209 for Arg in The_Args'Range loop
1210 Put (" " & The_Args (Arg).all);
1211 end loop;
1212
1213 New_Line;
1214 end if;
1215
1216 My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
1217 Set_Exit_Status (My_Exit_Status);
1218 end;
1219 end;
1220
1221 exception
1222 when Error_Exit =>
1223 Set_Exit_Status (Failure);
1224 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org