Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/gnatcmd.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 Gnatvsn;
27 with Namet; use Namet;
28 with Opt; use Opt;
29 with Osint; use Osint;
30 with Output; use Output;
31 with Switch; use Switch;
32 with Table;
33
34 with Ada.Characters.Handling; use Ada.Characters.Handling;
35 with Ada.Command_Line; use Ada.Command_Line;
36 with Ada.Text_IO; use Ada.Text_IO;
37
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
39
40 procedure GNATCmd is
41 Gprbuild : constant String := "gprbuild";
42 Gprclean : constant String := "gprclean";
43 Gprname : constant String := "gprname";
44 Gprls : constant String := "gprls";
45
46 Error_Exit : exception;
47 -- Raise this exception if error detected
48
49 type Command_Type is
50 (Bind,
51 Chop,
52 Clean,
53 Compile,
54 Check,
55 Elim,
56 Find,
57 Krunch,
58 Link,
59 List,
60 Make,
61 Metric,
62 Name,
63 Preprocess,
64 Pretty,
65 Stack,
66 Stub,
67 Test,
68 Xref,
69 Undefined);
70
71 subtype Real_Command_Type is Command_Type range Bind .. Xref;
72 -- All real command types (excludes only Undefined).
73
74 type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
75 -- Alternate command label
76
77 Corresponding_To : constant array (Alternate_Command) of Command_Type :=
78 (Comp => Compile,
79 Ls => List,
80 Kr => Krunch,
81 Prep => Preprocess,
82 Pp => Pretty);
83 -- Mapping of alternate commands to commands
84
85 package First_Switches is new Table.Table
86 (Table_Component_Type => String_Access,
87 Table_Index_Type => Integer,
88 Table_Low_Bound => 1,
89 Table_Initial => 20,
90 Table_Increment => 100,
91 Table_Name => "Gnatcmd.First_Switches");
92 -- A table to keep the switches from the project file
93
94 package Last_Switches is new Table.Table
95 (Table_Component_Type => String_Access,
96 Table_Index_Type => Integer,
97 Table_Low_Bound => 1,
98 Table_Initial => 20,
99 Table_Increment => 100,
100 Table_Name => "Gnatcmd.Last_Switches");
101
102 ----------------------------------
103 -- Declarations for GNATCMD use --
104 ----------------------------------
105
106 The_Command : Command_Type;
107 -- The command specified in the invocation of the GNAT driver
108
109 Command_Arg : Positive := 1;
110 -- The index of the command in the arguments of the GNAT driver
111
112 My_Exit_Status : Exit_Status := Success;
113 -- The exit status of the spawned tool
114
115 type Command_Entry is record
116 Cname : String_Access;
117 -- Command name for GNAT xxx command
118
119 Unixcmd : String_Access;
120 -- Corresponding Unix command
121
122 Unixsws : Argument_List_Access;
123 -- List of switches to be used with the Unix command
124 end record;
125
126 Command_List : constant array (Real_Command_Type) of Command_Entry :=
127 (Bind =>
128 (Cname => new String'("BIND"),
129 Unixcmd => new String'("gnatbind"),
130 Unixsws => null),
131
132 Chop =>
133 (Cname => new String'("CHOP"),
134 Unixcmd => new String'("gnatchop"),
135 Unixsws => null),
136
137 Clean =>
138 (Cname => new String'("CLEAN"),
139 Unixcmd => new String'("gnatclean"),
140 Unixsws => null),
141
142 Compile =>
143 (Cname => new String'("COMPILE"),
144 Unixcmd => new String'("gnatmake"),
145 Unixsws => new Argument_List'(1 => new String'("-f"),
146 2 => new String'("-u"),
147 3 => new String'("-c"))),
148
149 Check =>
150 (Cname => new String'("CHECK"),
151 Unixcmd => new String'("gnatcheck"),
152 Unixsws => null),
153
154 Elim =>
155 (Cname => new String'("ELIM"),
156 Unixcmd => new String'("gnatelim"),
157 Unixsws => null),
158
159 Find =>
160 (Cname => new String'("FIND"),
161 Unixcmd => new String'("gnatfind"),
162 Unixsws => null),
163
164 Krunch =>
165 (Cname => new String'("KRUNCH"),
166 Unixcmd => new String'("gnatkr"),
167 Unixsws => null),
168
169 Link =>
170 (Cname => new String'("LINK"),
171 Unixcmd => new String'("gnatlink"),
172 Unixsws => null),
173
174 List =>
175 (Cname => new String'("LIST"),
176 Unixcmd => new String'("gnatls"),
177 Unixsws => null),
178
179 Make =>
180 (Cname => new String'("MAKE"),
181 Unixcmd => new String'("gnatmake"),
182 Unixsws => null),
183
184 Metric =>
185 (Cname => new String'("METRIC"),
186 Unixcmd => new String'("gnatmetric"),
187 Unixsws => null),
188
189 Name =>
190 (Cname => new String'("NAME"),
191 Unixcmd => new String'("gnatname"),
192 Unixsws => null),
193
194 Preprocess =>
195 (Cname => new String'("PREPROCESS"),
196 Unixcmd => new String'("gnatprep"),
197 Unixsws => null),
198
199 Pretty =>
200 (Cname => new String'("PRETTY"),
201 Unixcmd => new String'("gnatpp"),
202 Unixsws => null),
203
204 Stack =>
205 (Cname => new String'("STACK"),
206 Unixcmd => new String'("gnatstack"),
207 Unixsws => null),
208
209 Stub =>
210 (Cname => new String'("STUB"),
211 Unixcmd => new String'("gnatstub"),
212 Unixsws => null),
213
214 Test =>
215 (Cname => new String'("TEST"),
216 Unixcmd => new String'("gnattest"),
217 Unixsws => null),
218
219 Xref =>
220 (Cname => new String'("XREF"),
221 Unixcmd => new String'("gnatxref"),
222 Unixsws => null)
223 );
224
225 -----------------------
226 -- Local Subprograms --
227 -----------------------
228
229 procedure Output_Version;
230 -- Output the version of this program
231
232 procedure Usage;
233 -- Display usage
234
235 --------------------
236 -- Output_Version --
237 --------------------
238
239 procedure Output_Version is
240 begin
241 Put ("GNAT ");
242 Put_Line (Gnatvsn.Gnat_Version_String);
243 Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
244 & ", Free Software Foundation, Inc.");
245 end Output_Version;
246
247 -----------
248 -- Usage --
249 -----------
250
251 procedure Usage is
252 begin
253 Output_Version;
254 New_Line;
255 Put_Line ("List of available commands");
256 New_Line;
257
258 for C in Command_List'Range loop
259 Put ("gnat ");
260 Put (To_Lower (Command_List (C).Cname.all));
261 Set_Col (25);
262 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
263
264 declare
265 Sws : Argument_List_Access renames Command_List (C).Unixsws;
266 begin
267 if Sws /= null then
268 for J in Sws'Range loop
269 Put (' ');
270 Put (Sws (J).all);
271 end loop;
272 end if;
273 end;
274
275 New_Line;
276 end loop;
277
278 New_Line;
279 end Usage;
280
281 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
282
283 -- Start of processing for GNATCmd
284
285 begin
286 -- All output from GNATCmd is debugging or error output: send to stderr
287
288 Set_Standard_Error;
289
290 -- Initializations
291
292 Last_Switches.Init;
293 Last_Switches.Set_Last (0);
294
295 First_Switches.Init;
296 First_Switches.Set_Last (0);
297
298 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
299 -- so that the spawned tool may know the way the GNAT driver was invoked.
300
301 Name_Len := 0;
302 Add_Str_To_Name_Buffer (Command_Name);
303
304 for J in 1 .. Argument_Count loop
305 Add_Char_To_Name_Buffer (' ');
306 Add_Str_To_Name_Buffer (Argument (J));
307 end loop;
308
309 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
310
311 -- Add the directory where the GNAT driver is invoked in front of the path,
312 -- if the GNAT driver is invoked with directory information.
313
314 declare
315 Command : constant String := Command_Name;
316
317 begin
318 for Index in reverse Command'Range loop
319 if Command (Index) = Directory_Separator then
320 declare
321 Absolute_Dir : constant String :=
322 Normalize_Pathname (Command (Command'First .. Index));
323 PATH : constant String :=
324 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
325 begin
326 Setenv ("PATH", PATH);
327 end;
328
329 exit;
330 end if;
331 end loop;
332 end;
333
334 -- Scan the command line
335
336 -- First, scan to detect --version and/or --help
337
338 Check_Version_And_Help ("GNAT", "1996");
339
340 begin
341 loop
342 if Command_Arg <= Argument_Count
343 and then Argument (Command_Arg) = "-v"
344 then
345 Verbose_Mode := True;
346 Command_Arg := Command_Arg + 1;
347
348 elsif Command_Arg <= Argument_Count
349 and then Argument (Command_Arg) = "-dn"
350 then
351 Keep_Temporary_Files := True;
352 Command_Arg := Command_Arg + 1;
353
354 else
355 exit;
356 end if;
357 end loop;
358
359 -- If there is no command, just output the usage
360
361 if Command_Arg > Argument_Count then
362 Usage;
363 return;
364 end if;
365
366 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
367
368 exception
369 when Constraint_Error =>
370
371 -- Check if it is an alternate command
372
373 declare
374 Alternate : Alternate_Command;
375
376 begin
377 Alternate := Alternate_Command'Value (Argument (Command_Arg));
378 The_Command := Corresponding_To (Alternate);
379
380 exception
381 when Constraint_Error =>
382 Usage;
383 Fail ("unknown command: " & Argument (Command_Arg));
384 end;
385 end;
386
387 -- Get the arguments from the command line and from the eventual
388 -- argument file(s) specified on the command line.
389
390 for Arg in Command_Arg + 1 .. Argument_Count loop
391 declare
392 The_Arg : constant String := Argument (Arg);
393
394 begin
395 -- Check if an argument file is specified
396
397 if The_Arg'Length > 0 and then The_Arg (The_Arg'First) = '@' then
398 declare
399 Arg_File : Ada.Text_IO.File_Type;
400 Line : String (1 .. 256);
401 Last : Natural;
402
403 begin
404 -- Open the file and fail if the file cannot be found
405
406 begin
407 Open (Arg_File, In_File,
408 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
409
410 exception
411 when others =>
412 Put (Standard_Error, "Cannot open argument file """);
413 Put (Standard_Error,
414 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
415 Put_Line (Standard_Error, """");
416 raise Error_Exit;
417 end;
418
419 -- Read line by line and put the content of each non-
420 -- empty line in the Last_Switches table.
421
422 while not End_Of_File (Arg_File) loop
423 Get_Line (Arg_File, Line, Last);
424
425 if Last /= 0 then
426 Last_Switches.Increment_Last;
427 Last_Switches.Table (Last_Switches.Last) :=
428 new String'(Line (1 .. Last));
429 end if;
430 end loop;
431
432 Close (Arg_File);
433 end;
434
435 elsif The_Arg'Length > 0 then
436 -- It is not an argument file; just put the argument in
437 -- the Last_Switches table.
438
439 Last_Switches.Increment_Last;
440 Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
441 end if;
442 end;
443 end loop;
444
445 declare
446 Program : String_Access;
447 Exec_Path : String_Access;
448 Get_Target : Boolean := False;
449
450 begin
451 if The_Command = Stack then
452
453 -- Never call gnatstack with a prefix
454
455 Program := new String'(Command_List (The_Command).Unixcmd.all);
456
457 else
458 Program :=
459 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
460
461 -- If we want to invoke gnatmake/gnatclean with -P, then check if
462 -- gprbuild/gprclean is available; if it is, use gprbuild/gprclean
463 -- instead of gnatmake/gnatclean.
464 -- Ditto for gnatname -> gprname and gnatls -> gprls.
465
466 if The_Command = Make
467 or else The_Command = Compile
468 or else The_Command = Bind
469 or else The_Command = Link
470 or else The_Command = Clean
471 or else The_Command = Name
472 or else The_Command = List
473 then
474 declare
475 Switch : String_Access;
476 Call_GPR_Tool : Boolean := False;
477 begin
478 for J in 1 .. Last_Switches.Last loop
479 Switch := Last_Switches.Table (J);
480
481 if Switch'Length >= 2
482 and then Switch (Switch'First .. Switch'First + 1) = "-P"
483 then
484 Call_GPR_Tool := True;
485 exit;
486 end if;
487 end loop;
488
489 if Call_GPR_Tool then
490 case The_Command is
491 when Bind
492 | Compile
493 | Link
494 | Make
495 =>
496 if Locate_Exec_On_Path (Gprbuild) /= null then
497 Program := new String'(Gprbuild);
498 Get_Target := True;
499
500 if The_Command = Bind then
501 First_Switches.Append (new String'("-b"));
502 elsif The_Command = Link then
503 First_Switches.Append (new String'("-l"));
504 end if;
505
506 elsif The_Command = Bind then
507 Fail
508 ("'gnat bind -P' is no longer supported;" &
509 " use 'gprbuild -b' instead.");
510
511 elsif The_Command = Link then
512 Fail
513 ("'gnat Link -P' is no longer supported;" &
514 " use 'gprbuild -l' instead.");
515 end if;
516
517 when Clean =>
518 if Locate_Exec_On_Path (Gprclean) /= null then
519 Program := new String'(Gprclean);
520 Get_Target := True;
521 end if;
522
523 when Name =>
524 if Locate_Exec_On_Path (Gprname) /= null then
525 Program := new String'(Gprname);
526 Get_Target := True;
527 end if;
528
529 when List =>
530 if Locate_Exec_On_Path (Gprls) /= null then
531 Program := new String'(Gprls);
532 Get_Target := True;
533 end if;
534
535 when others =>
536 null;
537 end case;
538
539 if Get_Target then
540 Find_Program_Name;
541
542 if Name_Len > 5 then
543 First_Switches.Append
544 (new String'
545 ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
546 end if;
547 end if;
548 end if;
549 end;
550 end if;
551 end if;
552
553 -- Locate the executable for the command
554
555 Exec_Path := Locate_Exec_On_Path (Program.all);
556
557 if Exec_Path = null then
558 Put_Line (Standard_Error, "could not locate " & Program.all);
559 raise Error_Exit;
560 end if;
561
562 -- If there are switches for the executable, put them as first switches
563
564 if Command_List (The_Command).Unixsws /= null then
565 for J in Command_List (The_Command).Unixsws'Range loop
566 First_Switches.Increment_Last;
567 First_Switches.Table (First_Switches.Last) :=
568 Command_List (The_Command).Unixsws (J);
569 end loop;
570 end if;
571
572 -- For FIND and XREF, look for switch -P. If it is specified, then
573 -- report an error indicating that the command is no longer supporting
574 -- project files.
575
576 if The_Command = Find or else The_Command = Xref then
577 declare
578 Argv : String_Access;
579 begin
580 for Arg_Num in 1 .. Last_Switches.Last loop
581 Argv := Last_Switches.Table (Arg_Num);
582
583 if Argv'Length >= 2 and then
584 Argv (Argv'First .. Argv'First + 1) = "-P"
585 then
586 if The_Command = Find then
587 Fail ("'gnat find -P' is no longer supported;");
588 else
589 Fail ("'gnat xref -P' is no longer supported;");
590 end if;
591 end if;
592 end loop;
593 end;
594 end if;
595
596 -- Gather all the arguments and invoke the executable
597
598 declare
599 The_Args : Argument_List
600 (1 .. First_Switches.Last + Last_Switches.Last);
601 Arg_Num : Natural := 0;
602
603 begin
604 for J in 1 .. First_Switches.Last loop
605 Arg_Num := Arg_Num + 1;
606 The_Args (Arg_Num) := First_Switches.Table (J);
607 end loop;
608
609 for J in 1 .. Last_Switches.Last loop
610 Arg_Num := Arg_Num + 1;
611 The_Args (Arg_Num) := Last_Switches.Table (J);
612 end loop;
613
614 if Verbose_Mode then
615 Put (Exec_Path.all);
616
617 for Arg in The_Args'Range loop
618 Put (" " & The_Args (Arg).all);
619 end loop;
620
621 New_Line;
622 end if;
623
624 My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
625
626 Set_Exit_Status (My_Exit_Status);
627 end;
628 end;
629
630 exception
631 when Error_Exit =>
632 Set_Exit_Status (Failure);
633 end GNATCmd;