?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from trunk:
[official-gcc.git] / main / gcc / ada / gnatcmd.adb
blob77cf6dc47ae88f06628ca91192c96efa86ad661e
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-2014, 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 GNAT.Directory_Operations; use GNAT.Directory_Operations;
27
28 with Csets;
29 with Gnatvsn;
30 with Makeutl; use Makeutl;
31 with MLib.Tgt; use MLib.Tgt;
32 with MLib.Utl;
33 with MLib.Fil;
34 with Namet; use Namet;
35 with Opt; use Opt;
36 with Osint; use Osint;
37 with Output; use Output;
38 with Prj; use Prj;
39 with Prj.Env;
40 with Prj.Ext; use Prj.Ext;
41 with Prj.Pars;
42 with Prj.Tree; use Prj.Tree;
43 with Prj.Util; use Prj.Util;
44 with Sdefault;
45 with Sinput.P;
46 with Snames; use Snames;
47 with Stringt;
48 with Switch; use Switch;
49 with Table;
50 with Targparm; use Targparm;
51 with Tempdir;
52 with Types; use Types;
53
54 with Ada.Characters.Handling; use Ada.Characters.Handling;
55 with Ada.Command_Line; use Ada.Command_Line;
56 with Ada.Text_IO; use Ada.Text_IO;
57
58 with GNAT.OS_Lib; use GNAT.OS_Lib;
59
60 procedure GNATCmd is
61 Normal_Exit : exception;
62 -- Raise this exception for normal program termination
63
64 Error_Exit : exception;
65 -- Raise this exception if error detected
66
67 type Command_Type is
68 (Bind,
69 Chop,
70 Clean,
71 Compile,
72 Check,
73 Sync,
74 Elim,
75 Find,
76 Krunch,
77 Link,
78 List,
79 Make,
80 Metric,
81 Name,
82 Preprocess,
83 Pretty,
84 Stack,
85 Stub,
86 Test,
87 Xref,
88 Undefined);
89
90 subtype Real_Command_Type is Command_Type range Bind .. Xref;
91 -- All real command types (excludes only Undefined).
92
93 type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
94 -- Alternate command label
95
96 Corresponding_To : constant array (Alternate_Command) of Command_Type :=
97 (Comp => Compile,
98 Ls => List,
99 Kr => Krunch,
100 Prep => Preprocess,
101 Pp => Pretty);
102 -- Mapping of alternate commands to commands
103
104 Project_Node_Tree : Project_Node_Tree_Ref;
105 Project_File : String_Access;
106 Project : Prj.Project_Id;
107 Current_Verbosity : Prj.Verbosity := Prj.Default;
108 Tool_Package_Name : Name_Id := No_Name;
109
110 B_Start : constant String := "b~";
111 -- Prefix of binder generated file
112
113 Project_Tree : constant Project_Tree_Ref :=
114 new Project_Tree_Data (Is_Root_Tree => True);
115 -- The project tree
116
117 Old_Project_File_Used : Boolean := False;
118 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
119 -- an old fashioned project file. -p cannot be used in conjunction
120 -- with -P.
121
122 Temp_File_Name : Path_Name_Type := No_Path;
123 -- The name of the temporary text file to put a list of source/object
124 -- files to pass to a tool.
125
126 ASIS_Main : String_Access := null;
127 -- Main for commands Check, Metric and Pretty, when -U is used
128
129 package First_Switches is new Table.Table
130 (Table_Component_Type => String_Access,
131 Table_Index_Type => Integer,
132 Table_Low_Bound => 1,
133 Table_Initial => 20,
134 Table_Increment => 100,
135 Table_Name => "Gnatcmd.First_Switches");
136 -- A table to keep the switches from the project file
137
138 package Carg_Switches is new Table.Table
139 (Table_Component_Type => String_Access,
140 Table_Index_Type => Integer,
141 Table_Low_Bound => 1,
142 Table_Initial => 20,
143 Table_Increment => 100,
144 Table_Name => "Gnatcmd.Carg_Switches");
145 -- A table to keep the switches following -cargs for ASIS tools
146
147 package Rules_Switches is new Table.Table
148 (Table_Component_Type => String_Access,
149 Table_Index_Type => Integer,
150 Table_Low_Bound => 1,
151 Table_Initial => 20,
152 Table_Increment => 100,
153 Table_Name => "Gnatcmd.Rules_Switches");
154 -- A table to keep the switches following -rules for gnatcheck
155
156 package Library_Paths is new Table.Table (
157 Table_Component_Type => String_Access,
158 Table_Index_Type => Integer,
159 Table_Low_Bound => 1,
160 Table_Initial => 20,
161 Table_Increment => 100,
162 Table_Name => "Make.Library_Path");
163
164 package Last_Switches is new Table.Table
165 (Table_Component_Type => String_Access,
166 Table_Index_Type => Integer,
167 Table_Low_Bound => 1,
168 Table_Initial => 20,
169 Table_Increment => 100,
170 Table_Name => "Gnatcmd.Last_Switches");
171
172 -- Packages of project files to pass to Prj.Pars.Parse, depending on the
173 -- tool. We allocate objects because we cannot declare aliased objects
174 -- as we are in a procedure, not a library level package.
175
176 subtype SA is String_Access;
177
178 Naming_String : constant SA := new String'("naming");
179 Binder_String : constant SA := new String'("binder");
180 Builder_String : constant SA := new String'("builder");
181 Compiler_String : constant SA := new String'("compiler");
182 Check_String : constant SA := new String'("check");
183 Synchronize_String : constant SA := new String'("synchronize");
184 Eliminate_String : constant SA := new String'("eliminate");
185 Finder_String : constant SA := new String'("finder");
186 Linker_String : constant SA := new String'("linker");
187 Gnatls_String : constant SA := new String'("gnatls");
188 Pretty_String : constant SA := new String'("pretty_printer");
189 Stack_String : constant SA := new String'("stack");
190 Gnatstub_String : constant SA := new String'("gnatstub");
191 Metric_String : constant SA := new String'("metrics");
192 Xref_String : constant SA := new String'("cross_reference");
193
194 Packages_To_Check_By_Binder : constant String_List_Access :=
195 new String_List'((Naming_String, Binder_String));
196
197 Packages_To_Check_By_Check : constant String_List_Access :=
198 new String_List'
199 ((Naming_String, Builder_String, Check_String, Compiler_String));
200
201 Packages_To_Check_By_Sync : constant String_List_Access :=
202 new String_List'((Naming_String, Synchronize_String, Compiler_String));
203
204 Packages_To_Check_By_Eliminate : constant String_List_Access :=
205 new String_List'((Naming_String, Eliminate_String, Compiler_String));
206
207 Packages_To_Check_By_Finder : constant String_List_Access :=
208 new String_List'((Naming_String, Finder_String));
209
210 Packages_To_Check_By_Linker : constant String_List_Access :=
211 new String_List'((Naming_String, Linker_String));
212
213 Packages_To_Check_By_Gnatls : constant String_List_Access :=
214 new String_List'((Naming_String, Gnatls_String));
215
216 Packages_To_Check_By_Pretty : constant String_List_Access :=
217 new String_List'((Naming_String, Pretty_String, Compiler_String));
218
219 Packages_To_Check_By_Stack : constant String_List_Access :=
220 new String_List'((Naming_String, Stack_String));
221
222 Packages_To_Check_By_Gnatstub : constant String_List_Access :=
223 new String_List'((Naming_String, Gnatstub_String, Compiler_String));
224
225 Packages_To_Check_By_Metric : constant String_List_Access :=
226 new String_List'((Naming_String, Metric_String, Compiler_String));
227
228 Packages_To_Check_By_Xref : constant String_List_Access :=
229 new String_List'((Naming_String, Xref_String));
230
231 Packages_To_Check : String_List_Access := Prj.All_Packages;
232
233 ----------------------------------
234 -- Declarations for GNATCMD use --
235 ----------------------------------
236
237 The_Command : Command_Type;
238 -- The command specified in the invocation of the GNAT driver
239
240 Command_Arg : Positive := 1;
241 -- The index of the command in the arguments of the GNAT driver
242
243 My_Exit_Status : Exit_Status := Success;
244 -- The exit status of the spawned tool
245
246 Current_Work_Dir : constant String := Get_Current_Dir;
247 -- The path of the working directory
248
249 All_Projects : Boolean := False;
250 -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
251 -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
252 -- should be invoked for all sources of all projects.
253
254 type Command_Entry is record
255 Cname : String_Access;
256 -- Command name for GNAT xxx command
257
258 Unixcmd : String_Access;
259 -- Corresponding Unix command
260
261 Unixsws : Argument_List_Access;
262 -- List of switches to be used with the Unix command
263 end record;
264
265 Command_List : constant array (Real_Command_Type) of Command_Entry :=
266 (Bind =>
267 (Cname => new String'("BIND"),
268 Unixcmd => new String'("gnatbind"),
269 Unixsws => null),
270
271 Chop =>
272 (Cname => new String'("CHOP"),
273 Unixcmd => new String'("gnatchop"),
274 Unixsws => null),
275
276 Clean =>
277 (Cname => new String'("CLEAN"),
278 Unixcmd => new String'("gnatclean"),
279 Unixsws => null),
280
281 Compile =>
282 (Cname => new String'("COMPILE"),
283 Unixcmd => new String'("gnatmake"),
284 Unixsws => new Argument_List'(1 => new String'("-f"),
285 2 => new String'("-u"),
286 3 => new String'("-c"))),
287
288 Check =>
289 (Cname => new String'("CHECK"),
290 Unixcmd => new String'("gnatcheck"),
291 Unixsws => null),
292
293 Sync =>
294 (Cname => new String'("SYNC"),
295 Unixcmd => new String'("gnatsync"),
296 Unixsws => null),
297
298 Elim =>
299 (Cname => new String'("ELIM"),
300 Unixcmd => new String'("gnatelim"),
301 Unixsws => null),
302
303 Find =>
304 (Cname => new String'("FIND"),
305 Unixcmd => new String'("gnatfind"),
306 Unixsws => null),
307
308 Krunch =>
309 (Cname => new String'("KRUNCH"),
310 Unixcmd => new String'("gnatkr"),
311 Unixsws => null),
312
313 Link =>
314 (Cname => new String'("LINK"),
315 Unixcmd => new String'("gnatlink"),
316 Unixsws => null),
317
318 List =>
319 (Cname => new String'("LIST"),
320 Unixcmd => new String'("gnatls"),
321 Unixsws => null),
322
323 Make =>
324 (Cname => new String'("MAKE"),
325 Unixcmd => new String'("gnatmake"),
326 Unixsws => null),
327
328 Metric =>
329 (Cname => new String'("METRIC"),
330 Unixcmd => new String'("gnatmetric"),
331 Unixsws => null),
332
333 Name =>
334 (Cname => new String'("NAME"),
335 Unixcmd => new String'("gnatname"),
336 Unixsws => null),
337
338 Preprocess =>
339 (Cname => new String'("PREPROCESS"),
340 Unixcmd => new String'("gnatprep"),
341 Unixsws => null),
342
343 Pretty =>
344 (Cname => new String'("PRETTY"),
345 Unixcmd => new String'("gnatpp"),
346 Unixsws => null),
347
348 Stack =>
349 (Cname => new String'("STACK"),
350 Unixcmd => new String'("gnatstack"),
351 Unixsws => null),
352
353 Stub =>
354 (Cname => new String'("STUB"),
355 Unixcmd => new String'("gnatstub"),
356 Unixsws => null),
357
358 Test =>
359 (Cname => new String'("TEST"),
360 Unixcmd => new String'("gnattest"),
361 Unixsws => null),
362
363 Xref =>
364 (Cname => new String'("XREF"),
365 Unixcmd => new String'("gnatxref"),
366 Unixsws => null)
367 );
368
369 -----------------------
370 -- Local Subprograms --
371 -----------------------
372
373 procedure Add_To_Carg_Switches (Switch : String_Access);
374 -- Add a switch to the Carg_Switches table. If it is the first one, put the
375 -- switch "-cargs" at the beginning of the table.
376
377 procedure Add_To_Rules_Switches (Switch : String_Access);
378 -- Add a switch to the Rules_Switches table. If it is the first one, put
379 -- the switch "-crules" at the beginning of the table.
380
381 procedure Check_Files;
382 -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
383 -- project file is specified, without any file arguments and without a
384 -- switch -files=. If it is the case, invoke the GNAT tool with the proper
385 -- list of files, derived from the sources of the project.
386
387 function Check_Project
388 (Project : Project_Id;
389 Root_Project : Project_Id) return Boolean;
390 -- Returns True if Project = Root_Project or if we want to consider all
391 -- sources of all projects. For GNAT METRIC, also returns True if Project
392 -- is extended by Root_Project.
393
394 procedure Check_Relative_Executable (Name : in out String_Access);
395 -- Check if an executable is specified as a relative path. If it is, and
396 -- the path contains directory information, fail. Otherwise, prepend the
397 -- exec directory. This procedure is only used for GNAT LINK when a project
398 -- file is specified.
399
400 function Configuration_Pragmas_File return Path_Name_Type;
401 -- Return an argument, if there is a configuration pragmas file to be
402 -- specified for Project, otherwise return No_Name. Used for gnatstub
403 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
404 -- (GNAT METRIC).
405
406 procedure Delete_Temp_Config_Files;
407 -- Delete all temporary config files. The caller is responsible for
408 -- ensuring that Keep_Temporary_Files is False.
409
410 procedure Ensure_Absolute_Path
411 (Switch : in out String_Access;
412 Parent : String);
413 -- Test if Switch is a relative search path switch. If it is and it
414 -- includes directory information, prepend the path with Parent. This
415 -- subprogram is only called when using project files.
416
417 procedure Get_Closure;
418 -- Get the sources in the closure of the ASIS_Main and add them to the
419 -- list of arguments.
420
421 function Mapping_File return Path_Name_Type;
422 -- Create and return the path name of a mapping file. Used for gnatstub
423 -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
424 -- (GNAT METRIC).
425
426 procedure Output_Version;
427 -- Output the version of this program
428
429 procedure Usage;
430 -- Display usage
431
432 procedure Process_Link;
433 -- Process GNAT LINK, when there is a project file specified
434
435 procedure Set_Library_For
436 (Project : Project_Id;
437 Tree : Project_Tree_Ref;
438 Libraries_Present : in out Boolean);
439 -- If Project is a library project, add the correct -L and -l switches to
440 -- the linker invocation.
441
442 procedure Set_Libraries is new
443 For_Every_Project_Imported (Boolean, Set_Library_For);
444 -- Add the -L and -l switches to the linker for all the library projects
445
446 --------------------------
447 -- Add_To_Carg_Switches --
448 --------------------------
449
450 procedure Add_To_Carg_Switches (Switch : String_Access) is
451 begin
452 -- If the Carg_Switches table is empty, put "-cargs" at the beginning
453
454 if Carg_Switches.Last = 0 then
455 Carg_Switches.Increment_Last;
456 Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
457 end if;
458
459 Carg_Switches.Increment_Last;
460 Carg_Switches.Table (Carg_Switches.Last) := Switch;
461 end Add_To_Carg_Switches;
462
463 ---------------------------
464 -- Add_To_Rules_Switches --
465 ---------------------------
466
467 procedure Add_To_Rules_Switches (Switch : String_Access) is
468 begin
469 -- If the Rules_Switches table is empty, put "-rules" at the beginning
470
471 if Rules_Switches.Last = 0 then
472 Rules_Switches.Increment_Last;
473 Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
474 end if;
475
476 Rules_Switches.Increment_Last;
477 Rules_Switches.Table (Rules_Switches.Last) := Switch;
478 end Add_To_Rules_Switches;
479
480 -----------------
481 -- Check_Files --
482 -----------------
483
484 procedure Check_Files is
485 Add_Sources : Boolean := True;
486 Unit : Prj.Unit_Index;
487 Subunit : Boolean := False;
488 FD : File_Descriptor := Invalid_FD;
489 Status : Integer;
490 Success : Boolean;
491
492 procedure Add_To_Response_File
493 (File_Name : String;
494 Check_File : Boolean := True);
495 -- Include the file name passed as parameter in the response file for
496 -- the tool being called. If the response file can not be written then
497 -- the file name is passed in the parameter list of the tool. If the
498 -- Check_File parameter is True then the procedure verifies the
499 -- existence of the file before adding it to the response file.
500
501 --------------------------
502 -- Add_To_Response_File --
503 --------------------------
504
505 procedure Add_To_Response_File
506 (File_Name : String;
507 Check_File : Boolean := True)
508 is
509 begin
510 Name_Len := 0;
511
512 Add_Str_To_Name_Buffer (File_Name);
513
514 if not Check_File or else
515 Is_Regular_File (Name_Buffer (1 .. Name_Len))
516 then
517 if FD /= Invalid_FD then
518 Name_Len := Name_Len + 1;
519 Name_Buffer (Name_Len) := ASCII.LF;
520
521 Status := Write (FD, Name_Buffer (1)'Address, Name_Len);
522
523 if Status /= Name_Len then
524 Osint.Fail ("disk full");
525 end if;
526 else
527 Last_Switches.Increment_Last;
528 Last_Switches.Table (Last_Switches.Last) :=
529 new String'(File_Name);
530 end if;
531 end if;
532 end Add_To_Response_File;
533
534 -- Start of processing for Check_Files
535
536 begin
537 -- Check if there is at least one argument that is not a switch or if
538 -- there is a -files= switch.
539
540 for Index in 1 .. Last_Switches.Last loop
541 if Last_Switches.Table (Index).all'Length > 7
542 and then Last_Switches.Table (Index) (1 .. 7) = "-files="
543 then
544 Add_Sources := False;
545 exit;
546
547 elsif Last_Switches.Table (Index) (1) /= '-' then
548 if Index = 1
549 or else
550 (The_Command = Check
551 and then Last_Switches.Table (Index - 1).all /= "-o")
552 or else
553 (The_Command = Pretty
554 and then Last_Switches.Table (Index - 1).all /= "-o"
555 and then Last_Switches.Table (Index - 1).all /= "-of")
556 or else
557 (The_Command = Metric
558 and then
559 Last_Switches.Table (Index - 1).all /= "-o" and then
560 Last_Switches.Table (Index - 1).all /= "-og" and then
561 Last_Switches.Table (Index - 1).all /= "-ox" and then
562 Last_Switches.Table (Index - 1).all /= "-d")
563 or else
564 (The_Command /= Check and then
565 The_Command /= Pretty and then
566 The_Command /= Metric)
567 then
568 Add_Sources := False;
569 exit;
570 end if;
571 end if;
572 end loop;
573
574 -- If all arguments are switches and there is no switch -files=, add the
575 -- path names of all the sources of the main project.
576
577 if Add_Sources then
578
579 -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file and
580 -- put the list of sources in it. For gnatstack create a temporary
581 -- file with the list of .ci files.
582
583 if The_Command = Check or else
584 The_Command = Pretty or else
585 The_Command = Metric or else
586 The_Command = List or else
587 The_Command = Stack
588 then
589 Tempdir.Create_Temp_File (FD, Temp_File_Name);
590 Last_Switches.Increment_Last;
591 Last_Switches.Table (Last_Switches.Last) :=
592 new String'("-files=" & Get_Name_String (Temp_File_Name));
593 end if;
594
595 declare
596 Proj : Project_List;
597
598 begin
599 -- Gnatstack needs to add the .ci file for the binder generated
600 -- files corresponding to all of the library projects and main
601 -- units belonging to the application.
602
603 if The_Command = Stack then
604 Proj := Project_Tree.Projects;
605 while Proj /= null loop
606 if Check_Project (Proj.Project, Project) then
607 declare
608 Main : String_List_Id;
609
610 begin
611 -- Include binder generated files for main programs
612
613 Main := Proj.Project.Mains;
614 while Main /= Nil_String loop
615 Add_To_Response_File
616 (Get_Name_String
617 (Proj.Project.Object_Directory.Name) &
618 B_Start &
619 MLib.Fil.Ext_To
620 (Get_Name_String
621 (Project_Tree.Shared.String_Elements.Table
622 (Main).Value),
623 "ci"));
624
625 -- When looking for the .ci file for a binder
626 -- generated file, look for both b~xxx and b__xxx
627 -- as gprbuild always uses b__ as the prefix of
628 -- such files.
629
630 if not Is_Regular_File (Name_Buffer (1 .. Name_Len))
631 then
632 Add_To_Response_File
633 (Get_Name_String
634 (Proj.Project.Object_Directory.Name) &
635 "b__" &
636 MLib.Fil.Ext_To
637 (Get_Name_String
638 (Project_Tree.Shared
639 .String_Elements.Table (Main).Value),
640 "ci"));
641 end if;
642
643 Main := Project_Tree.Shared.String_Elements.Table
644 (Main).Next;
645 end loop;
646
647 if Proj.Project.Library then
648
649 -- Include the .ci file for the binder generated
650 -- files that contains the initialization and
651 -- finalization of the library.
652
653 Add_To_Response_File
654 (Get_Name_String
655 (Proj.Project.Object_Directory.Name) &
656 B_Start &
657 Get_Name_String (Proj.Project.Library_Name) &
658 ".ci");
659
660 -- When looking for the .ci file for a binder
661 -- generated file, look for both b~xxx and b__xxx
662 -- as gprbuild always uses b__ as the prefix of
663 -- such files.
664
665 if not Is_Regular_File (Name_Buffer (1 .. Name_Len))
666 then
667 Add_To_Response_File
668 (Get_Name_String
669 (Proj.Project.Object_Directory.Name) &
670 "b__" &
671 Get_Name_String (Proj.Project.Library_Name) &
672 ".ci");
673 end if;
674 end if;
675 end;
676 end if;
677
678 Proj := Proj.Next;
679 end loop;
680 end if;
681
682 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
683 while Unit /= No_Unit_Index loop
684
685 -- For gnatls, we only need to put the library units, body or
686 -- spec, but not the subunits.
687
688 if The_Command = List then
689 if Unit.File_Names (Impl) /= null
690 and then not Unit.File_Names (Impl).Locally_Removed
691 then
692 -- There is a body, check if it is for this project
693
694 if All_Projects
695 or else Unit.File_Names (Impl).Project = Project
696 then
697 Subunit := False;
698
699 if Unit.File_Names (Spec) = null
700 or else Unit.File_Names (Spec).Locally_Removed
701 then
702 -- We have a body with no spec: we need to check if
703 -- this is a subunit, because gnatls will complain
704 -- about subunits.
705
706 declare
707 Src_Ind : constant Source_File_Index :=
708 Sinput.P.Load_Project_File
709 (Get_Name_String
710 (Unit.File_Names
711 (Impl).Path.Name));
712 begin
713 Subunit :=
714 Sinput.P.Source_File_Is_Subunit (Src_Ind);
715 end;
716 end if;
717
718 if not Subunit then
719 Add_To_Response_File
720 (Get_Name_String
721 (Unit.File_Names (Impl).Display_File),
722 Check_File => False);
723 end if;
724 end if;
725
726 elsif Unit.File_Names (Spec) /= null
727 and then not Unit.File_Names (Spec).Locally_Removed
728 then
729 -- We have a spec with no body. Check if it is for this
730 -- project.
731
732 if All_Projects or else
733 Unit.File_Names (Spec).Project = Project
734 then
735 Add_To_Response_File
736 (Get_Name_String
737 (Unit.File_Names (Spec).Display_File),
738 Check_File => False);
739 end if;
740 end if;
741
742 -- For gnatstack, we put the .ci files corresponding to the
743 -- different units, including the binder generated files. We
744 -- only need to do that for the library units, body or spec,
745 -- but not the subunits.
746
747 elsif The_Command = Stack then
748 if Unit.File_Names (Impl) /= null
749 and then not Unit.File_Names (Impl).Locally_Removed
750 then
751 -- There is a body. Check if .ci files for this project
752 -- must be added.
753
754 if Check_Project
755 (Unit.File_Names (Impl).Project, Project)
756 then
757 Subunit := False;
758
759 if Unit.File_Names (Spec) = null
760 or else Unit.File_Names (Spec).Locally_Removed
761 then
762 -- We have a body with no spec: we need to check
763 -- if this is a subunit, because .ci files are not
764 -- generated for subunits.
765
766 declare
767 Src_Ind : constant Source_File_Index :=
768 Sinput.P.Load_Project_File
769 (Get_Name_String
770 (Unit.File_Names
771 (Impl).Path.Name));
772 begin
773 Subunit :=
774 Sinput.P.Source_File_Is_Subunit (Src_Ind);
775 end;
776 end if;
777
778 if not Subunit then
779 Add_To_Response_File
780 (Get_Name_String
781 (Unit.File_Names
782 (Impl).Project. Object_Directory.Name) &
783 MLib.Fil.Ext_To
784 (Get_Name_String
785 (Unit.File_Names (Impl).Display_File),
786 "ci"));
787 end if;
788 end if;
789
790 elsif Unit.File_Names (Spec) /= null
791 and then not Unit.File_Names (Spec).Locally_Removed
792 then
793 -- Spec with no body, check if it is for this project
794
795 if Check_Project
796 (Unit.File_Names (Spec).Project, Project)
797 then
798 Add_To_Response_File
799 (Get_Name_String
800 (Unit.File_Names
801 (Spec).Project. Object_Directory.Name) &
802 Dir_Separator &
803 MLib.Fil.Ext_To
804 (Get_Name_String (Unit.File_Names (Spec).File),
805 "ci"));
806 end if;
807 end if;
808
809 else
810 -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
811 -- sources of the project, or of all projects if -U was
812 -- specified.
813
814 for Kind in Spec_Or_Body loop
815 if Unit.File_Names (Kind) /= null
816 and then Check_Project
817 (Unit.File_Names (Kind).Project, Project)
818 and then not Unit.File_Names (Kind).Locally_Removed
819 then
820 Add_To_Response_File
821 ("""" &
822 Get_Name_String
823 (Unit.File_Names (Kind).Path.Display_Name) &
824 """",
825 Check_File => False);
826 end if;
827 end loop;
828 end if;
829
830 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
831 end loop;
832 end;
833
834 if FD /= Invalid_FD then
835 Close (FD, Success);
836
837 if not Success then
838 Osint.Fail ("disk full");
839 end if;
840 end if;
841 end if;
842 end Check_Files;
843
844 -------------------
845 -- Check_Project --
846 -------------------
847
848 function Check_Project
849 (Project : Project_Id;
850 Root_Project : Project_Id) return Boolean
851 is
852 Proj : Project_Id;
853
854 begin
855 if Project = No_Project then
856 return False;
857
858 elsif All_Projects or else Project = Root_Project then
859 return True;
860
861 elsif The_Command = Metric then
862 Proj := Root_Project;
863 while Proj.Extends /= No_Project loop
864 if Project = Proj.Extends then
865 return True;
866 end if;
867
868 Proj := Proj.Extends;
869 end loop;
870 end if;
871
872 return False;
873 end Check_Project;
874
875 -------------------------------
876 -- Check_Relative_Executable --
877 -------------------------------
878
879 procedure Check_Relative_Executable (Name : in out String_Access) is
880 Exec_File_Name : constant String := Name.all;
881
882 begin
883 if not Is_Absolute_Path (Exec_File_Name) then
884 for Index in Exec_File_Name'Range loop
885 if Exec_File_Name (Index) = Directory_Separator then
886 Fail ("relative executable (""" &
887 Exec_File_Name &
888 """) with directory part not allowed " &
889 "when using project files");
890 end if;
891 end loop;
892
893 Get_Name_String (Project.Exec_Directory.Name);
894
895 if Name_Buffer (Name_Len) /= Directory_Separator then
896 Name_Len := Name_Len + 1;
897 Name_Buffer (Name_Len) := Directory_Separator;
898 end if;
899
900 Name_Buffer (Name_Len + 1 ..
901 Name_Len + Exec_File_Name'Length) :=
902 Exec_File_Name;
903 Name_Len := Name_Len + Exec_File_Name'Length;
904 Name := new String'(Name_Buffer (1 .. Name_Len));
905 end if;
906 end Check_Relative_Executable;
907
908 --------------------------------
909 -- Configuration_Pragmas_File --
910 --------------------------------
911
912 function Configuration_Pragmas_File return Path_Name_Type is
913 begin
914 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
915 return Project.Config_File_Name;
916 end Configuration_Pragmas_File;
917
918 ------------------------------
919 -- Delete_Temp_Config_Files --
920 ------------------------------
921
922 procedure Delete_Temp_Config_Files is
923 Success : Boolean;
924 Proj : Project_List;
925 pragma Warnings (Off, Success);
926
927 begin
928 -- This should only be called if Keep_Temporary_Files is False
929
930 pragma Assert (not Keep_Temporary_Files);
931
932 if Project /= No_Project then
933 Proj := Project_Tree.Projects;
934 while Proj /= null loop
935 if Proj.Project.Config_File_Temp then
936 Delete_Temporary_File
937 (Project_Tree.Shared, Proj.Project.Config_File_Name);
938 end if;
939
940 Proj := Proj.Next;
941 end loop;
942 end if;
943
944 -- If a temporary text file that contains a list of files for a tool
945 -- has been created, delete this temporary file.
946
947 if Temp_File_Name /= No_Path then
948 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
949 end if;
950 end Delete_Temp_Config_Files;
951
952 ---------------------------
953 -- Ensure_Absolute_Path --
954 ---------------------------
955
956 procedure Ensure_Absolute_Path
957 (Switch : in out String_Access;
958 Parent : String)
959 is
960 begin
961 Makeutl.Ensure_Absolute_Path
962 (Switch, Parent,
963 Do_Fail => Osint.Fail'Access,
964 Including_Non_Switch => False,
965 Including_RTS => True);
966 end Ensure_Absolute_Path;
967
968 -----------------
969 -- Get_Closure --
970 -----------------
971
972 procedure Get_Closure is
973 Args : constant Argument_List :=
974 (1 => new String'("-q"),
975 2 => new String'("-b"),
976 3 => new String'("-P"),
977 4 => Project_File,
978 5 => ASIS_Main,
979 6 => new String'("-bargs"),
980 7 => new String'("-R"),
981 8 => new String'("-Z"));
982 -- Arguments for the invocation of gnatmake which are added to the
983 -- Last_Arguments list by this procedure.
984
985 FD : File_Descriptor;
986 -- File descriptor for the temp file that will get the output of the
987 -- invocation of gnatmake.
988
989 Name : Path_Name_Type;
990 -- Path of the file FD
991
992 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
993 -- Name for gnatmake
994
995 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
996 -- Path of gnatmake
997
998 Return_Code : Integer;
999
1000 Unused : Boolean;
1001 pragma Warnings (Off, Unused);
1002
1003 File : Ada.Text_IO.File_Type;
1004 Line : String (1 .. 250);
1005 Last : Natural;
1006 -- Used to read file if there is an error, it is good enough to display
1007 -- just 250 characters if the first line of the file is very long.
1008
1009 Unit : Unit_Index;
1010 Path : Path_Name_Type;
1011
1012 Files_File : Ada.Text_IO.File_Type;
1013 Temp_File_Name : Path_Name_Type;
1014
1015 begin
1016 if GN_Path = null then
1017 Put_Line (Standard_Error, "could not locate " & GN_Name);
1018 raise Error_Exit;
1019 end if;
1020
1021 -- Create the temp file
1022
1023 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
1024
1025 -- And close it
1026
1027 Close (FD);
1028
1029 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
1030
1031 Spawn
1032 (Program_Name => GN_Path.all,
1033 Args => Args,
1034 Output_File => Get_Name_String (Name),
1035 Success => Unused,
1036 Return_Code => Return_Code,
1037 Err_To_Out => True);
1038
1039 -- Read the output of the invocation of gnatmake
1040
1041 Open (File, In_File, Get_Name_String (Name));
1042
1043 -- If it was unsuccessful, display the first line in the file and exit
1044 -- with error.
1045
1046 if Return_Code /= 0 then
1047 Get_Line (File, Line, Last);
1048
1049 begin
1050 if not Keep_Temporary_Files then
1051 Delete (File);
1052 else
1053 Close (File);
1054 end if;
1055
1056 -- Don't crash if it is not possible to delete or close the file,
1057 -- just ignore the situation.
1058
1059 exception
1060 when others =>
1061 null;
1062 end;
1063
1064 Put_Line (Standard_Error, Line (1 .. Last));
1065 Put_Line
1066 (Standard_Error, "could not get closure of " & ASIS_Main.all);
1067 raise Error_Exit;
1068
1069 else
1070 -- Create a temporary file to put the list of files in the closure
1071
1072 Tempdir.Create_Temp_File (FD, Temp_File_Name);
1073 Last_Switches.Increment_Last;
1074 Last_Switches.Table (Last_Switches.Last) :=
1075 new String'("-files=" & Get_Name_String (Temp_File_Name));
1076
1077 Close (FD);
1078
1079 Open (Files_File, Out_File, Get_Name_String (Temp_File_Name));
1080
1081 -- Get each file name in the file, find its path and add it the list
1082 -- of arguments.
1083
1084 while not End_Of_File (File) loop
1085 Get_Line (File, Line, Last);
1086 Path := No_Path;
1087
1088 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
1089 while Unit /= No_Unit_Index loop
1090 if Unit.File_Names (Spec) /= null
1091 and then
1092 Get_Name_String (Unit.File_Names (Spec).File) =
1093 Line (1 .. Last)
1094 then
1095 Path := Unit.File_Names (Spec).Path.Name;
1096 exit;
1097
1098 elsif Unit.File_Names (Impl) /= null
1099 and then
1100 Get_Name_String (Unit.File_Names (Impl).File) =
1101 Line (1 .. Last)
1102 then
1103 Path := Unit.File_Names (Impl).Path.Name;
1104 exit;
1105 end if;
1106
1107 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
1108 end loop;
1109
1110 if Path /= No_Path then
1111 Put_Line (Files_File, Get_Name_String (Path));
1112
1113 else
1114 Put_Line (Files_File, Line (1 .. Last));
1115 end if;
1116 end loop;
1117
1118 Close (Files_File);
1119
1120 begin
1121 if not Keep_Temporary_Files then
1122 Delete (File);
1123 else
1124 Close (File);
1125 end if;
1126
1127 -- Don't crash if it is not possible to delete or close the file,
1128 -- just ignore the situation.
1129
1130 exception
1131 when others =>
1132 null;
1133 end;
1134 end if;
1135 end Get_Closure;
1136
1137 ------------------
1138 -- Mapping_File --
1139 ------------------
1140
1141 function Mapping_File return Path_Name_Type is
1142 Result : Path_Name_Type;
1143 begin
1144 Prj.Env.Create_Mapping_File
1145 (Project => Project,
1146 Language => Name_Ada,
1147 In_Tree => Project_Tree,
1148 Name => Result);
1149 return Result;
1150 end Mapping_File;
1151
1152 --------------------
1153 -- Output_Version --
1154 --------------------
1155
1156 procedure Output_Version is
1157 begin
1158 if AAMP_On_Target then
1159 Put ("GNAAMP ");
1160 else
1161 Put ("GNAT ");
1162 end if;
1163
1164 Put_Line (Gnatvsn.Gnat_Version_String);
1165 Put_Line ("Copyright 1996-" &
1166 Gnatvsn.Current_Year &
1167 ", Free Software Foundation, Inc.");
1168 end Output_Version;
1169
1170 -----------
1171 -- Usage --
1172 -----------
1173
1174 procedure Usage is
1175 begin
1176 Output_Version;
1177 New_Line;
1178 Put_Line ("List of available commands");
1179 New_Line;
1180
1181 for C in Command_List'Range loop
1182
1183 -- No usage for Sync
1184
1185 if C /= Sync then
1186 if Targparm.AAMP_On_Target then
1187 Put ("gnaampcmd ");
1188 else
1189 Put ("gnat ");
1190 end if;
1191
1192 Put (To_Lower (Command_List (C).Cname.all));
1193 Set_Col (25);
1194
1195 -- Never call gnatstack with a prefix
1196
1197 if C = Stack then
1198 Put (Command_List (C).Unixcmd.all);
1199 else
1200 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
1201 end if;
1202
1203 declare
1204 Sws : Argument_List_Access renames Command_List (C).Unixsws;
1205 begin
1206 if Sws /= null then
1207 for J in Sws'Range loop
1208 Put (' ');
1209 Put (Sws (J).all);
1210 end loop;
1211 end if;
1212 end;
1213
1214 New_Line;
1215 end if;
1216 end loop;
1217
1218 New_Line;
1219 Put_Line ("All commands except chop, krunch and preprocess " &
1220 "accept project file switches -vPx, -Pprj and -Xnam=val");
1221 New_Line;
1222 end Usage;
1223
1224 ------------------
1225 -- Process_Link --
1226 ------------------
1227
1228 procedure Process_Link is
1229 Look_For_Executable : Boolean := True;
1230 Libraries_Present : Boolean := False;
1231 Path_Option : constant String_Access :=
1232 MLib.Linker_Library_Path_Option;
1233 Prj : Project_Id := Project;
1234 Arg : String_Access;
1235 Last : Natural := 0;
1236 Skip_Executable : Boolean := False;
1237
1238 begin
1239 -- Add the default search directories, to be able to find
1240 -- libgnat in call to MLib.Utl.Lib_Directory.
1241
1242 Add_Default_Search_Dirs;
1243
1244 Library_Paths.Set_Last (0);
1245
1246 -- Check if there are library project files
1247
1248 if MLib.Tgt.Support_For_Libraries /= None then
1249 Set_Libraries (Project, Project_Tree, Libraries_Present);
1250 end if;
1251
1252 -- If there are, add the necessary additional switches
1253
1254 if Libraries_Present then
1255
1256 -- Add -Wl,-rpath,<lib_dir>
1257
1258 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
1259 -- equivalent) with all the library dirs plus the standard GNAT
1260 -- library dir.
1261
1262 if Path_Option /= null then
1263 declare
1264 Option : String_Access;
1265 Length : Natural := Path_Option'Length;
1266 Current : Natural;
1267
1268 begin
1269 if MLib.Separate_Run_Path_Options then
1270
1271 -- We are going to create one switch of the form
1272 -- "-Wl,-rpath,dir_N" for each directory to consider.
1273
1274 -- One switch for each library directory
1275
1276 for Index in
1277 Library_Paths.First .. Library_Paths.Last
1278 loop
1279 Last_Switches.Increment_Last;
1280 Last_Switches.Table
1281 (Last_Switches.Last) := new String'
1282 (Path_Option.all &
1283 Last_Switches.Table (Index).all);
1284 end loop;
1285
1286 -- One switch for the standard GNAT library dir
1287
1288 Last_Switches.Increment_Last;
1289 Last_Switches.Table
1290 (Last_Switches.Last) := new String'
1291 (Path_Option.all & MLib.Utl.Lib_Directory);
1292
1293 else
1294 -- First, compute the exact length for the switch
1295
1296 for Index in
1297 Library_Paths.First .. Library_Paths.Last
1298 loop
1299 -- Add the length of the library dir plus one for the
1300 -- directory separator.
1301
1302 Length :=
1303 Length +
1304 Library_Paths.Table (Index)'Length + 1;
1305 end loop;
1306
1307 -- Finally, add the length of the standard GNAT library dir
1308
1309 Length := Length + MLib.Utl.Lib_Directory'Length;
1310 Option := new String (1 .. Length);
1311 Option (1 .. Path_Option'Length) := Path_Option.all;
1312 Current := Path_Option'Length;
1313
1314 -- Put each library dir followed by a dir separator
1315
1316 for Index in
1317 Library_Paths.First .. Library_Paths.Last
1318 loop
1319 Option
1320 (Current + 1 ..
1321 Current +
1322 Library_Paths.Table (Index)'Length) :=
1323 Library_Paths.Table (Index).all;
1324 Current :=
1325 Current +
1326 Library_Paths.Table (Index)'Length + 1;
1327 Option (Current) := Path_Separator;
1328 end loop;
1329
1330 -- Finally put the standard GNAT library dir
1331
1332 Option
1333 (Current + 1 ..
1334 Current + MLib.Utl.Lib_Directory'Length) :=
1335 MLib.Utl.Lib_Directory;
1336
1337 -- And add the switch to the last switches
1338
1339 Last_Switches.Increment_Last;
1340 Last_Switches.Table (Last_Switches.Last) :=
1341 Option;
1342 end if;
1343 end;
1344 end if;
1345 end if;
1346
1347 -- Check if the first ALI file specified can be found, either in the
1348 -- object directory of the main project or in an object directory of a
1349 -- project file extended by the main project. If the ALI file can be
1350 -- found, replace its name with its absolute path.
1351
1352 Skip_Executable := False;
1353
1354 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1355
1356 -- If we have an executable just reset the flag
1357
1358 if Skip_Executable then
1359 Skip_Executable := False;
1360
1361 -- If -o, set flag so that next switch is not processed
1362
1363 elsif Last_Switches.Table (J).all = "-o" then
1364 Skip_Executable := True;
1365
1366 -- Normal case
1367
1368 else
1369 declare
1370 Switch : constant String :=
1371 Last_Switches.Table (J).all;
1372 ALI_File : constant String (1 .. Switch'Length + 4) :=
1373 Switch & ".ali";
1374
1375 Test_Existence : Boolean := False;
1376
1377 begin
1378 Last := Switch'Length;
1379
1380 -- Skip real switches
1381
1382 if Switch'Length /= 0
1383 and then Switch (Switch'First) /= '-'
1384 then
1385 -- Append ".ali" if file name does not end with it
1386
1387 if Switch'Length <= 4
1388 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1389 then
1390 Last := ALI_File'Last;
1391 end if;
1392
1393 -- If file name includes directory information, stop if ALI
1394 -- file exists.
1395
1396 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1397 Test_Existence := True;
1398
1399 else
1400 for K in Switch'Range loop
1401 if Switch (K) = '/'
1402 or else Switch (K) = Directory_Separator
1403 then
1404 Test_Existence := True;
1405 exit;
1406 end if;
1407 end loop;
1408 end if;
1409
1410 if Test_Existence then
1411 if Is_Regular_File (ALI_File (1 .. Last)) then
1412 exit Switch_Loop;
1413 end if;
1414
1415 -- Look in object directories if ALI file exists
1416
1417 else
1418 Project_Loop : loop
1419 declare
1420 Dir : constant String :=
1421 Get_Name_String (Prj.Object_Directory.Name);
1422 begin
1423 if Is_Regular_File
1424 (Dir &
1425 ALI_File (1 .. Last))
1426 then
1427 -- We have found the correct project, so we
1428 -- replace the file with the absolute path.
1429
1430 Last_Switches.Table (J) :=
1431 new String'(Dir & ALI_File (1 .. Last));
1432
1433 -- And we are done
1434
1435 exit Switch_Loop;
1436 end if;
1437 end;
1438
1439 -- Go to the project being extended, if any
1440
1441 Prj := Prj.Extends;
1442 exit Project_Loop when Prj = No_Project;
1443 end loop Project_Loop;
1444 end if;
1445 end if;
1446 end;
1447 end if;
1448 end loop Switch_Loop;
1449
1450 -- If a relative path output file has been specified, we add the exec
1451 -- directory.
1452
1453 for J in reverse 1 .. Last_Switches.Last - 1 loop
1454 if Last_Switches.Table (J).all = "-o" then
1455 Check_Relative_Executable
1456 (Name => Last_Switches.Table (J + 1));
1457 Look_For_Executable := False;
1458 exit;
1459 end if;
1460 end loop;
1461
1462 if Look_For_Executable then
1463 for J in reverse 1 .. First_Switches.Last - 1 loop
1464 if First_Switches.Table (J).all = "-o" then
1465 Look_For_Executable := False;
1466 Check_Relative_Executable
1467 (Name => First_Switches.Table (J + 1));
1468 exit;
1469 end if;
1470 end loop;
1471 end if;
1472
1473 -- If no executable is specified, then find the name of the first ALI
1474 -- file on the command line and issue a -o switch with the absolute path
1475 -- of the executable in the exec directory.
1476
1477 if Look_For_Executable then
1478 for J in 1 .. Last_Switches.Last loop
1479 Arg := Last_Switches.Table (J);
1480 Last := 0;
1481
1482 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
1483 if Arg'Length > 4
1484 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
1485 then
1486 Last := Arg'Last - 4;
1487
1488 elsif Is_Regular_File (Arg.all & ".ali") then
1489 Last := Arg'Last;
1490 end if;
1491
1492 if Last /= 0 then
1493 Last_Switches.Increment_Last;
1494 Last_Switches.Table (Last_Switches.Last) :=
1495 new String'("-o");
1496 Get_Name_String (Project.Exec_Directory.Name);
1497 Last_Switches.Increment_Last;
1498 Last_Switches.Table (Last_Switches.Last) :=
1499 new String'(Name_Buffer (1 .. Name_Len) &
1500 Executable_Name
1501 (Base_Name (Arg (Arg'First .. Last))));
1502 exit;
1503 end if;
1504 end if;
1505 end loop;
1506 end if;
1507 end Process_Link;
1508
1509 ---------------------
1510 -- Set_Library_For --
1511 ---------------------
1512
1513 procedure Set_Library_For
1514 (Project : Project_Id;
1515 Tree : Project_Tree_Ref;
1516 Libraries_Present : in out Boolean)
1517 is
1518 pragma Unreferenced (Tree);
1519
1520 Path_Option : constant String_Access :=
1521 MLib.Linker_Library_Path_Option;
1522
1523 begin
1524 -- Case of library project
1525
1526 if Project.Library then
1527 Libraries_Present := True;
1528
1529 -- Add the -L switch
1530
1531 Last_Switches.Increment_Last;
1532 Last_Switches.Table (Last_Switches.Last) :=
1533 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1534
1535 -- Add the -l switch
1536
1537 Last_Switches.Increment_Last;
1538 Last_Switches.Table (Last_Switches.Last) :=
1539 new String'("-l" & Get_Name_String (Project.Library_Name));
1540
1541 -- Add the directory to table Library_Paths, to be processed later
1542 -- if library is not static and if Path_Option is not null.
1543
1544 if Project.Library_Kind /= Static
1545 and then Path_Option /= null
1546 then
1547 Library_Paths.Increment_Last;
1548 Library_Paths.Table (Library_Paths.Last) :=
1549 new String'(Get_Name_String (Project.Library_Dir.Name));
1550 end if;
1551 end if;
1552 end Set_Library_For;
1553
1554 procedure Check_Version_And_Help is
1555 new Check_Version_And_Help_G (Usage);
1556
1557 -- Start of processing for GNATCmd
1558
1559 begin
1560 -- All output from GNATCmd is debugging or error output: send to stderr
1561
1562 Set_Standard_Error;
1563
1564 -- Initializations
1565
1566 Csets.Initialize;
1567 Snames.Initialize;
1568 Stringt.Initialize;
1569
1570 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1571
1572 Project_Node_Tree := new Project_Node_Tree_Data;
1573 Prj.Tree.Initialize (Project_Node_Tree);
1574
1575 Prj.Initialize (Project_Tree);
1576
1577 Last_Switches.Init;
1578 Last_Switches.Set_Last (0);
1579
1580 First_Switches.Init;
1581 First_Switches.Set_Last (0);
1582 Carg_Switches.Init;
1583 Carg_Switches.Set_Last (0);
1584 Rules_Switches.Init;
1585 Rules_Switches.Set_Last (0);
1586
1587 -- Set AAMP_On_Target from command name, for testing in Osint.Program_Name
1588 -- to handle the mapping of GNAAMP tool names. We don't extract it from
1589 -- system.ads, as there may be no default runtime.
1590
1591 Find_Program_Name;
1592 AAMP_On_Target := Name_Buffer (1 .. Name_Len) = "gnaampcmd";
1593
1594 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1595 -- so that the spawned tool may know the way the GNAT driver was invoked.
1596
1597 Name_Len := 0;
1598 Add_Str_To_Name_Buffer (Command_Name);
1599
1600 for J in 1 .. Argument_Count loop
1601 Add_Char_To_Name_Buffer (' ');
1602 Add_Str_To_Name_Buffer (Argument (J));
1603 end loop;
1604
1605 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1606
1607 -- Add the directory where the GNAT driver is invoked in front of the path,
1608 -- if the GNAT driver is invoked with directory information.
1609
1610 declare
1611 Command : constant String := Command_Name;
1612
1613 begin
1614 for Index in reverse Command'Range loop
1615 if Command (Index) = Directory_Separator then
1616 declare
1617 Absolute_Dir : constant String :=
1618 Normalize_Pathname
1619 (Command (Command'First .. Index));
1620
1621 PATH : constant String :=
1622 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1623
1624 begin
1625 Setenv ("PATH", PATH);
1626 end;
1627
1628 exit;
1629 end if;
1630 end loop;
1631 end;
1632
1633 -- Scan the command line
1634
1635 -- First, scan to detect --version and/or --help
1636
1637 Check_Version_And_Help ("GNAT", "1996");
1638
1639 begin
1640 loop
1641 if Command_Arg <= Argument_Count
1642 and then Argument (Command_Arg) = "-v"
1643 then
1644 Verbose_Mode := True;
1645 Command_Arg := Command_Arg + 1;
1646
1647 elsif Command_Arg <= Argument_Count
1648 and then Argument (Command_Arg) = "-dn"
1649 then
1650 Keep_Temporary_Files := True;
1651 Command_Arg := Command_Arg + 1;
1652
1653 else
1654 exit;
1655 end if;
1656 end loop;
1657
1658 -- If there is no command, just output the usage
1659
1660 if Command_Arg > Argument_Count then
1661 Usage;
1662 return;
1663 end if;
1664
1665 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1666
1667 exception
1668 when Constraint_Error =>
1669
1670 -- Check if it is an alternate command
1671
1672 declare
1673 Alternate : Alternate_Command;
1674
1675 begin
1676 Alternate := Alternate_Command'Value
1677 (Argument (Command_Arg));
1678 The_Command := Corresponding_To (Alternate);
1679
1680 exception
1681 when Constraint_Error =>
1682 Usage;
1683 Fail ("unknown command: " & Argument (Command_Arg));
1684 end;
1685 end;
1686
1687 -- Get the arguments from the command line and from the eventual
1688 -- argument file(s) specified on the command line.
1689
1690 for Arg in Command_Arg + 1 .. Argument_Count loop
1691 declare
1692 The_Arg : constant String := Argument (Arg);
1693
1694 begin
1695 -- Check if an argument file is specified
1696
1697 if The_Arg (The_Arg'First) = '@' then
1698 declare
1699 Arg_File : Ada.Text_IO.File_Type;
1700 Line : String (1 .. 256);
1701 Last : Natural;
1702
1703 begin
1704 -- Open the file and fail if the file cannot be found
1705
1706 begin
1707 Open
1708 (Arg_File, In_File,
1709 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1710
1711 exception
1712 when others =>
1713 Put (Standard_Error, "Cannot open argument file """);
1714 Put (Standard_Error,
1715 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1716 Put_Line (Standard_Error, """");
1717 raise Error_Exit;
1718 end;
1719
1720 -- Read line by line and put the content of each non-
1721 -- empty line in the Last_Switches table.
1722
1723 while not End_Of_File (Arg_File) loop
1724 Get_Line (Arg_File, Line, Last);
1725
1726 if Last /= 0 then
1727 Last_Switches.Increment_Last;
1728 Last_Switches.Table (Last_Switches.Last) :=
1729 new String'(Line (1 .. Last));
1730 end if;
1731 end loop;
1732
1733 Close (Arg_File);
1734 end;
1735
1736 else
1737 -- It is not an argument file; just put the argument in
1738 -- the Last_Switches table.
1739
1740 Last_Switches.Increment_Last;
1741 Last_Switches.Table (Last_Switches.Last) :=
1742 new String'(The_Arg);
1743 end if;
1744 end;
1745 end loop;
1746
1747 declare
1748 Program : String_Access;
1749 Exec_Path : String_Access;
1750
1751 begin
1752 if The_Command = Stack then
1753
1754 -- Never call gnatstack with a prefix
1755
1756 Program := new String'(Command_List (The_Command).Unixcmd.all);
1757
1758 else
1759 Program :=
1760 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1761 end if;
1762
1763 -- For the tools where the GNAT driver processes the project files,
1764 -- allow shared library projects to import projects that are not shared
1765 -- library projects, to avoid adding a switch for these tools. For the
1766 -- builder (gnatmake), if a shared library project imports a project
1767 -- that is not a shared library project and the appropriate switch is
1768 -- not specified, the invocation of gnatmake will fail.
1769
1770 Opt.Unchecked_Shared_Lib_Imports := True;
1771
1772 -- Locate the executable for the command
1773
1774 Exec_Path := Locate_Exec_On_Path (Program.all);
1775
1776 if Exec_Path = null then
1777 Put_Line (Standard_Error, "could not locate " & Program.all);
1778 raise Error_Exit;
1779 end if;
1780
1781 -- If there are switches for the executable, put them as first switches
1782
1783 if Command_List (The_Command).Unixsws /= null then
1784 for J in Command_List (The_Command).Unixsws'Range loop
1785 First_Switches.Increment_Last;
1786 First_Switches.Table (First_Switches.Last) :=
1787 Command_List (The_Command).Unixsws (J);
1788 end loop;
1789 end if;
1790
1791 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1792 -- SYNC and XREF, look for project file related switches.
1793
1794 case The_Command is
1795 when Bind =>
1796 Tool_Package_Name := Name_Binder;
1797 Packages_To_Check := Packages_To_Check_By_Binder;
1798 when Check =>
1799 Tool_Package_Name := Name_Check;
1800 Packages_To_Check := Packages_To_Check_By_Check;
1801 when Elim =>
1802 Tool_Package_Name := Name_Eliminate;
1803 Packages_To_Check := Packages_To_Check_By_Eliminate;
1804 when Find =>
1805 Tool_Package_Name := Name_Finder;
1806 Packages_To_Check := Packages_To_Check_By_Finder;
1807 when Link =>
1808 Tool_Package_Name := Name_Linker;
1809 Packages_To_Check := Packages_To_Check_By_Linker;
1810 when List =>
1811 Tool_Package_Name := Name_Gnatls;
1812 Packages_To_Check := Packages_To_Check_By_Gnatls;
1813 when Metric =>
1814 Tool_Package_Name := Name_Metrics;
1815 Packages_To_Check := Packages_To_Check_By_Metric;
1816 when Pretty =>
1817 Tool_Package_Name := Name_Pretty_Printer;
1818 Packages_To_Check := Packages_To_Check_By_Pretty;
1819 when Stack =>
1820 Tool_Package_Name := Name_Stack;
1821 Packages_To_Check := Packages_To_Check_By_Stack;
1822 when Stub =>
1823 Tool_Package_Name := Name_Gnatstub;
1824 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1825 when Sync =>
1826 Tool_Package_Name := Name_Synchronize;
1827 Packages_To_Check := Packages_To_Check_By_Sync;
1828 when Xref =>
1829 Tool_Package_Name := Name_Cross_Reference;
1830 Packages_To_Check := Packages_To_Check_By_Xref;
1831 when others =>
1832 Tool_Package_Name := No_Name;
1833 end case;
1834
1835 if Tool_Package_Name /= No_Name then
1836
1837 -- Check that the switches are consistent. Detect project file
1838 -- related switches.
1839
1840 Inspect_Switches : declare
1841 Arg_Num : Positive := 1;
1842 Argv : String_Access;
1843
1844 procedure Remove_Switch (Num : Positive);
1845 -- Remove a project related switch from table Last_Switches
1846
1847 -------------------
1848 -- Remove_Switch --
1849 -------------------
1850
1851 procedure Remove_Switch (Num : Positive) is
1852 begin
1853 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1854 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1855 Last_Switches.Decrement_Last;
1856 end Remove_Switch;
1857
1858 -- Start of processing for Inspect_Switches
1859
1860 begin
1861 while Arg_Num <= Last_Switches.Last loop
1862 Argv := Last_Switches.Table (Arg_Num);
1863
1864 if Argv (Argv'First) = '-' then
1865 if Argv'Length = 1 then
1866 Fail
1867 ("switch character cannot be followed by a blank");
1868 end if;
1869
1870 -- The two style project files (-p and -P) cannot be used
1871 -- together
1872
1873 if (The_Command = Find or else The_Command = Xref)
1874 and then Argv (2) = 'p'
1875 then
1876 Old_Project_File_Used := True;
1877 if Project_File /= null then
1878 Fail ("-P and -p cannot be used together");
1879 end if;
1880 end if;
1881
1882 -- --subdirs=... Specify Subdirs
1883
1884 if Argv'Length > Makeutl.Subdirs_Option'Length
1885 and then
1886 Argv
1887 (Argv'First ..
1888 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1889 Makeutl.Subdirs_Option
1890 then
1891 Subdirs :=
1892 new String'
1893 (Argv
1894 (Argv'First + Makeutl.Subdirs_Option'Length ..
1895 Argv'Last));
1896
1897 Remove_Switch (Arg_Num);
1898
1899 -- -aPdir Add dir to the project search path
1900
1901 elsif Argv'Length > 3
1902 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
1903 then
1904 Prj.Env.Add_Directories
1905 (Root_Environment.Project_Path,
1906 Argv (Argv'First + 3 .. Argv'Last));
1907
1908 -- Pass -aPdir to gnatls, but not to other tools
1909
1910 if The_Command = List then
1911 Arg_Num := Arg_Num + 1;
1912 else
1913 Remove_Switch (Arg_Num);
1914 end if;
1915
1916 -- -eL Follow links for files
1917
1918 elsif Argv.all = "-eL" then
1919 Follow_Links_For_Files := True;
1920 Follow_Links_For_Dirs := True;
1921
1922 Remove_Switch (Arg_Num);
1923
1924 -- -vPx Specify verbosity while parsing project files
1925
1926 elsif Argv'Length >= 3
1927 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1928 then
1929 if Argv'Length = 4
1930 and then Argv (Argv'Last) in '0' .. '2'
1931 then
1932 case Argv (Argv'Last) is
1933 when '0' =>
1934 Current_Verbosity := Prj.Default;
1935 when '1' =>
1936 Current_Verbosity := Prj.Medium;
1937 when '2' =>
1938 Current_Verbosity := Prj.High;
1939 when others =>
1940
1941 -- Cannot happen
1942
1943 raise Program_Error;
1944 end case;
1945 else
1946 Fail ("invalid verbosity level: "
1947 & Argv (Argv'First + 3 .. Argv'Last));
1948 end if;
1949
1950 Remove_Switch (Arg_Num);
1951
1952 -- -Pproject_file Specify project file to be used
1953
1954 elsif Argv (Argv'First + 1) = 'P' then
1955
1956 -- Only one -P switch can be used
1957
1958 if Project_File /= null then
1959 Fail
1960 (Argv.all
1961 & ": second project file forbidden (first is """
1962 & Project_File.all
1963 & """)");
1964
1965 -- The two style project files (-p and -P) cannot be
1966 -- used together.
1967
1968 elsif Old_Project_File_Used then
1969 Fail ("-p and -P cannot be used together");
1970
1971 elsif Argv'Length = 2 then
1972
1973 -- There is space between -P and the project file
1974 -- name. -P cannot be the last option.
1975
1976 if Arg_Num = Last_Switches.Last then
1977 Fail ("project file name missing after -P");
1978
1979 else
1980 Remove_Switch (Arg_Num);
1981 Argv := Last_Switches.Table (Arg_Num);
1982
1983 -- After -P, there must be a project file name,
1984 -- not another switch.
1985
1986 if Argv (Argv'First) = '-' then
1987 Fail ("project file name missing after -P");
1988
1989 else
1990 Project_File := new String'(Argv.all);
1991 end if;
1992 end if;
1993
1994 else
1995 -- No space between -P and project file name
1996
1997 Project_File :=
1998 new String'(Argv (Argv'First + 2 .. Argv'Last));
1999 end if;
2000
2001 Remove_Switch (Arg_Num);
2002
2003 -- -Xexternal=value Specify an external reference to be
2004 -- used in project files
2005
2006 elsif Argv'Length >= 5
2007 and then Argv (Argv'First + 1) = 'X'
2008 then
2009 if not Check (Root_Environment.External,
2010 Argv (Argv'First + 2 .. Argv'Last))
2011 then
2012 Fail (Argv.all
2013 & " is not a valid external assignment.");
2014 end if;
2015
2016 Remove_Switch (Arg_Num);
2017
2018 elsif
2019 (The_Command = Check or else
2020 The_Command = Sync or else
2021 The_Command = Pretty or else
2022 The_Command = Metric or else
2023 The_Command = Stack or else
2024 The_Command = List)
2025 and then Argv'Length = 2
2026 and then Argv (2) = 'U'
2027 then
2028 All_Projects := True;
2029 Remove_Switch (Arg_Num);
2030
2031 else
2032 Arg_Num := Arg_Num + 1;
2033 end if;
2034
2035 elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
2036 or else The_Command = Sync
2037 or else The_Command = Metric
2038 or else The_Command = Pretty)
2039 and then Project_File /= null
2040 and then All_Projects
2041 then
2042 if ASIS_Main /= null then
2043 Fail ("cannot specify more than one main after -U");
2044 else
2045 ASIS_Main := Argv;
2046 Remove_Switch (Arg_Num);
2047 end if;
2048
2049 else
2050 Arg_Num := Arg_Num + 1;
2051 end if;
2052 end loop;
2053 end Inspect_Switches;
2054 end if;
2055
2056 -- Add the default project search directories now, after the directories
2057 -- that have been specified by switches -aP<dir>.
2058
2059 Prj.Env.Initialize_Default_Project_Path
2060 (Root_Environment.Project_Path,
2061 Target_Name => Sdefault.Target_Name.all);
2062
2063 -- If there is a project file specified, parse it, get the switches
2064 -- for the tool and setup PATH environment variables.
2065
2066 if Project_File /= null then
2067 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
2068
2069 Prj.Pars.Parse
2070 (Project => Project,
2071 In_Tree => Project_Tree,
2072 In_Node_Tree => Project_Node_Tree,
2073 Project_File_Name => Project_File.all,
2074 Env => Root_Environment,
2075 Packages_To_Check => Packages_To_Check);
2076
2077 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
2078
2079 Set_Standard_Error;
2080
2081 if Project = Prj.No_Project then
2082 Fail ("""" & Project_File.all & """ processing failed");
2083
2084 elsif Project.Qualifier = Aggregate then
2085 Fail ("aggregate projects are not supported");
2086
2087 elsif Aggregate_Libraries_In (Project_Tree) then
2088 Fail ("aggregate library projects are not supported");
2089 end if;
2090
2091 -- Check if a package with the name of the tool is in the project
2092 -- file and if there is one, get the switches, if any, and scan them.
2093
2094 declare
2095 Pkg : constant Prj.Package_Id :=
2096 Prj.Util.Value_Of
2097 (Name => Tool_Package_Name,
2098 In_Packages => Project.Decl.Packages,
2099 Shared => Project_Tree.Shared);
2100
2101 Element : Package_Element;
2102
2103 Switches_Array : Array_Element_Id;
2104
2105 The_Switches : Prj.Variable_Value;
2106 Current : Prj.String_List_Id;
2107 The_String : String_Element;
2108
2109 Main : String_Access := null;
2110
2111 begin
2112 if Pkg /= No_Package then
2113 Element := Project_Tree.Shared.Packages.Table (Pkg);
2114
2115 -- Packages Gnatls and Gnatstack have a single attribute
2116 -- Switches, that is not an associative array.
2117
2118 if The_Command = List or else The_Command = Stack then
2119 The_Switches :=
2120 Prj.Util.Value_Of
2121 (Variable_Name => Snames.Name_Switches,
2122 In_Variables => Element.Decl.Attributes,
2123 Shared => Project_Tree.Shared);
2124
2125 -- Packages Binder (for gnatbind), Cross_Reference (for
2126 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
2127 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
2128 -- (for gnatcheck), and Metric (for gnatmetric) have an
2129 -- attributed Switches, an associative array, indexed by the
2130 -- name of the file.
2131
2132 -- They also have an attribute Default_Switches, indexed by the
2133 -- name of the programming language.
2134
2135 else
2136 -- First check if there is a single main
2137
2138 for J in 1 .. Last_Switches.Last loop
2139 if Last_Switches.Table (J) (1) /= '-' then
2140 if Main = null then
2141 Main := Last_Switches.Table (J);
2142
2143 else
2144 Main := null;
2145 exit;
2146 end if;
2147 end if;
2148 end loop;
2149
2150 if Main /= null then
2151 Switches_Array :=
2152 Prj.Util.Value_Of
2153 (Name => Name_Switches,
2154 In_Arrays => Element.Decl.Arrays,
2155 Shared => Project_Tree.Shared);
2156 Name_Len := 0;
2157
2158 -- If the single main has been specified as an absolute
2159 -- path, use only the simple file name. If the absolute
2160 -- path is incorrect, an error will be reported by the
2161 -- underlying tool and it does not make a difference
2162 -- what switches are used.
2163
2164 if Is_Absolute_Path (Main.all) then
2165 Add_Str_To_Name_Buffer (File_Name (Main.all));
2166 else
2167 Add_Str_To_Name_Buffer (Main.all);
2168 end if;
2169
2170 The_Switches := Prj.Util.Value_Of
2171 (Index => Name_Find,
2172 Src_Index => 0,
2173 In_Array => Switches_Array,
2174 Shared => Project_Tree.Shared);
2175 end if;
2176
2177 if The_Switches.Kind = Prj.Undefined then
2178 Switches_Array :=
2179 Prj.Util.Value_Of
2180 (Name => Name_Default_Switches,
2181 In_Arrays => Element.Decl.Arrays,
2182 Shared => Project_Tree.Shared);
2183 The_Switches := Prj.Util.Value_Of
2184 (Index => Name_Ada,
2185 Src_Index => 0,
2186 In_Array => Switches_Array,
2187 Shared => Project_Tree.Shared);
2188 end if;
2189 end if;
2190
2191 -- If there are switches specified in the package of the
2192 -- project file corresponding to the tool, scan them.
2193
2194 case The_Switches.Kind is
2195 when Prj.Undefined =>
2196 null;
2197
2198 when Prj.Single =>
2199 declare
2200 Switch : constant String :=
2201 Get_Name_String (The_Switches.Value);
2202
2203 begin
2204 if Switch'Length > 0 then
2205 First_Switches.Increment_Last;
2206 First_Switches.Table (First_Switches.Last) :=
2207 new String'(Switch);
2208 end if;
2209 end;
2210
2211 when Prj.List =>
2212 Current := The_Switches.Values;
2213 while Current /= Prj.Nil_String loop
2214 The_String := Project_Tree.Shared.String_Elements.
2215 Table (Current);
2216
2217 declare
2218 Switch : constant String :=
2219 Get_Name_String (The_String.Value);
2220
2221 begin
2222 if Switch'Length > 0 then
2223 First_Switches.Increment_Last;
2224 First_Switches.Table (First_Switches.Last) :=
2225 new String'(Switch);
2226 end if;
2227 end;
2228
2229 Current := The_String.Next;
2230 end loop;
2231 end case;
2232 end if;
2233 end;
2234
2235 if The_Command = Bind or else
2236 The_Command = Link or else
2237 The_Command = Elim
2238 then
2239 if Project.Object_Directory.Name = No_Path then
2240 Fail ("project " & Get_Name_String (Project.Display_Name)
2241 & " has no object directory");
2242 end if;
2243
2244 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
2245 end if;
2246
2247 -- Set up the env vars for project path files
2248
2249 Prj.Env.Set_Ada_Paths
2250 (Project, Project_Tree, Including_Libraries => True);
2251
2252 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2253 -- a configuration pragmas file, if necessary.
2254
2255 if The_Command = Pretty
2256 or else The_Command = Metric
2257 or else The_Command = Stub
2258 or else The_Command = Elim
2259 or else The_Command = Check
2260 or else The_Command = Sync
2261 then
2262 -- If there are switches in package Compiler, put them in the
2263 -- Carg_Switches table.
2264
2265 declare
2266 Pkg : constant Prj.Package_Id :=
2267 Prj.Util.Value_Of
2268 (Name => Name_Compiler,
2269 In_Packages => Project.Decl.Packages,
2270 Shared => Project_Tree.Shared);
2271
2272 Element : Package_Element;
2273
2274 Switches_Array : Array_Element_Id;
2275
2276 The_Switches : Prj.Variable_Value;
2277 Current : Prj.String_List_Id;
2278 The_String : String_Element;
2279
2280 Main : String_Access := null;
2281 Main_Id : Name_Id;
2282
2283 begin
2284 if Pkg /= No_Package then
2285
2286 -- First, check if there is a single main specified
2287
2288 for J in 1 .. Last_Switches.Last loop
2289 if Last_Switches.Table (J) (1) /= '-' then
2290 if Main = null then
2291 Main := Last_Switches.Table (J);
2292
2293 else
2294 Main := null;
2295 exit;
2296 end if;
2297 end if;
2298 end loop;
2299
2300 Element := Project_Tree.Shared.Packages.Table (Pkg);
2301
2302 -- If there is a single main and there is compilation
2303 -- switches specified in the project file, use them.
2304
2305 if Main /= null and then not All_Projects then
2306 Name_Len := Main'Length;
2307 Name_Buffer (1 .. Name_Len) := Main.all;
2308 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2309 Main_Id := Name_Find;
2310
2311 Switches_Array :=
2312 Prj.Util.Value_Of
2313 (Name => Name_Switches,
2314 In_Arrays => Element.Decl.Arrays,
2315 Shared => Project_Tree.Shared);
2316 The_Switches := Prj.Util.Value_Of
2317 (Index => Main_Id,
2318 Src_Index => 0,
2319 In_Array => Switches_Array,
2320 Shared => Project_Tree.Shared);
2321 end if;
2322
2323 -- Otherwise, get the Default_Switches ("Ada")
2324
2325 if The_Switches.Kind = Undefined then
2326 Switches_Array :=
2327 Prj.Util.Value_Of
2328 (Name => Name_Default_Switches,
2329 In_Arrays => Element.Decl.Arrays,
2330 Shared => Project_Tree.Shared);
2331 The_Switches := Prj.Util.Value_Of
2332 (Index => Name_Ada,
2333 Src_Index => 0,
2334 In_Array => Switches_Array,
2335 Shared => Project_Tree.Shared);
2336 end if;
2337
2338 -- If there are switches specified, put them in the
2339 -- Carg_Switches table.
2340
2341 case The_Switches.Kind is
2342 when Prj.Undefined =>
2343 null;
2344
2345 when Prj.Single =>
2346 declare
2347 Switch : constant String :=
2348 Get_Name_String (The_Switches.Value);
2349 begin
2350 if Switch'Length > 0 then
2351 Add_To_Carg_Switches (new String'(Switch));
2352 end if;
2353 end;
2354
2355 when Prj.List =>
2356 Current := The_Switches.Values;
2357 while Current /= Prj.Nil_String loop
2358 The_String := Project_Tree.Shared.String_Elements
2359 .Table (Current);
2360
2361 declare
2362 Switch : constant String :=
2363 Get_Name_String (The_String.Value);
2364 begin
2365 if Switch'Length > 0 then
2366 Add_To_Carg_Switches (new String'(Switch));
2367 end if;
2368 end;
2369
2370 Current := The_String.Next;
2371 end loop;
2372 end case;
2373 end if;
2374 end;
2375
2376 -- If -cargs is one of the switches, move the following switches
2377 -- to the Carg_Switches table.
2378
2379 for J in 1 .. First_Switches.Last loop
2380 if First_Switches.Table (J).all = "-cargs" then
2381 declare
2382 K : Positive;
2383 Last : Natural;
2384
2385 begin
2386 -- Move the switches that are before -rules when the
2387 -- command is CHECK.
2388
2389 K := J + 1;
2390 while K <= First_Switches.Last
2391 and then
2392 (The_Command /= Check
2393 or else First_Switches.Table (K).all /= "-rules")
2394 loop
2395 Add_To_Carg_Switches (First_Switches.Table (K));
2396 K := K + 1;
2397 end loop;
2398
2399 if K > First_Switches.Last then
2400 First_Switches.Set_Last (J - 1);
2401
2402 else
2403 Last := J - 1;
2404 while K <= First_Switches.Last loop
2405 Last := Last + 1;
2406 First_Switches.Table (Last) :=
2407 First_Switches.Table (K);
2408 K := K + 1;
2409 end loop;
2410
2411 First_Switches.Set_Last (Last);
2412 end if;
2413 end;
2414
2415 exit;
2416 end if;
2417 end loop;
2418
2419 for J in 1 .. Last_Switches.Last loop
2420 if Last_Switches.Table (J).all = "-cargs" then
2421 declare
2422 K : Positive;
2423 Last : Natural;
2424
2425 begin
2426 -- Move the switches that are before -rules when the
2427 -- command is CHECK.
2428
2429 K := J + 1;
2430 while K <= Last_Switches.Last
2431 and then
2432 (The_Command /= Check
2433 or else Last_Switches.Table (K).all /= "-rules")
2434 loop
2435 Add_To_Carg_Switches (Last_Switches.Table (K));
2436 K := K + 1;
2437 end loop;
2438
2439 if K > Last_Switches.Last then
2440 Last_Switches.Set_Last (J - 1);
2441
2442 else
2443 Last := J - 1;
2444 while K <= Last_Switches.Last loop
2445 Last := Last + 1;
2446 Last_Switches.Table (Last) :=
2447 Last_Switches.Table (K);
2448 K := K + 1;
2449 end loop;
2450
2451 Last_Switches.Set_Last (Last);
2452 end if;
2453 end;
2454
2455 exit;
2456 end if;
2457 end loop;
2458
2459 declare
2460 CP_File : constant Path_Name_Type := Configuration_Pragmas_File;
2461 M_File : constant Path_Name_Type := Mapping_File;
2462
2463 begin
2464 if CP_File /= No_Path then
2465 if The_Command = Elim then
2466 First_Switches.Increment_Last;
2467 First_Switches.Table (First_Switches.Last) :=
2468 new String'("-C" & Get_Name_String (CP_File));
2469
2470 else
2471 Add_To_Carg_Switches
2472 (new String'("-gnatec=" & Get_Name_String (CP_File)));
2473 end if;
2474 end if;
2475
2476 if M_File /= No_Path then
2477 Add_To_Carg_Switches
2478 (new String'("-gnatem=" & Get_Name_String (M_File)));
2479 end if;
2480
2481 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2482 -- indicate a global configuration pragmas file and, if -U
2483 -- is not used, a local one.
2484
2485 if The_Command = Check or else
2486 The_Command = Pretty or else
2487 The_Command = Stub or else
2488 The_Command = Metric
2489 then
2490 declare
2491 Pkg : constant Prj.Package_Id :=
2492 Prj.Util.Value_Of
2493 (Name => Name_Builder,
2494 In_Packages => Project.Decl.Packages,
2495 Shared => Project_Tree.Shared);
2496
2497 Variable : Variable_Value :=
2498 Prj.Util.Value_Of
2499 (Name => No_Name,
2500 Attribute_Or_Array_Name =>
2501 Name_Global_Configuration_Pragmas,
2502 In_Package => Pkg,
2503 Shared => Project_Tree.Shared);
2504
2505 begin
2506 if (Variable = Nil_Variable_Value
2507 or else Length_Of_Name (Variable.Value) = 0)
2508 and then Pkg /= No_Package
2509 then
2510 Variable :=
2511 Prj.Util.Value_Of
2512 (Name => Name_Ada,
2513 Attribute_Or_Array_Name =>
2514 Name_Global_Config_File,
2515 In_Package => Pkg,
2516 Shared => Project_Tree.Shared);
2517 end if;
2518
2519 if Variable /= Nil_Variable_Value
2520 and then Length_Of_Name (Variable.Value) /= 0
2521 then
2522 declare
2523 Path : constant String :=
2524 Absolute_Path
2525 (Path_Name_Type (Variable.Value),
2526 Variable.Project);
2527 begin
2528 Add_To_Carg_Switches
2529 (new String'("-gnatec=" & Path));
2530 end;
2531 end if;
2532 end;
2533
2534 if not All_Projects then
2535 declare
2536 Pkg : constant Prj.Package_Id :=
2537 Prj.Util.Value_Of
2538 (Name => Name_Compiler,
2539 In_Packages => Project.Decl.Packages,
2540 Shared => Project_Tree.Shared);
2541
2542 Variable : Variable_Value :=
2543 Prj.Util.Value_Of
2544 (Name => No_Name,
2545 Attribute_Or_Array_Name =>
2546 Name_Local_Configuration_Pragmas,
2547 In_Package => Pkg,
2548 Shared => Project_Tree.Shared);
2549
2550 begin
2551 if (Variable = Nil_Variable_Value
2552 or else Length_Of_Name (Variable.Value) = 0)
2553 and then Pkg /= No_Package
2554 then
2555 Variable :=
2556 Prj.Util.Value_Of
2557 (Name => Name_Ada,
2558 Attribute_Or_Array_Name =>
2559 Name_Local_Config_File,
2560 In_Package => Pkg,
2561 Shared =>
2562 Project_Tree.Shared);
2563 end if;
2564
2565 if Variable /= Nil_Variable_Value
2566 and then Length_Of_Name (Variable.Value) /= 0
2567 then
2568 declare
2569 Path : constant String :=
2570 Absolute_Path
2571 (Path_Name_Type (Variable.Value),
2572 Variable.Project);
2573 begin
2574 Add_To_Carg_Switches
2575 (new String'("-gnatec=" & Path));
2576 end;
2577 end if;
2578 end;
2579 end if;
2580 end if;
2581 end;
2582 end if;
2583
2584 if The_Command = Link then
2585 Process_Link;
2586 end if;
2587
2588 if The_Command = Link or else The_Command = Bind then
2589
2590 -- For files that are specified as relative paths with directory
2591 -- information, we convert them to absolute paths, with parent
2592 -- being the current working directory if specified on the command
2593 -- line and the project directory if specified in the project
2594 -- file. This is what gnatmake is doing for linker and binder
2595 -- arguments.
2596
2597 for J in 1 .. Last_Switches.Last loop
2598 GNATCmd.Ensure_Absolute_Path
2599 (Last_Switches.Table (J), Current_Work_Dir);
2600 end loop;
2601
2602 Get_Name_String (Project.Directory.Name);
2603
2604 declare
2605 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2606 begin
2607 for J in 1 .. First_Switches.Last loop
2608 GNATCmd.Ensure_Absolute_Path
2609 (First_Switches.Table (J), Project_Dir);
2610 end loop;
2611 end;
2612
2613 elsif The_Command = Stub then
2614 declare
2615 File_Index : Integer := 0;
2616 Dir_Index : Integer := 0;
2617 Last : constant Integer := Last_Switches.Last;
2618 Lang : constant Language_Ptr :=
2619 Get_Language_From_Name (Project, "ada");
2620
2621 begin
2622 for Index in 1 .. Last loop
2623 if Last_Switches.Table (Index)
2624 (Last_Switches.Table (Index)'First) /= '-'
2625 then
2626 File_Index := Index;
2627 exit;
2628 end if;
2629 end loop;
2630
2631 -- If the project file naming scheme is not standard, and if
2632 -- the file name ends with the spec suffix, then indicate to
2633 -- gnatstub the name of the body file with a -o switch.
2634
2635 if Lang /= No_Language_Index
2636 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data)
2637 then
2638 if File_Index /= 0 then
2639 declare
2640 Spec : constant String :=
2641 Base_Name
2642 (Last_Switches.Table (File_Index).all);
2643 Last : Natural := Spec'Last;
2644
2645 begin
2646 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2647
2648 if Spec'Length > Name_Len
2649 and then Spec (Last - Name_Len + 1 .. Last) =
2650 Name_Buffer (1 .. Name_Len)
2651 then
2652 Last := Last - Name_Len;
2653 Get_Name_String
2654 (Lang.Config.Naming_Data.Body_Suffix);
2655 Last_Switches.Increment_Last;
2656 Last_Switches.Table (Last_Switches.Last) :=
2657 new String'("-o");
2658 Last_Switches.Increment_Last;
2659 Last_Switches.Table (Last_Switches.Last) :=
2660 new String'(Spec (Spec'First .. Last) &
2661 Name_Buffer (1 .. Name_Len));
2662 end if;
2663 end;
2664 end if;
2665 end if;
2666
2667 -- Add the directory of the spec as the destination directory
2668 -- of the body, if there is no destination directory already
2669 -- specified.
2670
2671 if File_Index /= 0 then
2672 for Index in File_Index + 1 .. Last loop
2673 if Last_Switches.Table (Index)
2674 (Last_Switches.Table (Index)'First) /= '-'
2675 then
2676 Dir_Index := Index;
2677 exit;
2678 end if;
2679 end loop;
2680
2681 if Dir_Index = 0 then
2682 Last_Switches.Increment_Last;
2683 Last_Switches.Table (Last_Switches.Last) :=
2684 new String'
2685 (Dir_Name (Last_Switches.Table (File_Index).all));
2686 end if;
2687 end if;
2688 end;
2689 end if;
2690
2691 -- For gnatmetric, the generated files should be put in the object
2692 -- directory. This must be the first switch, because it may be
2693 -- overridden by a switch in package Metrics in the project file or
2694 -- by a command line option. Note that we don't add the -d= switch
2695 -- if there is no object directory available.
2696
2697 if The_Command = Metric
2698 and then Project.Object_Directory /= No_Path_Information
2699 then
2700 First_Switches.Increment_Last;
2701 First_Switches.Table (2 .. First_Switches.Last) :=
2702 First_Switches.Table (1 .. First_Switches.Last - 1);
2703 First_Switches.Table (1) :=
2704 new String'("-d=" &
2705 Get_Name_String (Project.Object_Directory.Name));
2706 end if;
2707
2708 -- For gnat check, -rules and the following switches need to be the
2709 -- last options, so move all these switches to table Rules_Switches.
2710
2711 if The_Command = Check then
2712 declare
2713 New_Last : Natural;
2714 -- Set to rank of options preceding "-rules"
2715
2716 In_Rules_Switches : Boolean;
2717 -- Set to True when options "-rules" is found
2718
2719 begin
2720 New_Last := First_Switches.Last;
2721 In_Rules_Switches := False;
2722
2723 for J in 1 .. First_Switches.Last loop
2724 if In_Rules_Switches then
2725 Add_To_Rules_Switches (First_Switches.Table (J));
2726
2727 elsif First_Switches.Table (J).all = "-rules" then
2728 New_Last := J - 1;
2729 In_Rules_Switches := True;
2730 end if;
2731 end loop;
2732
2733 if In_Rules_Switches then
2734 First_Switches.Set_Last (New_Last);
2735 end if;
2736
2737 New_Last := Last_Switches.Last;
2738 In_Rules_Switches := False;
2739
2740 for J in 1 .. Last_Switches.Last loop
2741 if In_Rules_Switches then
2742 Add_To_Rules_Switches (Last_Switches.Table (J));
2743
2744 elsif Last_Switches.Table (J).all = "-rules" then
2745 New_Last := J - 1;
2746 In_Rules_Switches := True;
2747 end if;
2748 end loop;
2749
2750 if In_Rules_Switches then
2751 Last_Switches.Set_Last (New_Last);
2752 end if;
2753 end;
2754 end if;
2755
2756 -- For gnat check, sync, metric or pretty with -U + a main, get the
2757 -- list of sources from the closure and add them to the arguments.
2758
2759 if ASIS_Main /= null then
2760 Get_Closure;
2761
2762 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2763 -- and gnat stack, if no file has been put on the command line, call
2764 -- tool with all the sources of the main project.
2765
2766 elsif The_Command = Check or else
2767 The_Command = Sync or else
2768 The_Command = Pretty or else
2769 The_Command = Metric or else
2770 The_Command = List or else
2771 The_Command = Stack
2772 then
2773 Check_Files;
2774 end if;
2775 end if;
2776
2777 -- Gather all the arguments and invoke the executable
2778
2779 declare
2780 The_Args : Argument_List
2781 (1 .. First_Switches.Last +
2782 Last_Switches.Last +
2783 Carg_Switches.Last +
2784 Rules_Switches.Last);
2785 Arg_Num : Natural := 0;
2786
2787 begin
2788 for J in 1 .. First_Switches.Last loop
2789 Arg_Num := Arg_Num + 1;
2790 The_Args (Arg_Num) := First_Switches.Table (J);
2791 end loop;
2792
2793 for J in 1 .. Last_Switches.Last loop
2794 Arg_Num := Arg_Num + 1;
2795 The_Args (Arg_Num) := Last_Switches.Table (J);
2796 end loop;
2797
2798 for J in 1 .. Carg_Switches.Last loop
2799 Arg_Num := Arg_Num + 1;
2800 The_Args (Arg_Num) := Carg_Switches.Table (J);
2801 end loop;
2802
2803 for J in 1 .. Rules_Switches.Last loop
2804 Arg_Num := Arg_Num + 1;
2805 The_Args (Arg_Num) := Rules_Switches.Table (J);
2806 end loop;
2807
2808 if Verbose_Mode then
2809 Output.Write_Str (Exec_Path.all);
2810
2811 for Arg in The_Args'Range loop
2812 Output.Write_Char (' ');
2813 Output.Write_Str (The_Args (Arg).all);
2814 end loop;
2815
2816 Output.Write_Eol;
2817 end if;
2818
2819 My_Exit_Status :=
2820 Exit_Status (Spawn (Exec_Path.all, The_Args));
2821 raise Normal_Exit;
2822 end;
2823 end;
2824
2825 exception
2826 when Error_Exit =>
2827 if not Keep_Temporary_Files then
2828 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2829 Delete_Temp_Config_Files;
2830 end if;
2831
2832 Set_Exit_Status (Failure);
2833
2834 when Normal_Exit =>
2835 if not Keep_Temporary_Files then
2836 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2837 Delete_Temp_Config_Files;
2838 end if;
2839
2840 Set_Exit_Status (My_Exit_Status);
2841 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org