?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[gcc]
[official-gcc.git] / gcc / ada / gnatcmd.adb
blobe82e8d591ae8325e5a1ef6c7156eb9dff73ef3f2
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 Bind
705 | Compile
706 | Link
707 | Make
708 =>
709 if Locate_Exec_On_Path (Gprbuild) /= null then
710 Program := new String'(Gprbuild);
711 Get_Target := True;
712
713 if The_Command = Bind then
714 First_Switches.Append (new String'("-b"));
715 elsif The_Command = Link then
716 First_Switches.Append (new String'("-l"));
717 end if;
718
719 elsif The_Command = Bind then
720 Fail
721 ("'gnat bind -P' is no longer supported;" &
722 " use 'gprbuild -b' instead.");
723
724 elsif The_Command = Link then
725 Fail
726 ("'gnat Link -P' is no longer supported;" &
727 " use 'gprbuild -l' instead.");
728 end if;
729
730 when Clean =>
731 if Locate_Exec_On_Path (Gprclean) /= null then
732 Program := new String'(Gprclean);
733 Get_Target := True;
734 end if;
735
736 when Name =>
737 if Locate_Exec_On_Path (Gprname) /= null then
738 Program := new String'(Gprname);
739 Get_Target := True;
740 end if;
741
742 when List =>
743 if Locate_Exec_On_Path (Gprls) /= null then
744 Program := new String'(Gprls);
745 Get_Target := True;
746 end if;
747
748 when others =>
749 null;
750 end case;
751
752 if Get_Target then
753 Find_Program_Name;
754
755 if Name_Len > 5 then
756 First_Switches.Append
757 (new String'
758 ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
759 end if;
760 end if;
761 end if;
762 end;
763 end if;
764 end if;
765
766 -- Locate the executable for the command
767
768 Exec_Path := Locate_Exec_On_Path (Program.all);
769
770 if Exec_Path = null then
771 Put_Line (Standard_Error, "could not locate " & Program.all);
772 raise Error_Exit;
773 end if;
774
775 -- If there are switches for the executable, put them as first switches
776
777 if Command_List (The_Command).Unixsws /= null then
778 for J in Command_List (The_Command).Unixsws'Range loop
779 First_Switches.Increment_Last;
780 First_Switches.Table (First_Switches.Last) :=
781 Command_List (The_Command).Unixsws (J);
782 end loop;
783 end if;
784
785 -- For FIND and XREF, look for switch -P. If it is specified, then
786 -- report an error indicating that the command is no longer supporting
787 -- project files.
788
789 if The_Command = Find or else The_Command = Xref then
790 declare
791 Argv : String_Access;
792 begin
793 for Arg_Num in 1 .. Last_Switches.Last loop
794 Argv := Last_Switches.Table (Arg_Num);
795
796 if Argv'Length >= 2 and then
797 Argv (Argv'First .. Argv'First + 1) = "-P"
798 then
799 if The_Command = Find then
800 Fail ("'gnat find -P' is no longer supported;");
801 else
802 Fail ("'gnat xref -P' is no longer supported;");
803 end if;
804 end if;
805 end loop;
806 end;
807 end if;
808
809 if The_Command = List and then not Call_GPR_Tool then
810 Tool_Package_Name := Name_Gnatls;
811 Packages_To_Check := Packages_To_Check_By_Gnatls;
812
813 -- Check that the switches are consistent. Detect project file
814 -- related switches.
815
816 Inspect_Switches : declare
817 Arg_Num : Positive := 1;
818 Argv : String_Access;
819
820 procedure Remove_Switch (Num : Positive);
821 -- Remove a project related switch from table Last_Switches
822
823 -------------------
824 -- Remove_Switch --
825 -------------------
826
827 procedure Remove_Switch (Num : Positive) is
828 begin
829 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
830 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
831 Last_Switches.Decrement_Last;
832 end Remove_Switch;
833
834 -- Start of processing for Inspect_Switches
835
836 begin
837 while Arg_Num <= Last_Switches.Last loop
838 Argv := Last_Switches.Table (Arg_Num);
839
840 if Argv (Argv'First) = '-' then
841 if Argv'Length = 1 then
842 Fail ("switch character cannot be followed by a blank");
843 end if;
844
845 -- --subdirs=... Specify Subdirs
846
847 if Argv'Length > Makeutl.Subdirs_Option'Length
848 and then
849 Argv
850 (Argv'First ..
851 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
852 Makeutl.Subdirs_Option
853 then
854 Subdirs :=
855 new String'
856 (Argv (Argv'First + Makeutl.Subdirs_Option'Length ..
857 Argv'Last));
858
859 Remove_Switch (Arg_Num);
860
861 -- -aPdir Add dir to the project search path
862
863 elsif Argv'Length > 3
864 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
865 then
866 Prj.Env.Add_Directories
867 (Root_Environment.Project_Path,
868 Argv (Argv'First + 3 .. Argv'Last));
869
870 -- Pass -aPdir to gnatls, but not to other tools
871
872 if The_Command = List then
873 Arg_Num := Arg_Num + 1;
874 else
875 Remove_Switch (Arg_Num);
876 end if;
877
878 -- -eL Follow links for files
879
880 elsif Argv.all = "-eL" then
881 Follow_Links_For_Files := True;
882 Follow_Links_For_Dirs := True;
883
884 Remove_Switch (Arg_Num);
885
886 -- -vPx Specify verbosity while parsing project files
887
888 elsif Argv'Length >= 3
889 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
890 then
891 if Argv'Length = 4
892 and then Argv (Argv'Last) in '0' .. '2'
893 then
894 case Argv (Argv'Last) is
895 when '0' =>
896 Current_Verbosity := Prj.Default;
897 when '1' =>
898 Current_Verbosity := Prj.Medium;
899 when '2' =>
900 Current_Verbosity := Prj.High;
901 when others =>
902
903 -- Cannot happen
904
905 raise Program_Error;
906 end case;
907 else
908 Fail ("invalid verbosity level: "
909 & Argv (Argv'First + 3 .. Argv'Last));
910 end if;
911
912 Remove_Switch (Arg_Num);
913
914 -- -Pproject_file Specify project file to be used
915
916 elsif Argv (Argv'First + 1) = 'P' then
917
918 -- Only one -P switch can be used
919
920 if Project_File /= null then
921 Fail
922 (Argv.all
923 & ": second project file forbidden (first is """
924 & Project_File.all & """)");
925
926 elsif Argv'Length = 2 then
927
928 -- There is space between -P and the project file
929 -- name. -P cannot be the last option.
930
931 if Arg_Num = Last_Switches.Last then
932 Fail ("project file name missing after -P");
933
934 else
935 Remove_Switch (Arg_Num);
936 Argv := Last_Switches.Table (Arg_Num);
937
938 -- After -P, there must be a project file name,
939 -- not another switch.
940
941 if Argv (Argv'First) = '-' then
942 Fail ("project file name missing after -P");
943
944 else
945 Project_File := new String'(Argv.all);
946 end if;
947 end if;
948
949 else
950 -- No space between -P and project file name
951
952 Project_File :=
953 new String'(Argv (Argv'First + 2 .. Argv'Last));
954 end if;
955
956 Remove_Switch (Arg_Num);
957
958 -- -Xexternal=value Specify an external reference to be
959 -- used in project files
960
961 elsif Argv'Length >= 5
962 and then Argv (Argv'First + 1) = 'X'
963 then
964 if not Check (Root_Environment.External,
965 Argv (Argv'First + 2 .. Argv'Last))
966 then
967 Fail
968 (Argv.all & " is not a valid external assignment.");
969 end if;
970
971 Remove_Switch (Arg_Num);
972
973 -- --unchecked-shared-lib-imports
974
975 elsif Argv.all = "--unchecked-shared-lib-imports" then
976 Opt.Unchecked_Shared_Lib_Imports := True;
977 Remove_Switch (Arg_Num);
978
979 -- gnat list -U
980
981 elsif
982 The_Command = List
983 and then Argv'Length = 2
984 and then Argv (2) = 'U'
985 then
986 All_Projects := True;
987 Remove_Switch (Arg_Num);
988
989 else
990 Arg_Num := Arg_Num + 1;
991 end if;
992
993 else
994 Arg_Num := Arg_Num + 1;
995 end if;
996 end loop;
997 end Inspect_Switches;
998 end if;
999
1000 -- Add the default project search directories now, after the directories
1001 -- that have been specified by switches -aP<dir>.
1002
1003 Prj.Env.Initialize_Default_Project_Path
1004 (Root_Environment.Project_Path,
1005 Target_Name => Sdefault.Target_Name.all);
1006
1007 -- If there is a project file specified, parse it, get the switches
1008 -- for the tool and setup PATH environment variables.
1009
1010 if Project_File /= null then
1011 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1012
1013 Prj.Pars.Parse
1014 (Project => Project,
1015 In_Tree => Project_Tree,
1016 In_Node_Tree => Project_Node_Tree,
1017 Project_File_Name => Project_File.all,
1018 Env => Root_Environment,
1019 Packages_To_Check => Packages_To_Check);
1020
1021 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1022
1023 Set_Standard_Error;
1024
1025 if Project = Prj.No_Project then
1026 Fail ("""" & Project_File.all & """ processing failed");
1027
1028 elsif Project.Qualifier = Aggregate then
1029 Fail ("aggregate projects are not supported");
1030
1031 elsif Aggregate_Libraries_In (Project_Tree) then
1032 Fail ("aggregate library projects are not supported");
1033 end if;
1034
1035 -- Check if a package with the name of the tool is in the project
1036 -- file and if there is one, get the switches, if any, and scan them.
1037
1038 declare
1039 Pkg : constant Prj.Package_Id :=
1040 Prj.Util.Value_Of
1041 (Name => Tool_Package_Name,
1042 In_Packages => Project.Decl.Packages,
1043 Shared => Project_Tree.Shared);
1044
1045 Element : Package_Element;
1046
1047 Switches_Array : Array_Element_Id;
1048
1049 The_Switches : Prj.Variable_Value;
1050 Current : Prj.String_List_Id;
1051 The_String : String_Element;
1052
1053 Main : String_Access := null;
1054
1055 begin
1056 if Pkg /= No_Package then
1057 Element := Project_Tree.Shared.Packages.Table (Pkg);
1058
1059 -- Package Gnatls has a single attribute Switches, that is not
1060 -- an associative array.
1061
1062 if The_Command = List then
1063 The_Switches :=
1064 Prj.Util.Value_Of
1065 (Variable_Name => Snames.Name_Switches,
1066 In_Variables => Element.Decl.Attributes,
1067 Shared => Project_Tree.Shared);
1068
1069 -- Packages Binder (for gnatbind), Cross_Reference (for
1070 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1071 -- have an attributed Switches, an associative array, indexed
1072 -- by the name of the file.
1073
1074 -- They also have an attribute Default_Switches, indexed by the
1075 -- name of the programming language.
1076
1077 else
1078 -- First check if there is a single main
1079
1080 for J in 1 .. Last_Switches.Last loop
1081 if Last_Switches.Table (J) (1) /= '-' then
1082 if Main = null then
1083 Main := Last_Switches.Table (J);
1084 else
1085 Main := null;
1086 exit;
1087 end if;
1088 end if;
1089 end loop;
1090
1091 if Main /= null then
1092 Switches_Array :=
1093 Prj.Util.Value_Of
1094 (Name => Name_Switches,
1095 In_Arrays => Element.Decl.Arrays,
1096 Shared => Project_Tree.Shared);
1097 Name_Len := 0;
1098
1099 -- If the single main has been specified as an absolute
1100 -- path, use only the simple file name. If the absolute
1101 -- path is incorrect, an error will be reported by the
1102 -- underlying tool and it does not make a difference
1103 -- what switches are used.
1104
1105 if Is_Absolute_Path (Main.all) then
1106 Add_Str_To_Name_Buffer (File_Name (Main.all));
1107 else
1108 Add_Str_To_Name_Buffer (Main.all);
1109 end if;
1110
1111 The_Switches := Prj.Util.Value_Of
1112 (Index => Name_Find,
1113 Src_Index => 0,
1114 In_Array => Switches_Array,
1115 Shared => Project_Tree.Shared);
1116 end if;
1117
1118 if The_Switches.Kind = Prj.Undefined then
1119 Switches_Array :=
1120 Prj.Util.Value_Of
1121 (Name => Name_Default_Switches,
1122 In_Arrays => Element.Decl.Arrays,
1123 Shared => Project_Tree.Shared);
1124 The_Switches := Prj.Util.Value_Of
1125 (Index => Name_Ada,
1126 Src_Index => 0,
1127 In_Array => Switches_Array,
1128 Shared => Project_Tree.Shared);
1129 end if;
1130 end if;
1131
1132 -- If there are switches specified in the package of the
1133 -- project file corresponding to the tool, scan them.
1134
1135 case The_Switches.Kind is
1136 when Prj.Undefined =>
1137 null;
1138
1139 when Prj.Single =>
1140 declare
1141 Switch : constant String :=
1142 Get_Name_String (The_Switches.Value);
1143 begin
1144 if Switch'Length > 0 then
1145 First_Switches.Increment_Last;
1146 First_Switches.Table (First_Switches.Last) :=
1147 new String'(Switch);
1148 end if;
1149 end;
1150
1151 when Prj.List =>
1152 Current := The_Switches.Values;
1153 while Current /= Prj.Nil_String loop
1154 The_String := Project_Tree.Shared.String_Elements.
1155 Table (Current);
1156
1157 declare
1158 Switch : constant String :=
1159 Get_Name_String (The_String.Value);
1160 begin
1161 if Switch'Length > 0 then
1162 First_Switches.Increment_Last;
1163 First_Switches.Table (First_Switches.Last) :=
1164 new String'(Switch);
1165 end if;
1166 end;
1167
1168 Current := The_String.Next;
1169 end loop;
1170 end case;
1171 end if;
1172 end;
1173
1174 if The_Command = Bind or else The_Command = Link then
1175 if Project.Object_Directory.Name = No_Path then
1176 Fail ("project " & Get_Name_String (Project.Display_Name)
1177 & " has no object directory");
1178 end if;
1179
1180 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
1181 end if;
1182
1183 -- Set up the env vars for project path files
1184
1185 Prj.Env.Set_Ada_Paths
1186 (Project, Project_Tree, Including_Libraries => True);
1187
1188 if The_Command = List then
1189 Check_Files;
1190 end if;
1191 end if;
1192
1193 -- Gather all the arguments and invoke the executable
1194
1195 declare
1196 The_Args : Argument_List
1197 (1 .. First_Switches.Last + Last_Switches.Last);
1198 Arg_Num : Natural := 0;
1199
1200 begin
1201 for J in 1 .. First_Switches.Last loop
1202 Arg_Num := Arg_Num + 1;
1203 The_Args (Arg_Num) := First_Switches.Table (J);
1204 end loop;
1205
1206 for J in 1 .. Last_Switches.Last loop
1207 Arg_Num := Arg_Num + 1;
1208 The_Args (Arg_Num) := Last_Switches.Table (J);
1209 end loop;
1210
1211 if Verbose_Mode then
1212 Put (Exec_Path.all);
1213
1214 for Arg in The_Args'Range loop
1215 Put (" " & The_Args (Arg).all);
1216 end loop;
1217
1218 New_Line;
1219 end if;
1220
1221 My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
1222
1223 if not Keep_Temporary_Files then
1224 Delete_All_Temp_Files (Project_Tree.Shared);
1225 end if;
1226
1227 Set_Exit_Status (My_Exit_Status);
1228 end;
1229 end;
1230
1231 exception
1232 when Error_Exit =>
1233 Set_Exit_Status (Failure);
1234 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org