?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config/rs6000/rs6000.md: Document why a pattern is not
[official-gcc.git] / gcc / ada / gnatcmd.adb
blobb793b48a7de56c60afcd08c35189c7225b3e94b6
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T C M D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
28
29 with Csets;
30 with MLib.Tgt; use MLib.Tgt;
31 with MLib.Utl;
32 with Namet; use Namet;
33 with Opt;
34 with Osint; use Osint;
35 with Output;
36 with Prj; use Prj;
37 with Prj.Com;
38 with Prj.Env;
39 with Prj.Ext; use Prj.Ext;
40 with Prj.Pars;
41 with Prj.Util; use Prj.Util;
42 with Snames; use Snames;
43 with Table;
44 with Types; use Types;
45 with Hostparm; use Hostparm;
46 -- Used to determine if we are in VMS or not for error message purposes
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.OS_Lib; use GNAT.OS_Lib;
53
54 with Table;
55
56 with VMS_Conv; use VMS_Conv;
57
58 procedure GNATCmd is
59 Project_File : String_Access;
60 Project : Prj.Project_Id;
61 Current_Verbosity : Prj.Verbosity := Prj.Default;
62 Tool_Package_Name : Name_Id := No_Name;
63
64 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
65 -- an old fashioned project file. -p cannot be used in conjonction
66 -- with -P.
67
68 Old_Project_File_Used : Boolean := False;
69
70 -- A table to keep the switches from the project file
71
72 package First_Switches is new Table.Table
73 (Table_Component_Type => String_Access,
74 Table_Index_Type => Integer,
75 Table_Low_Bound => 1,
76 Table_Initial => 20,
77 Table_Increment => 100,
78 Table_Name => "Gnatcmd.First_Switches");
79
80 package Library_Paths is new Table.Table (
81 Table_Component_Type => String_Access,
82 Table_Index_Type => Integer,
83 Table_Low_Bound => 1,
84 Table_Initial => 20,
85 Table_Increment => 100,
86 Table_Name => "Make.Library_Path");
87
88 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
89 -- tool. We allocate objects because we cannot declare aliased objects
90 -- as we are in a procedure, not a library level package.
91
92 Naming_String : constant String_Access := new String'("naming");
93 Binder_String : constant String_Access := new String'("binder");
94 Eliminate_String : constant String_Access := new String'("eliminate");
95 Finder_String : constant String_Access := new String'("finder");
96 Linker_String : constant String_Access := new String'("linker");
97 Gnatls_String : constant String_Access := new String'("gnatls");
98 Pretty_String : constant String_Access := new String'("pretty_printer");
99 Gnatstub_String : constant String_Access := new String'("gnatstub");
100 Xref_String : constant String_Access := new String'("cross_reference");
101
102 Packages_To_Check_By_Binder : constant String_List_Access :=
103 new String_List'((Naming_String, Binder_String));
104
105 Packages_To_Check_By_Eliminate : constant String_List_Access :=
106 new String_List'((Naming_String, Eliminate_String));
107
108 Packages_To_Check_By_Finder : constant String_List_Access :=
109 new String_List'((Naming_String, Finder_String));
110
111 Packages_To_Check_By_Linker : constant String_List_Access :=
112 new String_List'((Naming_String, Linker_String));
113
114 Packages_To_Check_By_Gnatls : constant String_List_Access :=
115 new String_List'((Naming_String, Gnatls_String));
116
117 Packages_To_Check_By_Pretty : constant String_List_Access :=
118 new String_List'((Naming_String, Pretty_String));
119
120 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
121 new String_List'((Naming_String, Gnatstub_String));
122
123 Packages_To_Check_By_Xref : constant String_List_Access :=
124 new String_List'((Naming_String, Xref_String));
125
126 Packages_To_Check : String_List_Access := Prj.All_Packages;
127
128 ----------------------------------
129 -- Declarations for GNATCMD use --
130 ----------------------------------
131
132 The_Command : Command_Type;
133
134 Command_Arg : Positive := 1;
135
136 My_Exit_Status : Exit_Status := Success;
137
138 Current_Work_Dir : constant String := Get_Current_Dir;
139
140 -----------------------
141 -- Local Subprograms --
142 -----------------------
143
144 procedure Check_Relative_Executable (Name : in out String_Access);
145 -- Check if an executable is specified as a relative path.
146 -- If it is, and the path contains directory information, fail.
147 -- Otherwise, prepend the exec directory.
148 -- This procedure is only used for GNAT LINK when a project file
149 -- is specified.
150
151 function Configuration_Pragmas_File return Name_Id;
152 -- Return an argument, if there is a configuration pragmas file to be
153 -- specified for Project, otherwise return No_Name.
154 -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim
155 -- (GNAT ELIM).
156
157 procedure Delete_Temp_Config_Files;
158 -- Delete all temporary config files
159
160 function Index (Char : Character; Str : String) return Natural;
161 -- Returns the first occurrence of Char in Str.
162 -- Returns 0 if Char is not in Str.
163
164 procedure Non_VMS_Usage;
165 -- Display usage for platforms other than VMS
166
167 procedure Set_Library_For
168 (Project : Project_Id;
169 There_Are_Libraries : in out Boolean);
170 -- If Project is a library project, add the correct
171 -- -L and -l switches to the linker invocation.
172
173 procedure Set_Libraries is
174 new For_Every_Project_Imported (Boolean, Set_Library_For);
175 -- Add the -L and -l switches to the linker for all
176 -- of the library projects.
177
178 procedure Test_If_Relative_Path
179 (Switch : in out String_Access;
180 Parent : String);
181 -- Test if Switch is a relative search path switch.
182 -- If it is and it includes directory information, prepend the path with
183 -- Parent.This subprogram is only called when using project files.
184
185 -------------------------------
186 -- Check_Relative_Executable --
187 -------------------------------
188
189 procedure Check_Relative_Executable (Name : in out String_Access) is
190 Exec_File_Name : constant String := Name.all;
191
192 begin
193 if not Is_Absolute_Path (Exec_File_Name) then
194 for Index in Exec_File_Name'Range loop
195 if Exec_File_Name (Index) = Directory_Separator then
196 Fail ("relative executable (""" &
197 Exec_File_Name &
198 """) with directory part not allowed " &
199 "when using project files");
200 end if;
201 end loop;
202
203 Get_Name_String (Projects.Table
204 (Project).Exec_Directory);
205
206 if Name_Buffer (Name_Len) /= Directory_Separator then
207 Name_Len := Name_Len + 1;
208 Name_Buffer (Name_Len) := Directory_Separator;
209 end if;
210
211 Name_Buffer (Name_Len + 1 ..
212 Name_Len + Exec_File_Name'Length) :=
213 Exec_File_Name;
214 Name_Len := Name_Len + Exec_File_Name'Length;
215 Name := new String'(Name_Buffer (1 .. Name_Len));
216 end if;
217 end Check_Relative_Executable;
218
219 --------------------------------
220 -- Configuration_Pragmas_File --
221 --------------------------------
222
223 function Configuration_Pragmas_File return Name_Id is
224 begin
225 Prj.Env.Create_Config_Pragmas_File
226 (Project, Project, Include_Config_Files => False);
227 return Projects.Table (Project).Config_File_Name;
228 end Configuration_Pragmas_File;
229
230 ------------------------------
231 -- Delete_Temp_Config_Files --
232 ------------------------------
233
234 procedure Delete_Temp_Config_Files is
235 Success : Boolean;
236
237 begin
238 if Project /= No_Project then
239 for Prj in 1 .. Projects.Last loop
240 if Projects.Table (Prj).Config_File_Temp then
241 if Opt.Verbose_Mode then
242 Output.Write_Str ("Deleting temp configuration file """);
243 Output.Write_Str (Get_Name_String
244 (Projects.Table (Prj).Config_File_Name));
245 Output.Write_Line ("""");
246 end if;
247
248 Delete_File
249 (Name => Get_Name_String
250 (Projects.Table (Prj).Config_File_Name),
251 Success => Success);
252 end if;
253 end loop;
254 end if;
255 end Delete_Temp_Config_Files;
256
257 -----------
258 -- Index --
259 -----------
260
261 function Index (Char : Character; Str : String) return Natural is
262 begin
263 for Index in Str'Range loop
264 if Str (Index) = Char then
265 return Index;
266 end if;
267 end loop;
268
269 return 0;
270 end Index;
271
272 ---------------------
273 -- Set_Library_For --
274 ---------------------
275
276 procedure Set_Library_For
277 (Project : Project_Id;
278 There_Are_Libraries : in out Boolean)
279 is
280 Path_Option : constant String_Access :=
281 MLib.Tgt.Linker_Library_Path_Option;
282
283 begin
284 -- Case of library project
285
286 if Projects.Table (Project).Library then
287 There_Are_Libraries := True;
288
289 -- Add the -L switch
290
291 Last_Switches.Increment_Last;
292 Last_Switches.Table (Last_Switches.Last) :=
293 new String'("-L" &
294 Get_Name_String
295 (Projects.Table (Project).Library_Dir));
296
297 -- Add the -l switch
298
299 Last_Switches.Increment_Last;
300 Last_Switches.Table (Last_Switches.Last) :=
301 new String'("-l" &
302 Get_Name_String
303 (Projects.Table (Project).Library_Name));
304
305 -- Add the directory to table Library_Paths, to be processed later
306 -- if library is not static and if Path_Option is not null.
307
308 if Projects.Table (Project).Library_Kind /= Static
309 and then Path_Option /= null
310 then
311 Library_Paths.Increment_Last;
312 Library_Paths.Table (Library_Paths.Last) :=
313 new String'(Get_Name_String
314 (Projects.Table (Project).Library_Dir));
315 end if;
316
317 end if;
318 end Set_Library_For;
319
320 ---------------------------
321 -- Test_If_Relative_Path --
322 ---------------------------
323
324 procedure Test_If_Relative_Path
325 (Switch : in out String_Access;
326 Parent : String)
327 is
328 begin
329 if Switch /= null then
330
331 declare
332 Sw : String (1 .. Switch'Length);
333 Start : Positive := 1;
334
335 begin
336 Sw := Switch.all;
337
338 if Sw (1) = '-' then
339 if Sw'Length >= 3
340 and then (Sw (2) = 'A'
341 or else Sw (2) = 'I'
342 or else Sw (2) = 'L')
343 then
344 Start := 3;
345
346 if Sw = "-I-" then
347 return;
348 end if;
349
350 elsif Sw'Length >= 4
351 and then (Sw (2 .. 3) = "aL"
352 or else Sw (2 .. 3) = "aO"
353 or else Sw (2 .. 3) = "aI")
354 then
355 Start := 4;
356
357 elsif Sw'Length >= 7
358 and then Sw (2 .. 6) = "-RTS="
359 then
360 Start := 7;
361 else
362 return;
363 end if;
364 end if;
365
366 -- If the path is relative, test if it includes directory
367 -- information. If it does, prepend Parent to the path.
368
369 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
370 for J in Start .. Sw'Last loop
371 if Sw (J) = Directory_Separator then
372 Switch :=
373 new String'
374 (Sw (1 .. Start - 1) &
375 Parent &
376 Directory_Separator &
377 Sw (Start .. Sw'Last));
378 return;
379 end if;
380 end loop;
381 end if;
382 end;
383 end if;
384 end Test_If_Relative_Path;
385
386 -------------------
387 -- Non_VMS_Usage --
388 -------------------
389
390 procedure Non_VMS_Usage is
391 begin
392 Output_Version;
393 New_Line;
394 Put_Line ("List of available commands");
395 New_Line;
396
397 for C in Command_List'Range loop
398 if not Command_List (C).VMS_Only then
399 Put ("GNAT " & Command_List (C).Cname.all);
400 Set_Col (25);
401 Put (Command_List (C).Unixcmd.all);
402
403 declare
404 Sws : Argument_List_Access renames Command_List (C).Unixsws;
405 begin
406 if Sws /= null then
407 for J in Sws'Range loop
408 Put (' ');
409 Put (Sws (J).all);
410 end loop;
411 end if;
412 end;
413
414 New_Line;
415 end if;
416 end loop;
417
418 New_Line;
419 Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " &
420 "project file switches -vPx, -Pprj and -Xnam=val");
421 New_Line;
422 end Non_VMS_Usage;
423
424 -------------------------------------
425 -- Start of processing for GNATCmd --
426 -------------------------------------
427
428 begin
429 -- Initializations
430
431 Namet.Initialize;
432 Csets.Initialize;
433
434 Snames.Initialize;
435
436 Prj.Initialize;
437
438 Last_Switches.Init;
439 Last_Switches.Set_Last (0);
440
441 First_Switches.Init;
442 First_Switches.Set_Last (0);
443
444 VMS_Conv.Initialize;
445
446 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
447 -- filenames and pathnames to Unix style.
448
449 if Hostparm.OpenVMS
450 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
451 then
452 VMS_Conversion (The_Command);
453
454 -- If not on VMS, scan the command line directly
455
456 else
457 if Argument_Count = 0 then
458 Non_VMS_Usage;
459 return;
460 else
461 begin
462 if Argument_Count > 1 and then Argument (1) = "-v" then
463 Opt.Verbose_Mode := True;
464 Command_Arg := 2;
465 end if;
466
467 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
468
469 if Command_List (The_Command).VMS_Only then
470 Non_VMS_Usage;
471 Fail
472 ("Command """,
473 Command_List (The_Command).Cname.all,
474 """ can only be used on VMS");
475 end if;
476
477 exception
478 when Constraint_Error =>
479
480 -- Check if it is an alternate command
481
482 declare
483 Alternate : Alternate_Command;
484
485 begin
486 Alternate := Alternate_Command'Value
487 (Argument (Command_Arg));
488 The_Command := Corresponding_To (Alternate);
489
490 exception
491 when Constraint_Error =>
492 Non_VMS_Usage;
493 Fail ("Unknown command: ", Argument (Command_Arg));
494 end;
495 end;
496
497 -- Get the arguments from the command line and from the eventual
498 -- argument file(s) specified on the command line.
499
500 for Arg in Command_Arg + 1 .. Argument_Count loop
501 declare
502 The_Arg : constant String := Argument (Arg);
503
504 begin
505 -- Check if an argument file is specified
506
507 if The_Arg (The_Arg'First) = '@' then
508 declare
509 Arg_File : Ada.Text_IO.File_Type;
510 Line : String (1 .. 256);
511 Last : Natural;
512
513 begin
514 -- Open the file and fail if the file cannot be found
515
516 begin
517 Open
518 (Arg_File, In_File,
519 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
520
521 exception
522 when others =>
523 Put
524 (Standard_Error, "Cannot open argument file """);
525 Put
526 (Standard_Error,
527 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
528
529 Put_Line (Standard_Error, """");
530 raise Error_Exit;
531 end;
532
533 -- Read line by line and put the content of each
534 -- non empty line in the Last_Switches table.
535
536 while not End_Of_File (Arg_File) loop
537 Get_Line (Arg_File, Line, Last);
538
539 if Last /= 0 then
540 Last_Switches.Increment_Last;
541 Last_Switches.Table (Last_Switches.Last) :=
542 new String'(Line (1 .. Last));
543 end if;
544 end loop;
545
546 Close (Arg_File);
547 end;
548
549 else
550 -- It is not an argument file; just put the argument in
551 -- the Last_Switches table.
552
553 Last_Switches.Increment_Last;
554 Last_Switches.Table (Last_Switches.Last) :=
555 new String'(The_Arg);
556 end if;
557 end;
558 end loop;
559 end if;
560 end if;
561
562 declare
563 Program : constant String :=
564 Program_Name (Command_List (The_Command).Unixcmd.all).all;
565
566 Exec_Path : String_Access;
567
568 begin
569 -- Locate the executable for the command
570
571 Exec_Path := Locate_Exec_On_Path (Program);
572
573 if Exec_Path = null then
574 Put_Line (Standard_Error, "Couldn't locate " & Program);
575 raise Error_Exit;
576 end if;
577
578 -- If there are switches for the executable, put them as first switches
579
580 if Command_List (The_Command).Unixsws /= null then
581 for J in Command_List (The_Command).Unixsws'Range loop
582 First_Switches.Increment_Last;
583 First_Switches.Table (First_Switches.Last) :=
584 Command_List (The_Command).Unixsws (J);
585 end loop;
586 end if;
587
588 -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file
589 -- related switches.
590
591 if The_Command = Bind
592 or else The_Command = Elim
593 or else The_Command = Find
594 or else The_Command = Link
595 or else The_Command = List
596 or else The_Command = Xref
597 or else The_Command = Pretty
598 or else The_Command = Stub
599 then
600 case The_Command is
601 when Bind =>
602 Tool_Package_Name := Name_Binder;
603 Packages_To_Check := Packages_To_Check_By_Binder;
604 when Elim =>
605 Tool_Package_Name := Name_Eliminate;
606 Packages_To_Check := Packages_To_Check_By_Eliminate;
607 when Find =>
608 Tool_Package_Name := Name_Finder;
609 Packages_To_Check := Packages_To_Check_By_Finder;
610 when Link =>
611 Tool_Package_Name := Name_Linker;
612 Packages_To_Check := Packages_To_Check_By_Linker;
613 when List =>
614 Tool_Package_Name := Name_Gnatls;
615 Packages_To_Check := Packages_To_Check_By_Gnatls;
616 when Pretty =>
617 Tool_Package_Name := Name_Pretty_Printer;
618 Packages_To_Check := Packages_To_Check_By_Pretty;
619 when Stub =>
620 Tool_Package_Name := Name_Gnatstub;
621 Packages_To_Check := Packages_To_Check_By_Gnatstub;
622 when Xref =>
623 Tool_Package_Name := Name_Cross_Reference;
624 Packages_To_Check := Packages_To_Check_By_Xref;
625 when others =>
626 null;
627 end case;
628
629 -- Check that the switches are consistent.
630 -- Detect project file related switches.
631
632 Inspect_Switches :
633 declare
634 Arg_Num : Positive := 1;
635 Argv : String_Access;
636
637 procedure Remove_Switch (Num : Positive);
638 -- Remove a project related switch from table Last_Switches
639
640 -------------------
641 -- Remove_Switch --
642 -------------------
643
644 procedure Remove_Switch (Num : Positive) is
645 begin
646 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
647 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
648 Last_Switches.Decrement_Last;
649 end Remove_Switch;
650
651 -- Start of processing for Inspect_Switches
652
653 begin
654 while Arg_Num <= Last_Switches.Last loop
655 Argv := Last_Switches.Table (Arg_Num);
656
657 if Argv (Argv'First) = '-' then
658 if Argv'Length = 1 then
659 Fail
660 ("switch character cannot be followed by a blank");
661 end if;
662
663 -- The two style project files (-p and -P) cannot be used
664 -- together
665
666 if (The_Command = Find or else The_Command = Xref)
667 and then Argv (2) = 'p'
668 then
669 Old_Project_File_Used := True;
670 if Project_File /= null then
671 Fail ("-P and -p cannot be used together");
672 end if;
673 end if;
674
675 -- -vPx Specify verbosity while parsing project files
676
677 if Argv'Length = 4
678 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
679 then
680 case Argv (Argv'Last) is
681 when '0' =>
682 Current_Verbosity := Prj.Default;
683 when '1' =>
684 Current_Verbosity := Prj.Medium;
685 when '2' =>
686 Current_Verbosity := Prj.High;
687 when others =>
688 Fail ("Invalid switch: ", Argv.all);
689 end case;
690
691 Remove_Switch (Arg_Num);
692
693 -- -Pproject_file Specify project file to be used
694
695 elsif Argv (Argv'First + 1) = 'P' then
696
697 -- Only one -P switch can be used
698
699 if Project_File /= null then
700 Fail
701 (Argv.all,
702 ": second project file forbidden (first is """,
703 Project_File.all & """)");
704
705 -- The two style project files (-p and -P) cannot be
706 -- used together.
707
708 elsif Old_Project_File_Used then
709 Fail ("-p and -P cannot be used together");
710
711 elsif Argv'Length = 2 then
712
713 -- There is space between -P and the project file
714 -- name. -P cannot be the last option.
715
716 if Arg_Num = Last_Switches.Last then
717 Fail ("project file name missing after -P");
718
719 else
720 Remove_Switch (Arg_Num);
721 Argv := Last_Switches.Table (Arg_Num);
722
723 -- After -P, there must be a project file name,
724 -- not another switch.
725
726 if Argv (Argv'First) = '-' then
727 Fail ("project file name missing after -P");
728
729 else
730 Project_File := new String'(Argv.all);
731 end if;
732 end if;
733
734 else
735 -- No space between -P and project file name
736
737 Project_File :=
738 new String'(Argv (Argv'First + 2 .. Argv'Last));
739 end if;
740
741 Remove_Switch (Arg_Num);
742
743 -- -Xexternal=value Specify an external reference to be
744 -- used in project files
745
746 elsif Argv'Length >= 5
747 and then Argv (Argv'First + 1) = 'X'
748 then
749 declare
750 Equal_Pos : constant Natural :=
751 Index ('=', Argv (Argv'First + 2 .. Argv'Last));
752 begin
753 if Equal_Pos >= Argv'First + 3 and then
754 Equal_Pos /= Argv'Last then
755 Add (External_Name =>
756 Argv (Argv'First + 2 .. Equal_Pos - 1),
757 Value => Argv (Equal_Pos + 1 .. Argv'Last));
758 else
759 Fail
760 (Argv.all,
761 " is not a valid external assignment.");
762 end if;
763 end;
764
765 Remove_Switch (Arg_Num);
766
767 else
768 Arg_Num := Arg_Num + 1;
769 end if;
770
771 else
772 Arg_Num := Arg_Num + 1;
773 end if;
774 end loop;
775 end Inspect_Switches;
776 end if;
777
778 -- If there is a project file specified, parse it, get the switches
779 -- for the tool and setup PATH environment variables.
780
781 if Project_File /= null then
782 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
783
784 Prj.Pars.Parse
785 (Project => Project,
786 Project_File_Name => Project_File.all,
787 Packages_To_Check => Packages_To_Check);
788
789 if Project = Prj.No_Project then
790 Fail ("""", Project_File.all, """ processing failed");
791 end if;
792
793 -- Check if a package with the name of the tool is in the project
794 -- file and if there is one, get the switches, if any, and scan them.
795
796 declare
797 Data : constant Prj.Project_Data :=
798 Prj.Projects.Table (Project);
799
800 Pkg : constant Prj.Package_Id :=
801 Prj.Util.Value_Of
802 (Name => Tool_Package_Name,
803 In_Packages => Data.Decl.Packages);
804
805 Element : Package_Element;
806
807 Default_Switches_Array : Array_Element_Id;
808
809 The_Switches : Prj.Variable_Value;
810 Current : Prj.String_List_Id;
811 The_String : String_Element;
812
813 begin
814 if Pkg /= No_Package then
815 Element := Packages.Table (Pkg);
816
817 -- Packages Gnatls has a single attribute Switches, that is
818 -- not an associative array.
819
820 if The_Command = List then
821 The_Switches :=
822 Prj.Util.Value_Of
823 (Variable_Name => Snames.Name_Switches,
824 In_Variables => Element.Decl.Attributes);
825
826 -- Packages Binder (for gnatbind), Cross_Reference (for
827 -- gnatxref), Linker (for gnatlink) Finder (for gnatfind),
828 -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim)
829 -- have an attributed Switches, an associative array, indexed
830 -- by the name of the file.
831
832 -- They also have an attribute Default_Switches, indexed
833 -- by the name of the programming language.
834
835 else
836 if The_Switches.Kind = Prj.Undefined then
837 Default_Switches_Array :=
838 Prj.Util.Value_Of
839 (Name => Name_Default_Switches,
840 In_Arrays => Element.Decl.Arrays);
841 The_Switches := Prj.Util.Value_Of
842 (Index => Name_Ada,
843 In_Array => Default_Switches_Array);
844 end if;
845 end if;
846
847 -- If there are switches specified in the package of the
848 -- project file corresponding to the tool, scan them.
849
850 case The_Switches.Kind is
851 when Prj.Undefined =>
852 null;
853
854 when Prj.Single =>
855 declare
856 Switch : constant String :=
857 Get_Name_String (The_Switches.Value);
858
859 begin
860 if Switch'Length > 0 then
861 First_Switches.Increment_Last;
862 First_Switches.Table (First_Switches.Last) :=
863 new String'(Switch);
864 end if;
865 end;
866
867 when Prj.List =>
868 Current := The_Switches.Values;
869 while Current /= Prj.Nil_String loop
870 The_String := String_Elements.Table (Current);
871
872 declare
873 Switch : constant String :=
874 Get_Name_String (The_String.Value);
875
876 begin
877 if Switch'Length > 0 then
878 First_Switches.Increment_Last;
879 First_Switches.Table (First_Switches.Last) :=
880 new String'(Switch);
881 end if;
882 end;
883
884 Current := The_String.Next;
885 end loop;
886 end case;
887 end if;
888 end;
889
890 if The_Command = Bind
891 or else The_Command = Link
892 or else The_Command = Elim
893 then
894 Change_Dir
895 (Get_Name_String
896 (Projects.Table (Project).Object_Directory));
897 end if;
898
899 -- Set up the env vars for project path files
900
901 Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False);
902
903 -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas
904 -- file, if necessary.
905
906 if The_Command = Pretty
907 or else The_Command = Stub
908 or else The_Command = Elim
909 then
910 declare
911 CP_File : constant Name_Id := Configuration_Pragmas_File;
912
913 begin
914 if CP_File /= No_Name then
915 First_Switches.Increment_Last;
916
917 if The_Command = Elim then
918 First_Switches.Table (First_Switches.Last) :=
919 new String'("-C" & Get_Name_String (CP_File));
920
921 else
922 First_Switches.Table (First_Switches.Last) :=
923 new String'("-gnatec=" & Get_Name_String (CP_File));
924 end if;
925 end if;
926 end;
927 end if;
928
929 if The_Command = Link then
930
931 -- Add the default search directories, to be able to find
932 -- libgnat in call to MLib.Utl.Lib_Directory.
933
934 Add_Default_Search_Dirs;
935
936 declare
937 There_Are_Libraries : Boolean := False;
938 Path_Option : constant String_Access :=
939 MLib.Tgt.Linker_Library_Path_Option;
940
941 begin
942 Library_Paths.Set_Last (0);
943
944 -- Check if there are library project files
945
946 if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
947 Set_Libraries (Project, There_Are_Libraries);
948 end if;
949
950 -- If there are, add the necessary additional switches
951
952 if There_Are_Libraries then
953
954 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
955
956 Last_Switches.Increment_Last;
957 Last_Switches.Table (Last_Switches.Last) :=
958 new String'("-L" & MLib.Utl.Lib_Directory);
959 Last_Switches.Increment_Last;
960 Last_Switches.Table (Last_Switches.Last) :=
961 new String'("-lgnarl");
962 Last_Switches.Increment_Last;
963 Last_Switches.Table (Last_Switches.Last) :=
964 new String'("-lgnat");
965
966 -- If Path_Option is not null, create the switch
967 -- ("-Wl,-rpath," or equivalent) with all the library dirs
968 -- plus the standard GNAT library dir.
969
970 if Path_Option /= null then
971 declare
972 Option : String_Access;
973 Length : Natural := Path_Option'Length;
974 Current : Natural;
975
976 begin
977 -- First, compute the exact length for the switch
978
979 for Index in
980 Library_Paths.First .. Library_Paths.Last
981 loop
982 -- Add the length of the library dir plus one
983 -- for the directory separator.
984
985 Length :=
986 Length +
987 Library_Paths.Table (Index)'Length + 1;
988 end loop;
989
990 -- Finally, add the length of the standard GNAT
991 -- library dir.
992
993 Length := Length + MLib.Utl.Lib_Directory'Length;
994 Option := new String (1 .. Length);
995 Option (1 .. Path_Option'Length) := Path_Option.all;
996 Current := Path_Option'Length;
997
998 -- Put each library dir followed by a dir separator
999
1000 for Index in
1001 Library_Paths.First .. Library_Paths.Last
1002 loop
1003 Option
1004 (Current + 1 ..
1005 Current +
1006 Library_Paths.Table (Index)'Length) :=
1007 Library_Paths.Table (Index).all;
1008 Current :=
1009 Current +
1010 Library_Paths.Table (Index)'Length + 1;
1011 Option (Current) := Path_Separator;
1012 end loop;
1013
1014 -- Finally put the standard GNAT library dir
1015
1016 Option
1017 (Current + 1 ..
1018 Current + MLib.Utl.Lib_Directory'Length) :=
1019 MLib.Utl.Lib_Directory;
1020
1021 -- And add the switch to the last switches
1022
1023 Last_Switches.Increment_Last;
1024 Last_Switches.Table (Last_Switches.Last) :=
1025 Option;
1026 end;
1027 end if;
1028 end if;
1029 end;
1030
1031 -- Check if the first ALI file specified can be found, either
1032 -- in the object directory of the main project or in an object
1033 -- directory of a project file extended by the main project.
1034 -- If the ALI file can be found, replace its name with its
1035 -- absolute path.
1036
1037 declare
1038 Skip_Executable : Boolean := False;
1039
1040 begin
1041 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1042
1043 -- If we have an executable just reset the flag
1044
1045 if Skip_Executable then
1046 Skip_Executable := False;
1047
1048 -- If -o, set flag so that next switch is not processed
1049
1050 elsif Last_Switches.Table (J).all = "-o" then
1051 Skip_Executable := True;
1052
1053 -- Normal case
1054
1055 else
1056 declare
1057 Switch : constant String :=
1058 Last_Switches.Table (J).all;
1059
1060 ALI_File : constant String (1 .. Switch'Length + 4) :=
1061 Switch & ".ali";
1062
1063 Last : Natural := Switch'Length;
1064 Test_Existence : Boolean := False;
1065
1066 begin
1067 -- Skip real switches
1068
1069 if Switch'Length /= 0 and then
1070 Switch (Switch'First) /= '-'
1071 then
1072 -- Append ".ali" if file name does not end with it
1073
1074 if Switch'Length <= 4 or else
1075 Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1076 then
1077 Last := ALI_File'Last;
1078 end if;
1079
1080 -- If file name includes directory information,
1081 -- stop if ALI file exists.
1082
1083 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1084 Test_Existence := True;
1085
1086 else
1087 for K in Switch'Range loop
1088 if Switch (K) = '/' or else
1089 Switch (K) = Directory_Separator
1090 then
1091 Test_Existence := True;
1092 exit;
1093 end if;
1094 end loop;
1095 end if;
1096
1097 if Test_Existence then
1098 if Is_Regular_File (ALI_File (1 .. Last)) then
1099 exit Switch_Loop;
1100 end if;
1101
1102 else
1103 -- Look in the object directories if the ALI
1104 -- file exists.
1105
1106 declare
1107 Prj : Project_Id := Project;
1108 begin
1109 Project_Loop :
1110 loop
1111 declare
1112 Dir : constant String :=
1113 Get_Name_String
1114 (Projects.Table (Prj).
1115 Object_Directory);
1116 begin
1117 if Is_Regular_File
1118 (Dir & Directory_Separator &
1119 ALI_File (1 .. Last))
1120 then
1121 -- We have found the correct
1122 -- project, so we replace the file
1123 -- with the absolute path.
1124
1125 Last_Switches.Table (J) :=
1126 new String'
1127 (Dir & Directory_Separator &
1128 ALI_File (1 .. Last));
1129
1130 -- And we are done
1131
1132 exit Switch_Loop;
1133 end if;
1134 end;
1135
1136 -- Go to the project being extended,
1137 -- if any.
1138
1139 Prj := Projects.Table (Prj).Extends;
1140 exit Project_Loop when Prj = No_Project;
1141 end loop Project_Loop;
1142 end;
1143 end if;
1144 end if;
1145 end;
1146 end if;
1147 end loop Switch_Loop;
1148 end;
1149
1150 -- If a relative path output file has been specified, we add
1151 -- the exec directory.
1152
1153 declare
1154 Look_For_Executable : Boolean := True;
1155
1156 begin
1157
1158 for J in reverse 1 .. Last_Switches.Last - 1 loop
1159 if Last_Switches.Table (J).all = "-o" then
1160 Check_Relative_Executable
1161 (Name => Last_Switches.Table (J + 1));
1162 Look_For_Executable := False;
1163 exit;
1164 end if;
1165 end loop;
1166
1167 if Look_For_Executable then
1168 for J in reverse 1 .. First_Switches.Last - 1 loop
1169 if First_Switches.Table (J).all = "-o" then
1170 Look_For_Executable := False;
1171 Check_Relative_Executable
1172 (Name => First_Switches.Table (J + 1));
1173 exit;
1174 end if;
1175 end loop;
1176 end if;
1177
1178 -- If no executable is specified, then find the name
1179 -- of the first ALI file on the command line and issue
1180 -- a -o switch with the absolute path of the executable
1181 -- in the exec directory.
1182
1183 if Look_For_Executable then
1184 for J in 1 .. Last_Switches.Last loop
1185 declare
1186 Arg : constant String_Access :=
1187 Last_Switches.Table (J);
1188 Last : Natural := 0;
1189
1190 begin
1191 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
1192 if Arg'Length > 4
1193 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
1194 then
1195 Last := Arg'Last - 4;
1196
1197 elsif Is_Regular_File (Arg.all & ".ali") then
1198 Last := Arg'Last;
1199 end if;
1200
1201 if Last /= 0 then
1202 declare
1203 Executable_Name : constant String :=
1204 Base_Name (Arg (Arg'First .. Last));
1205 begin
1206 Last_Switches.Increment_Last;
1207 Last_Switches.Table (Last_Switches.Last) :=
1208 new String'("-o");
1209 Get_Name_String
1210 (Projects.Table (Project).Exec_Directory);
1211 Last_Switches.Increment_Last;
1212 Last_Switches.Table (Last_Switches.Last) :=
1213 new String'(Name_Buffer (1 .. Name_Len) &
1214 Directory_Separator &
1215 Executable_Name &
1216 Get_Executable_Suffix.all);
1217 exit;
1218 end;
1219 end if;
1220 end if;
1221 end;
1222 end loop;
1223 end if;
1224 end;
1225 end if;
1226
1227 if The_Command = Link or The_Command = Bind then
1228
1229 -- For files that are specified as relative paths with directory
1230 -- information, we convert them to absolute paths, with parent
1231 -- being the current working directory if specified on the command
1232 -- line and the project directory if specified in the project
1233 -- file. This is what gnatmake is doing for linker and binder
1234 -- arguments.
1235
1236 for J in 1 .. Last_Switches.Last loop
1237 Test_If_Relative_Path
1238 (Last_Switches.Table (J), Current_Work_Dir);
1239 end loop;
1240
1241 Get_Name_String (Projects.Table (Project).Directory);
1242
1243 declare
1244 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
1245
1246 begin
1247 for J in 1 .. First_Switches.Last loop
1248 Test_If_Relative_Path
1249 (First_Switches.Table (J), Project_Dir);
1250 end loop;
1251 end;
1252
1253 elsif The_Command = Stub then
1254 declare
1255 Data : constant Prj.Project_Data :=
1256 Prj.Projects.Table (Project);
1257 File_Index : Integer := 0;
1258 Dir_Index : Integer := 0;
1259 Last : constant Integer := Last_Switches.Last;
1260
1261 begin
1262 for Index in 1 .. Last loop
1263 if Last_Switches.Table (Index)
1264 (Last_Switches.Table (Index)'First) /= '-'
1265 then
1266 File_Index := Index;
1267 exit;
1268 end if;
1269 end loop;
1270
1271 -- If the naming scheme of the project file is not standard,
1272 -- and if the file name ends with the spec suffix, then
1273 -- indicate to gnatstub the name of the body file with
1274 -- a -o switch.
1275
1276 if Data.Naming.Current_Spec_Suffix /=
1277 Prj.Default_Ada_Spec_Suffix
1278 then
1279 if File_Index /= 0 then
1280 declare
1281 Spec : constant String :=
1282 Base_Name (Last_Switches.Table (File_Index).all);
1283 Last : Natural := Spec'Last;
1284
1285 begin
1286 Get_Name_String (Data.Naming.Current_Spec_Suffix);
1287
1288 if Spec'Length > Name_Len
1289 and then Spec (Last - Name_Len + 1 .. Last) =
1290 Name_Buffer (1 .. Name_Len)
1291 then
1292 Last := Last - Name_Len;
1293 Get_Name_String (Data.Naming.Current_Body_Suffix);
1294 Last_Switches.Increment_Last;
1295 Last_Switches.Table (Last_Switches.Last) :=
1296 new String'("-o");
1297 Last_Switches.Increment_Last;
1298 Last_Switches.Table (Last_Switches.Last) :=
1299 new String'(Spec (Spec'First .. Last) &
1300 Name_Buffer (1 .. Name_Len));
1301 end if;
1302 end;
1303 end if;
1304 end if;
1305
1306 -- Add the directory of the spec as the destination directory
1307 -- of the body, if there is no destination directory already
1308 -- specified.
1309
1310 if File_Index /= 0 then
1311 for Index in File_Index + 1 .. Last loop
1312 if Last_Switches.Table (Index)
1313 (Last_Switches.Table (Index)'First) /= '-'
1314 then
1315 Dir_Index := Index;
1316 exit;
1317 end if;
1318 end loop;
1319
1320 if Dir_Index = 0 then
1321 Last_Switches.Increment_Last;
1322 Last_Switches.Table (Last_Switches.Last) :=
1323 new String'
1324 (Dir_Name (Last_Switches.Table (File_Index).all));
1325 end if;
1326 end if;
1327 end;
1328 end if;
1329
1330 -- For gnat pretty, if no file has been put on the command line,
1331 -- call gnatpp with all the sources of the main project.
1332
1333 if The_Command = Pretty then
1334 declare
1335 Add_Sources : Boolean := True;
1336 Unit_Data : Prj.Com.Unit_Data;
1337 begin
1338 -- Check if there is at least one argument that is not a switch
1339
1340 for Index in 1 .. Last_Switches.Last loop
1341 if Last_Switches.Table (Index)(1) /= '-' then
1342 Add_Sources := False;
1343 exit;
1344 end if;
1345 end loop;
1346
1347 -- If all arguments were switches, add the path names of
1348 -- all the sources of the main project.
1349
1350 if Add_Sources then
1351 for Unit in 1 .. Prj.Com.Units.Last loop
1352 Unit_Data := Prj.Com.Units.Table (Unit);
1353
1354 for Kind in Prj.Com.Spec_Or_Body loop
1355
1356 -- Put only sources that belong to the main project
1357
1358 if Unit_Data.File_Names (Kind).Project = Project then
1359 Last_Switches.Increment_Last;
1360 Last_Switches.Table (Last_Switches.Last) :=
1361 new String'
1362 (Get_Name_String
1363 (Unit_Data.File_Names (Kind).Display_Path));
1364 end if;
1365 end loop;
1366 end loop;
1367 end if;
1368 end;
1369 end if;
1370 end if;
1371
1372 -- Gather all the arguments and invoke the executable
1373
1374 declare
1375 The_Args : Argument_List
1376 (1 .. First_Switches.Last + Last_Switches.Last);
1377 Arg_Num : Natural := 0;
1378 begin
1379 for J in 1 .. First_Switches.Last loop
1380 Arg_Num := Arg_Num + 1;
1381 The_Args (Arg_Num) := First_Switches.Table (J);
1382 end loop;
1383
1384 for J in 1 .. Last_Switches.Last loop
1385 Arg_Num := Arg_Num + 1;
1386 The_Args (Arg_Num) := Last_Switches.Table (J);
1387 end loop;
1388
1389 -- If Display_Command is on, only display the generated command
1390
1391 if Display_Command then
1392 Put (Standard_Error, "generated command -->");
1393 Put (Standard_Error, Exec_Path.all);
1394
1395 for Arg in The_Args'Range loop
1396 Put (Standard_Error, " ");
1397 Put (Standard_Error, The_Args (Arg).all);
1398 end loop;
1399
1400 Put (Standard_Error, "<--");
1401 New_Line (Standard_Error);
1402 raise Normal_Exit;
1403 end if;
1404
1405 if Opt.Verbose_Mode then
1406 Output.Write_Str (Exec_Path.all);
1407
1408 for Arg in The_Args'Range loop
1409 Output.Write_Char (' ');
1410 Output.Write_Str (The_Args (Arg).all);
1411 end loop;
1412
1413 Output.Write_Eol;
1414 end if;
1415
1416 My_Exit_Status :=
1417 Exit_Status (Spawn (Exec_Path.all, The_Args));
1418 raise Normal_Exit;
1419 end;
1420 end;
1421
1422 exception
1423 when Error_Exit =>
1424 Prj.Env.Delete_All_Path_Files;
1425 Delete_Temp_Config_Files;
1426 Set_Exit_Status (Failure);
1427
1428 when Normal_Exit =>
1429 Prj.Env.Delete_All_Path_Files;
1430 Delete_Temp_Config_Files;
1431
1432 -- Since GNATCmd is normally called from DCL (the VMS shell),
1433 -- it must return an understandable VMS exit status. However
1434 -- the exit status returned *to* GNATCmd is a Posix style code,
1435 -- so we test it and return just a simple success or failure on VMS.
1436
1437 if Hostparm.OpenVMS and then My_Exit_Status /= Success then
1438 Set_Exit_Status (Failure);
1439 else
1440 Set_Exit_Status (My_Exit_Status);
1441 end if;
1442 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org