?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2016-10-26 François Dumont <fdumont@gcc.gnu.org>
[official-gcc.git] / gcc / ada / gnatcmd.adb
blob9a04e78abecd3531f143f9f75f76e47b591540f1
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 Record_Temp_File (Project_Tree.Shared, Temp_File_Name);
360 Last_Switches.Increment_Last;
361 Last_Switches.Table (Last_Switches.Last) :=
362 new String'("-files=" & Get_Name_String (Temp_File_Name));
363
364 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
365 while Unit /= No_Unit_Index loop
366
367 -- We only need to put the library units, body or spec, but not
368 -- the subunits.
369
370 if Unit.File_Names (Impl) /= null
371 and then not Unit.File_Names (Impl).Locally_Removed
372 then
373 -- There is a body, check if it is for this project
374
375 if All_Projects
376 or else Unit.File_Names (Impl).Project = Project
377 then
378 Subunit := False;
379
380 if Unit.File_Names (Spec) = null
381 or else Unit.File_Names (Spec).Locally_Removed
382 then
383 -- We have a body with no spec: we need to check if
384 -- this is a subunit, because gnatls will complain
385 -- about subunits.
386
387 declare
388 Src_Ind : constant Source_File_Index :=
389 Sinput.P.Load_Project_File
390 (Get_Name_String
391 (Unit.File_Names (Impl).Path.Name));
392 begin
393 Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind);
394 end;
395 end if;
396
397 if not Subunit then
398 Add_To_Response_File
399 (Get_Name_String (Unit.File_Names (Impl).Display_File),
400 Check_File => False);
401 end if;
402 end if;
403
404 elsif Unit.File_Names (Spec) /= null
405 and then not Unit.File_Names (Spec).Locally_Removed
406 then
407 -- We have a spec with no body. Check if it is for this project
408
409 if All_Projects
410 or else Unit.File_Names (Spec).Project = Project
411 then
412 Add_To_Response_File
413 (Get_Name_String (Unit.File_Names (Spec).Display_File),
414 Check_File => False);
415 end if;
416 end if;
417
418 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
419 end loop;
420
421 if FD /= Invalid_FD then
422 Close (FD, Success);
423
424 if not Success then
425 Osint.Fail ("disk full");
426 end if;
427 end if;
428 end if;
429 end Check_Files;
430
431 --------------------
432 -- Output_Version --
433 --------------------
434
435 procedure Output_Version is
436 begin
437 Put ("GNAT ");
438 Put_Line (Gnatvsn.Gnat_Version_String);
439 Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
440 & ", Free Software Foundation, Inc.");
441 end Output_Version;
442
443 -----------
444 -- Usage --
445 -----------
446
447 procedure Usage is
448 begin
449 Output_Version;
450 New_Line;
451 Put_Line ("List of available commands");
452 New_Line;
453
454 for C in Command_List'Range loop
455 Put ("gnat ");
456 Put (To_Lower (Command_List (C).Cname.all));
457 Set_Col (25);
458 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
459
460 declare
461 Sws : Argument_List_Access renames Command_List (C).Unixsws;
462 begin
463 if Sws /= null then
464 for J in Sws'Range loop
465 Put (' ');
466 Put (Sws (J).all);
467 end loop;
468 end if;
469 end;
470
471 New_Line;
472 end loop;
473
474 New_Line;
475 end Usage;
476
477 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
478
479 -- Start of processing for GNATCmd
480
481 begin
482 -- All output from GNATCmd is debugging or error output: send to stderr
483
484 Set_Standard_Error;
485
486 -- Initializations
487
488 Csets.Initialize;
489 Snames.Initialize;
490 Stringt.Initialize;
491
492 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
493
494 Project_Node_Tree := new Project_Node_Tree_Data;
495 Prj.Tree.Initialize (Project_Node_Tree);
496
497 Prj.Initialize (Project_Tree);
498
499 Last_Switches.Init;
500 Last_Switches.Set_Last (0);
501
502 First_Switches.Init;
503 First_Switches.Set_Last (0);
504
505 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
506 -- so that the spawned tool may know the way the GNAT driver was invoked.
507
508 Name_Len := 0;
509 Add_Str_To_Name_Buffer (Command_Name);
510
511 for J in 1 .. Argument_Count loop
512 Add_Char_To_Name_Buffer (' ');
513 Add_Str_To_Name_Buffer (Argument (J));
514 end loop;
515
516 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
517
518 -- Add the directory where the GNAT driver is invoked in front of the path,
519 -- if the GNAT driver is invoked with directory information.
520
521 declare
522 Command : constant String := Command_Name;
523
524 begin
525 for Index in reverse Command'Range loop
526 if Command (Index) = Directory_Separator then
527 declare
528 Absolute_Dir : constant String :=
529 Normalize_Pathname (Command (Command'First .. Index));
530 PATH : constant String :=
531 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
532 begin
533 Setenv ("PATH", PATH);
534 end;
535
536 exit;
537 end if;
538 end loop;
539 end;
540
541 -- Scan the command line
542
543 -- First, scan to detect --version and/or --help
544
545 Check_Version_And_Help ("GNAT", "1996");
546
547 begin
548 loop
549 if Command_Arg <= Argument_Count
550 and then Argument (Command_Arg) = "-v"
551 then
552 Verbose_Mode := True;
553 Command_Arg := Command_Arg + 1;
554
555 elsif Command_Arg <= Argument_Count
556 and then Argument (Command_Arg) = "-dn"
557 then
558 Keep_Temporary_Files := True;
559 Command_Arg := Command_Arg + 1;
560
561 else
562 exit;
563 end if;
564 end loop;
565
566 -- If there is no command, just output the usage
567
568 if Command_Arg > Argument_Count then
569 Usage;
570 return;
571 end if;
572
573 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
574
575 exception
576 when Constraint_Error =>
577
578 -- Check if it is an alternate command
579
580 declare
581 Alternate : Alternate_Command;
582
583 begin
584 Alternate := Alternate_Command'Value (Argument (Command_Arg));
585 The_Command := Corresponding_To (Alternate);
586
587 exception
588 when Constraint_Error =>
589 Usage;
590 Fail ("unknown command: " & Argument (Command_Arg));
591 end;
592 end;
593
594 -- Get the arguments from the command line and from the eventual
595 -- argument file(s) specified on the command line.
596
597 for Arg in Command_Arg + 1 .. Argument_Count loop
598 declare
599 The_Arg : constant String := Argument (Arg);
600
601 begin
602 -- Check if an argument file is specified
603
604 if The_Arg (The_Arg'First) = '@' then
605 declare
606 Arg_File : Ada.Text_IO.File_Type;
607 Line : String (1 .. 256);
608 Last : Natural;
609
610 begin
611 -- Open the file and fail if the file cannot be found
612
613 begin
614 Open (Arg_File, In_File,
615 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
616
617 exception
618 when others =>
619 Put (Standard_Error, "Cannot open argument file """);
620 Put (Standard_Error,
621 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
622 Put_Line (Standard_Error, """");
623 raise Error_Exit;
624 end;
625
626 -- Read line by line and put the content of each non-
627 -- empty line in the Last_Switches table.
628
629 while not End_Of_File (Arg_File) loop
630 Get_Line (Arg_File, Line, Last);
631
632 if Last /= 0 then
633 Last_Switches.Increment_Last;
634 Last_Switches.Table (Last_Switches.Last) :=
635 new String'(Line (1 .. Last));
636 end if;
637 end loop;
638
639 Close (Arg_File);
640 end;
641
642 else
643 -- It is not an argument file; just put the argument in
644 -- the Last_Switches table.
645
646 Last_Switches.Increment_Last;
647 Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
648 end if;
649 end;
650 end loop;
651
652 declare
653 Program : String_Access;
654 Exec_Path : String_Access;
655 Get_Target : Boolean := False;
656
657 begin
658 if The_Command = Stack then
659
660 -- Never call gnatstack with a prefix
661
662 Program := new String'(Command_List (The_Command).Unixcmd.all);
663
664 else
665 Program :=
666 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
667
668 -- If we want to invoke gnatmake/gnatclean with -P, then check if
669 -- gprbuild/gprclean is available; if it is, use gprbuild/gprclean
670 -- instead of gnatmake/gnatclean.
671 -- Ditto for gnatname -> gprname and gnatls -> gprls.
672
673 if The_Command = Make
674 or else The_Command = Compile
675 or else The_Command = Bind
676 or else The_Command = Link
677 or else The_Command = Clean
678 or else The_Command = Name
679 or else The_Command = List
680 then
681 declare
682 Switch : String_Access;
683 Dash_V_Switch : constant String := "-V";
684
685 begin
686 for J in 1 .. Last_Switches.Last loop
687 Switch := Last_Switches.Table (J);
688
689 if The_Command = List and then Switch.all = Dash_V_Switch
690 then
691 Call_GPR_Tool := False;
692 exit;
693 end if;
694
695 if Switch'Length >= 2
696 and then Switch (Switch'First .. Switch'First + 1) = "-P"
697 then
698 Call_GPR_Tool := True;
699 end if;
700 end loop;
701
702 if Call_GPR_Tool then
703 case The_Command is
704 when Make | Compile | Bind | Link =>
705 if Locate_Exec_On_Path (Gprbuild) /= null then
706 Program := new String'(Gprbuild);
707 Get_Target := True;
708
709 if The_Command = Bind then
710 First_Switches.Append (new String'("-b"));
711 elsif The_Command = Link then
712 First_Switches.Append (new String'("-l"));
713 end if;
714
715 elsif The_Command = Bind then
716 Fail
717 ("'gnat bind -P' is no longer supported;" &
718 " use 'gprbuild -b' instead.");
719
720 elsif The_Command = Link then
721 Fail
722 ("'gnat Link -P' is no longer supported;" &
723 " use 'gprbuild -l' instead.");
724 end if;
725
726 when Clean =>
727 if Locate_Exec_On_Path (Gprclean) /= null then
728 Program := new String'(Gprclean);
729 Get_Target := True;
730 end if;
731
732 when Name =>
733 if Locate_Exec_On_Path (Gprname) /= null then
734 Program := new String'(Gprname);
735 Get_Target := True;
736 end if;
737
738 when List =>
739 if Locate_Exec_On_Path (Gprls) /= null then
740 Program := new String'(Gprls);
741 Get_Target := True;
742 end if;
743
744 when others =>
745 null;
746 end case;
747
748 if Get_Target then
749 Find_Program_Name;
750
751 if Name_Len > 5 then
752 First_Switches.Append
753 (new String'
754 ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
755 end if;
756 end if;
757 end if;
758 end;
759 end if;
760 end if;
761
762 -- Locate the executable for the command
763
764 Exec_Path := Locate_Exec_On_Path (Program.all);
765
766 if Exec_Path = null then
767 Put_Line (Standard_Error, "could not locate " & Program.all);
768 raise Error_Exit;
769 end if;
770
771 -- If there are switches for the executable, put them as first switches
772
773 if Command_List (The_Command).Unixsws /= null then
774 for J in Command_List (The_Command).Unixsws'Range loop
775 First_Switches.Increment_Last;
776 First_Switches.Table (First_Switches.Last) :=
777 Command_List (The_Command).Unixsws (J);
778 end loop;
779 end if;
780
781 -- For FIND and XREF, look for switch -P. If it is specified, then
782 -- report an error indicating that the command is no longer supporting
783 -- project files.
784
785 if The_Command = Find or else The_Command = Xref then
786 declare
787 Argv : String_Access;
788 begin
789 for Arg_Num in 1 .. Last_Switches.Last loop
790 Argv := Last_Switches.Table (Arg_Num);
791
792 if Argv'Length >= 2 and then
793 Argv (Argv'First .. Argv'First + 1) = "-P"
794 then
795 if The_Command = Find then
796 Fail ("'gnat find -P' is no longer supported;");
797 else
798 Fail ("'gnat xref -P' is no longer supported;");
799 end if;
800 end if;
801 end loop;
802 end;
803 end if;
804
805 if The_Command = List and then not Call_GPR_Tool then
806 Tool_Package_Name := Name_Gnatls;
807 Packages_To_Check := Packages_To_Check_By_Gnatls;
808
809 -- Check that the switches are consistent. Detect project file
810 -- related switches.
811
812 Inspect_Switches : declare
813 Arg_Num : Positive := 1;
814 Argv : String_Access;
815
816 procedure Remove_Switch (Num : Positive);
817 -- Remove a project related switch from table Last_Switches
818
819 -------------------
820 -- Remove_Switch --
821 -------------------
822
823 procedure Remove_Switch (Num : Positive) is
824 begin
825 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
826 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
827 Last_Switches.Decrement_Last;
828 end Remove_Switch;
829
830 -- Start of processing for Inspect_Switches
831
832 begin
833 while Arg_Num <= Last_Switches.Last loop
834 Argv := Last_Switches.Table (Arg_Num);
835
836 if Argv (Argv'First) = '-' then
837 if Argv'Length = 1 then
838 Fail ("switch character cannot be followed by a blank");
839 end if;
840
841 -- --subdirs=... Specify Subdirs
842
843 if Argv'Length > Makeutl.Subdirs_Option'Length
844 and then
845 Argv
846 (Argv'First ..
847 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
848 Makeutl.Subdirs_Option
849 then
850 Subdirs :=
851 new String'
852 (Argv (Argv'First + Makeutl.Subdirs_Option'Length ..
853 Argv'Last));
854
855 Remove_Switch (Arg_Num);
856
857 -- -aPdir Add dir to the project search path
858
859 elsif Argv'Length > 3
860 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
861 then
862 Prj.Env.Add_Directories
863 (Root_Environment.Project_Path,
864 Argv (Argv'First + 3 .. Argv'Last));
865
866 -- Pass -aPdir to gnatls, but not to other tools
867
868 if The_Command = List then
869 Arg_Num := Arg_Num + 1;
870 else
871 Remove_Switch (Arg_Num);
872 end if;
873
874 -- -eL Follow links for files
875
876 elsif Argv.all = "-eL" then
877 Follow_Links_For_Files := True;
878 Follow_Links_For_Dirs := True;
879
880 Remove_Switch (Arg_Num);
881
882 -- -vPx Specify verbosity while parsing project files
883
884 elsif Argv'Length >= 3
885 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
886 then
887 if Argv'Length = 4
888 and then Argv (Argv'Last) in '0' .. '2'
889 then
890 case Argv (Argv'Last) is
891 when '0' =>
892 Current_Verbosity := Prj.Default;
893 when '1' =>
894 Current_Verbosity := Prj.Medium;
895 when '2' =>
896 Current_Verbosity := Prj.High;
897 when others =>
898
899 -- Cannot happen
900
901 raise Program_Error;
902 end case;
903 else
904 Fail ("invalid verbosity level: "
905 & Argv (Argv'First + 3 .. Argv'Last));
906 end if;
907
908 Remove_Switch (Arg_Num);
909
910 -- -Pproject_file Specify project file to be used
911
912 elsif Argv (Argv'First + 1) = 'P' then
913
914 -- Only one -P switch can be used
915
916 if Project_File /= null then
917 Fail
918 (Argv.all
919 & ": second project file forbidden (first is """
920 & Project_File.all & """)");
921
922 elsif Argv'Length = 2 then
923
924 -- There is space between -P and the project file
925 -- name. -P cannot be the last option.
926
927 if Arg_Num = Last_Switches.Last then
928 Fail ("project file name missing after -P");
929
930 else
931 Remove_Switch (Arg_Num);
932 Argv := Last_Switches.Table (Arg_Num);
933
934 -- After -P, there must be a project file name,
935 -- not another switch.
936
937 if Argv (Argv'First) = '-' then
938 Fail ("project file name missing after -P");
939
940 else
941 Project_File := new String'(Argv.all);
942 end if;
943 end if;
944
945 else
946 -- No space between -P and project file name
947
948 Project_File :=
949 new String'(Argv (Argv'First + 2 .. Argv'Last));
950 end if;
951
952 Remove_Switch (Arg_Num);
953
954 -- -Xexternal=value Specify an external reference to be
955 -- used in project files
956
957 elsif Argv'Length >= 5
958 and then Argv (Argv'First + 1) = 'X'
959 then
960 if not Check (Root_Environment.External,
961 Argv (Argv'First + 2 .. Argv'Last))
962 then
963 Fail
964 (Argv.all & " is not a valid external assignment.");
965 end if;
966
967 Remove_Switch (Arg_Num);
968
969 -- --unchecked-shared-lib-imports
970
971 elsif Argv.all = "--unchecked-shared-lib-imports" then
972 Opt.Unchecked_Shared_Lib_Imports := True;
973 Remove_Switch (Arg_Num);
974
975 -- gnat list -U
976
977 elsif
978 The_Command = List
979 and then Argv'Length = 2
980 and then Argv (2) = 'U'
981 then
982 All_Projects := True;
983 Remove_Switch (Arg_Num);
984
985 else
986 Arg_Num := Arg_Num + 1;
987 end if;
988
989 else
990 Arg_Num := Arg_Num + 1;
991 end if;
992 end loop;
993 end Inspect_Switches;
994 end if;
995
996 -- Add the default project search directories now, after the directories
997 -- that have been specified by switches -aP<dir>.
998
999 Prj.Env.Initialize_Default_Project_Path
1000 (Root_Environment.Project_Path,
1001 Target_Name => Sdefault.Target_Name.all);
1002
1003 -- If there is a project file specified, parse it, get the switches
1004 -- for the tool and setup PATH environment variables.
1005
1006 if Project_File /= null then
1007 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1008
1009 Prj.Pars.Parse
1010 (Project => Project,
1011 In_Tree => Project_Tree,
1012 In_Node_Tree => Project_Node_Tree,
1013 Project_File_Name => Project_File.all,
1014 Env => Root_Environment,
1015 Packages_To_Check => Packages_To_Check);
1016
1017 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1018
1019 Set_Standard_Error;
1020
1021 if Project = Prj.No_Project then
1022 Fail ("""" & Project_File.all & """ processing failed");
1023
1024 elsif Project.Qualifier = Aggregate then
1025 Fail ("aggregate projects are not supported");
1026
1027 elsif Aggregate_Libraries_In (Project_Tree) then
1028 Fail ("aggregate library projects are not supported");
1029 end if;
1030
1031 -- Check if a package with the name of the tool is in the project
1032 -- file and if there is one, get the switches, if any, and scan them.
1033
1034 declare
1035 Pkg : constant Prj.Package_Id :=
1036 Prj.Util.Value_Of
1037 (Name => Tool_Package_Name,
1038 In_Packages => Project.Decl.Packages,
1039 Shared => Project_Tree.Shared);
1040
1041 Element : Package_Element;
1042
1043 Switches_Array : Array_Element_Id;
1044
1045 The_Switches : Prj.Variable_Value;
1046 Current : Prj.String_List_Id;
1047 The_String : String_Element;
1048
1049 Main : String_Access := null;
1050
1051 begin
1052 if Pkg /= No_Package then
1053 Element := Project_Tree.Shared.Packages.Table (Pkg);
1054
1055 -- Package Gnatls has a single attribute Switches, that is not
1056 -- an associative array.
1057
1058 if The_Command = List then
1059 The_Switches :=
1060 Prj.Util.Value_Of
1061 (Variable_Name => Snames.Name_Switches,
1062 In_Variables => Element.Decl.Attributes,
1063 Shared => Project_Tree.Shared);
1064
1065 -- Packages Binder (for gnatbind), Cross_Reference (for
1066 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1067 -- have an attributed Switches, an associative array, indexed
1068 -- by the name of the file.
1069
1070 -- They also have an attribute Default_Switches, indexed by the
1071 -- name of the programming language.
1072
1073 else
1074 -- First check if there is a single main
1075
1076 for J in 1 .. Last_Switches.Last loop
1077 if Last_Switches.Table (J) (1) /= '-' then
1078 if Main = null then
1079 Main := Last_Switches.Table (J);
1080 else
1081 Main := null;
1082 exit;
1083 end if;
1084 end if;
1085 end loop;
1086
1087 if Main /= null then
1088 Switches_Array :=
1089 Prj.Util.Value_Of
1090 (Name => Name_Switches,
1091 In_Arrays => Element.Decl.Arrays,
1092 Shared => Project_Tree.Shared);
1093 Name_Len := 0;
1094
1095 -- If the single main has been specified as an absolute
1096 -- path, use only the simple file name. If the absolute
1097 -- path is incorrect, an error will be reported by the
1098 -- underlying tool and it does not make a difference
1099 -- what switches are used.
1100
1101 if Is_Absolute_Path (Main.all) then
1102 Add_Str_To_Name_Buffer (File_Name (Main.all));
1103 else
1104 Add_Str_To_Name_Buffer (Main.all);
1105 end if;
1106
1107 The_Switches := Prj.Util.Value_Of
1108 (Index => Name_Find,
1109 Src_Index => 0,
1110 In_Array => Switches_Array,
1111 Shared => Project_Tree.Shared);
1112 end if;
1113
1114 if The_Switches.Kind = Prj.Undefined then
1115 Switches_Array :=
1116 Prj.Util.Value_Of
1117 (Name => Name_Default_Switches,
1118 In_Arrays => Element.Decl.Arrays,
1119 Shared => Project_Tree.Shared);
1120 The_Switches := Prj.Util.Value_Of
1121 (Index => Name_Ada,
1122 Src_Index => 0,
1123 In_Array => Switches_Array,
1124 Shared => Project_Tree.Shared);
1125 end if;
1126 end if;
1127
1128 -- If there are switches specified in the package of the
1129 -- project file corresponding to the tool, scan them.
1130
1131 case The_Switches.Kind is
1132 when Prj.Undefined =>
1133 null;
1134
1135 when Prj.Single =>
1136 declare
1137 Switch : constant String :=
1138 Get_Name_String (The_Switches.Value);
1139 begin
1140 if Switch'Length > 0 then
1141 First_Switches.Increment_Last;
1142 First_Switches.Table (First_Switches.Last) :=
1143 new String'(Switch);
1144 end if;
1145 end;
1146
1147 when Prj.List =>
1148 Current := The_Switches.Values;
1149 while Current /= Prj.Nil_String loop
1150 The_String := Project_Tree.Shared.String_Elements.
1151 Table (Current);
1152
1153 declare
1154 Switch : constant String :=
1155 Get_Name_String (The_String.Value);
1156 begin
1157 if Switch'Length > 0 then
1158 First_Switches.Increment_Last;
1159 First_Switches.Table (First_Switches.Last) :=
1160 new String'(Switch);
1161 end if;
1162 end;
1163
1164 Current := The_String.Next;
1165 end loop;
1166 end case;
1167 end if;
1168 end;
1169
1170 if The_Command = Bind or else The_Command = Link then
1171 if Project.Object_Directory.Name = No_Path then
1172 Fail ("project " & Get_Name_String (Project.Display_Name)
1173 & " has no object directory");
1174 end if;
1175
1176 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
1177 end if;
1178
1179 -- Set up the env vars for project path files
1180
1181 Prj.Env.Set_Ada_Paths
1182 (Project, Project_Tree, Including_Libraries => True);
1183
1184 if The_Command = List then
1185 Check_Files;
1186 end if;
1187 end if;
1188
1189 -- Gather all the arguments and invoke the executable
1190
1191 declare
1192 The_Args : Argument_List
1193 (1 .. First_Switches.Last + Last_Switches.Last);
1194 Arg_Num : Natural := 0;
1195
1196 begin
1197 for J in 1 .. First_Switches.Last loop
1198 Arg_Num := Arg_Num + 1;
1199 The_Args (Arg_Num) := First_Switches.Table (J);
1200 end loop;
1201
1202 for J in 1 .. Last_Switches.Last loop
1203 Arg_Num := Arg_Num + 1;
1204 The_Args (Arg_Num) := Last_Switches.Table (J);
1205 end loop;
1206
1207 if Verbose_Mode then
1208 Put (Exec_Path.all);
1209
1210 for Arg in The_Args'Range loop
1211 Put (" " & The_Args (Arg).all);
1212 end loop;
1213
1214 New_Line;
1215 end if;
1216
1217 My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
1218
1219 if not Keep_Temporary_Files then
1220 Delete_All_Temp_Files (Project_Tree.Shared);
1221 end if;
1222
1223 Set_Exit_Status (My_Exit_Status);
1224 end;
1225 end;
1226
1227 exception
1228 when Error_Exit =>
1229 Set_Exit_Status (Failure);
1230 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org