?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-11-18 Christophe Lyon <christophe.lyon@linaro.org>
[official-gcc.git] / gcc / ada / gnatcmd.adb
blobc7a1330a15179bc080475ad2908ddab49faeee03
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 (""" & Exec_File_Name
887 & """) with directory part not allowed "
888 & "when using project files");
889 end if;
890 end loop;
891
892 Get_Name_String (Project.Exec_Directory.Name);
893
894 if Name_Buffer (Name_Len) /= Directory_Separator then
895 Name_Len := Name_Len + 1;
896 Name_Buffer (Name_Len) := Directory_Separator;
897 end if;
898
899 Name_Buffer (Name_Len + 1 ..
900 Name_Len + Exec_File_Name'Length) :=
901 Exec_File_Name;
902 Name_Len := Name_Len + Exec_File_Name'Length;
903 Name := new String'(Name_Buffer (1 .. Name_Len));
904 end if;
905 end Check_Relative_Executable;
906
907 --------------------------------
908 -- Configuration_Pragmas_File --
909 --------------------------------
910
911 function Configuration_Pragmas_File return Path_Name_Type is
912 begin
913 Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
914 return Project.Config_File_Name;
915 end Configuration_Pragmas_File;
916
917 ------------------------------
918 -- Delete_Temp_Config_Files --
919 ------------------------------
920
921 procedure Delete_Temp_Config_Files is
922 Success : Boolean;
923 Proj : Project_List;
924 pragma Warnings (Off, Success);
925
926 begin
927 -- This should only be called if Keep_Temporary_Files is False
928
929 pragma Assert (not Keep_Temporary_Files);
930
931 if Project /= No_Project then
932 Proj := Project_Tree.Projects;
933 while Proj /= null loop
934 if Proj.Project.Config_File_Temp then
935 Delete_Temporary_File
936 (Project_Tree.Shared, Proj.Project.Config_File_Name);
937 end if;
938
939 Proj := Proj.Next;
940 end loop;
941 end if;
942
943 -- If a temporary text file that contains a list of files for a tool
944 -- has been created, delete this temporary file.
945
946 if Temp_File_Name /= No_Path then
947 Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
948 end if;
949 end Delete_Temp_Config_Files;
950
951 ---------------------------
952 -- Ensure_Absolute_Path --
953 ---------------------------
954
955 procedure Ensure_Absolute_Path
956 (Switch : in out String_Access;
957 Parent : String)
958 is
959 begin
960 Makeutl.Ensure_Absolute_Path
961 (Switch, Parent,
962 Do_Fail => Osint.Fail'Access,
963 Including_Non_Switch => False,
964 Including_RTS => True);
965 end Ensure_Absolute_Path;
966
967 -----------------
968 -- Get_Closure --
969 -----------------
970
971 procedure Get_Closure is
972 Args : constant Argument_List :=
973 (1 => new String'("-q"),
974 2 => new String'("-b"),
975 3 => new String'("-P"),
976 4 => Project_File,
977 5 => ASIS_Main,
978 6 => new String'("-bargs"),
979 7 => new String'("-R"),
980 8 => new String'("-Z"));
981 -- Arguments for the invocation of gnatmake which are added to the
982 -- Last_Arguments list by this procedure.
983
984 FD : File_Descriptor;
985 -- File descriptor for the temp file that will get the output of the
986 -- invocation of gnatmake.
987
988 Name : Path_Name_Type;
989 -- Path of the file FD
990
991 GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
992 -- Name for gnatmake
993
994 GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
995 -- Path of gnatmake
996
997 Return_Code : Integer;
998
999 Unused : Boolean;
1000 pragma Warnings (Off, Unused);
1001
1002 File : Ada.Text_IO.File_Type;
1003 Line : String (1 .. 250);
1004 Last : Natural;
1005 -- Used to read file if there is an error, it is good enough to display
1006 -- just 250 characters if the first line of the file is very long.
1007
1008 Unit : Unit_Index;
1009 Path : Path_Name_Type;
1010
1011 Files_File : Ada.Text_IO.File_Type;
1012 Temp_File_Name : Path_Name_Type;
1013
1014 begin
1015 if GN_Path = null then
1016 Put_Line (Standard_Error, "could not locate " & GN_Name);
1017 raise Error_Exit;
1018 end if;
1019
1020 -- Create the temp file
1021
1022 Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
1023
1024 -- And close it
1025
1026 Close (FD);
1027
1028 -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
1029
1030 Spawn
1031 (Program_Name => GN_Path.all,
1032 Args => Args,
1033 Output_File => Get_Name_String (Name),
1034 Success => Unused,
1035 Return_Code => Return_Code,
1036 Err_To_Out => True);
1037
1038 -- Read the output of the invocation of gnatmake
1039
1040 Open (File, In_File, Get_Name_String (Name));
1041
1042 -- If it was unsuccessful, display the first line in the file and exit
1043 -- with error.
1044
1045 if Return_Code /= 0 then
1046 Get_Line (File, Line, Last);
1047
1048 begin
1049 if not Keep_Temporary_Files then
1050 Delete (File);
1051 else
1052 Close (File);
1053 end if;
1054
1055 -- Don't crash if it is not possible to delete or close the file,
1056 -- just ignore the situation.
1057
1058 exception
1059 when others =>
1060 null;
1061 end;
1062
1063 Put_Line (Standard_Error, Line (1 .. Last));
1064 Put_Line
1065 (Standard_Error, "could not get closure of " & ASIS_Main.all);
1066 raise Error_Exit;
1067
1068 else
1069 -- Create a temporary file to put the list of files in the closure
1070
1071 Tempdir.Create_Temp_File (FD, Temp_File_Name);
1072 Last_Switches.Increment_Last;
1073 Last_Switches.Table (Last_Switches.Last) :=
1074 new String'("-files=" & Get_Name_String (Temp_File_Name));
1075
1076 Close (FD);
1077
1078 Open (Files_File, Out_File, Get_Name_String (Temp_File_Name));
1079
1080 -- Get each file name in the file, find its path and add it the list
1081 -- of arguments.
1082
1083 while not End_Of_File (File) loop
1084 Get_Line (File, Line, Last);
1085 Path := No_Path;
1086
1087 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
1088 while Unit /= No_Unit_Index loop
1089 if Unit.File_Names (Spec) /= null
1090 and then
1091 Get_Name_String (Unit.File_Names (Spec).File) =
1092 Line (1 .. Last)
1093 then
1094 Path := Unit.File_Names (Spec).Path.Name;
1095 exit;
1096
1097 elsif Unit.File_Names (Impl) /= null
1098 and then
1099 Get_Name_String (Unit.File_Names (Impl).File) =
1100 Line (1 .. Last)
1101 then
1102 Path := Unit.File_Names (Impl).Path.Name;
1103 exit;
1104 end if;
1105
1106 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
1107 end loop;
1108
1109 if Path /= No_Path then
1110 Put_Line (Files_File, Get_Name_String (Path));
1111
1112 else
1113 Put_Line (Files_File, Line (1 .. Last));
1114 end if;
1115 end loop;
1116
1117 Close (Files_File);
1118
1119 begin
1120 if not Keep_Temporary_Files then
1121 Delete (File);
1122 else
1123 Close (File);
1124 end if;
1125
1126 -- Don't crash if it is not possible to delete or close the file,
1127 -- just ignore the situation.
1128
1129 exception
1130 when others =>
1131 null;
1132 end;
1133 end if;
1134 end Get_Closure;
1135
1136 ------------------
1137 -- Mapping_File --
1138 ------------------
1139
1140 function Mapping_File return Path_Name_Type is
1141 Result : Path_Name_Type;
1142 begin
1143 Prj.Env.Create_Mapping_File
1144 (Project => Project,
1145 Language => Name_Ada,
1146 In_Tree => Project_Tree,
1147 Name => Result);
1148 return Result;
1149 end Mapping_File;
1150
1151 --------------------
1152 -- Output_Version --
1153 --------------------
1154
1155 procedure Output_Version is
1156 begin
1157 if AAMP_On_Target then
1158 Put ("GNAAMP ");
1159 else
1160 Put ("GNAT ");
1161 end if;
1162
1163 Put_Line (Gnatvsn.Gnat_Version_String);
1164 Put_Line ("Copyright 1996-" &
1165 Gnatvsn.Current_Year &
1166 ", Free Software Foundation, Inc.");
1167 end Output_Version;
1168
1169 -----------
1170 -- Usage --
1171 -----------
1172
1173 procedure Usage is
1174 begin
1175 Output_Version;
1176 New_Line;
1177 Put_Line ("List of available commands");
1178 New_Line;
1179
1180 for C in Command_List'Range loop
1181
1182 -- No usage for Sync
1183
1184 if C /= Sync then
1185 if Targparm.AAMP_On_Target then
1186 Put ("gnaampcmd ");
1187 else
1188 Put ("gnat ");
1189 end if;
1190
1191 Put (To_Lower (Command_List (C).Cname.all));
1192 Set_Col (25);
1193
1194 -- Never call gnatstack with a prefix
1195
1196 if C = Stack then
1197 Put (Command_List (C).Unixcmd.all);
1198 else
1199 Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
1200 end if;
1201
1202 declare
1203 Sws : Argument_List_Access renames Command_List (C).Unixsws;
1204 begin
1205 if Sws /= null then
1206 for J in Sws'Range loop
1207 Put (' ');
1208 Put (Sws (J).all);
1209 end loop;
1210 end if;
1211 end;
1212
1213 New_Line;
1214 end if;
1215 end loop;
1216
1217 New_Line;
1218 Put_Line ("All commands except chop, krunch and preprocess " &
1219 "accept project file switches -vPx, -Pprj and -Xnam=val");
1220 New_Line;
1221 end Usage;
1222
1223 ------------------
1224 -- Process_Link --
1225 ------------------
1226
1227 procedure Process_Link is
1228 Look_For_Executable : Boolean := True;
1229 Libraries_Present : Boolean := False;
1230 Path_Option : constant String_Access :=
1231 MLib.Linker_Library_Path_Option;
1232 Prj : Project_Id := Project;
1233 Arg : String_Access;
1234 Last : Natural := 0;
1235 Skip_Executable : Boolean := False;
1236
1237 begin
1238 -- Add the default search directories, to be able to find
1239 -- libgnat in call to MLib.Utl.Lib_Directory.
1240
1241 Add_Default_Search_Dirs;
1242
1243 Library_Paths.Set_Last (0);
1244
1245 -- Check if there are library project files
1246
1247 if MLib.Tgt.Support_For_Libraries /= None then
1248 Set_Libraries (Project, Project_Tree, Libraries_Present);
1249 end if;
1250
1251 -- If there are, add the necessary additional switches
1252
1253 if Libraries_Present then
1254
1255 -- Add -Wl,-rpath,<lib_dir>
1256
1257 -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
1258 -- equivalent) with all the library dirs plus the standard GNAT
1259 -- library dir.
1260
1261 if Path_Option /= null then
1262 declare
1263 Option : String_Access;
1264 Length : Natural := Path_Option'Length;
1265 Current : Natural;
1266
1267 begin
1268 if MLib.Separate_Run_Path_Options then
1269
1270 -- We are going to create one switch of the form
1271 -- "-Wl,-rpath,dir_N" for each directory to consider.
1272
1273 -- One switch for each library directory
1274
1275 for Index in
1276 Library_Paths.First .. Library_Paths.Last
1277 loop
1278 Last_Switches.Increment_Last;
1279 Last_Switches.Table
1280 (Last_Switches.Last) := new String'
1281 (Path_Option.all &
1282 Last_Switches.Table (Index).all);
1283 end loop;
1284
1285 -- One switch for the standard GNAT library dir
1286
1287 Last_Switches.Increment_Last;
1288 Last_Switches.Table
1289 (Last_Switches.Last) := new String'
1290 (Path_Option.all & MLib.Utl.Lib_Directory);
1291
1292 else
1293 -- First, compute the exact length for the switch
1294
1295 for Index in
1296 Library_Paths.First .. Library_Paths.Last
1297 loop
1298 -- Add the length of the library dir plus one for the
1299 -- directory separator.
1300
1301 Length :=
1302 Length +
1303 Library_Paths.Table (Index)'Length + 1;
1304 end loop;
1305
1306 -- Finally, add the length of the standard GNAT library dir
1307
1308 Length := Length + MLib.Utl.Lib_Directory'Length;
1309 Option := new String (1 .. Length);
1310 Option (1 .. Path_Option'Length) := Path_Option.all;
1311 Current := Path_Option'Length;
1312
1313 -- Put each library dir followed by a dir separator
1314
1315 for Index in
1316 Library_Paths.First .. Library_Paths.Last
1317 loop
1318 Option
1319 (Current + 1 ..
1320 Current +
1321 Library_Paths.Table (Index)'Length) :=
1322 Library_Paths.Table (Index).all;
1323 Current :=
1324 Current +
1325 Library_Paths.Table (Index)'Length + 1;
1326 Option (Current) := Path_Separator;
1327 end loop;
1328
1329 -- Finally put the standard GNAT library dir
1330
1331 Option
1332 (Current + 1 ..
1333 Current + MLib.Utl.Lib_Directory'Length) :=
1334 MLib.Utl.Lib_Directory;
1335
1336 -- And add the switch to the last switches
1337
1338 Last_Switches.Increment_Last;
1339 Last_Switches.Table (Last_Switches.Last) :=
1340 Option;
1341 end if;
1342 end;
1343 end if;
1344 end if;
1345
1346 -- Check if the first ALI file specified can be found, either in the
1347 -- object directory of the main project or in an object directory of a
1348 -- project file extended by the main project. If the ALI file can be
1349 -- found, replace its name with its absolute path.
1350
1351 Skip_Executable := False;
1352
1353 Switch_Loop : for J in 1 .. Last_Switches.Last loop
1354
1355 -- If we have an executable just reset the flag
1356
1357 if Skip_Executable then
1358 Skip_Executable := False;
1359
1360 -- If -o, set flag so that next switch is not processed
1361
1362 elsif Last_Switches.Table (J).all = "-o" then
1363 Skip_Executable := True;
1364
1365 -- Normal case
1366
1367 else
1368 declare
1369 Switch : constant String :=
1370 Last_Switches.Table (J).all;
1371 ALI_File : constant String (1 .. Switch'Length + 4) :=
1372 Switch & ".ali";
1373
1374 Test_Existence : Boolean := False;
1375
1376 begin
1377 Last := Switch'Length;
1378
1379 -- Skip real switches
1380
1381 if Switch'Length /= 0
1382 and then Switch (Switch'First) /= '-'
1383 then
1384 -- Append ".ali" if file name does not end with it
1385
1386 if Switch'Length <= 4
1387 or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
1388 then
1389 Last := ALI_File'Last;
1390 end if;
1391
1392 -- If file name includes directory information, stop if ALI
1393 -- file exists.
1394
1395 if Is_Absolute_Path (ALI_File (1 .. Last)) then
1396 Test_Existence := True;
1397
1398 else
1399 for K in Switch'Range loop
1400 if Is_Directory_Separator (Switch (K)) then
1401 Test_Existence := True;
1402 exit;
1403 end if;
1404 end loop;
1405 end if;
1406
1407 if Test_Existence then
1408 if Is_Regular_File (ALI_File (1 .. Last)) then
1409 exit Switch_Loop;
1410 end if;
1411
1412 -- Look in object directories if ALI file exists
1413
1414 else
1415 Project_Loop : loop
1416 declare
1417 Dir : constant String :=
1418 Get_Name_String (Prj.Object_Directory.Name);
1419 begin
1420 if Is_Regular_File
1421 (Dir &
1422 ALI_File (1 .. Last))
1423 then
1424 -- We have found the correct project, so we
1425 -- replace the file with the absolute path.
1426
1427 Last_Switches.Table (J) :=
1428 new String'(Dir & ALI_File (1 .. Last));
1429
1430 -- And we are done
1431
1432 exit Switch_Loop;
1433 end if;
1434 end;
1435
1436 -- Go to the project being extended, if any
1437
1438 Prj := Prj.Extends;
1439 exit Project_Loop when Prj = No_Project;
1440 end loop Project_Loop;
1441 end if;
1442 end if;
1443 end;
1444 end if;
1445 end loop Switch_Loop;
1446
1447 -- If a relative path output file has been specified, we add the exec
1448 -- directory.
1449
1450 for J in reverse 1 .. Last_Switches.Last - 1 loop
1451 if Last_Switches.Table (J).all = "-o" then
1452 Check_Relative_Executable
1453 (Name => Last_Switches.Table (J + 1));
1454 Look_For_Executable := False;
1455 exit;
1456 end if;
1457 end loop;
1458
1459 if Look_For_Executable then
1460 for J in reverse 1 .. First_Switches.Last - 1 loop
1461 if First_Switches.Table (J).all = "-o" then
1462 Look_For_Executable := False;
1463 Check_Relative_Executable
1464 (Name => First_Switches.Table (J + 1));
1465 exit;
1466 end if;
1467 end loop;
1468 end if;
1469
1470 -- If no executable is specified, then find the name of the first ALI
1471 -- file on the command line and issue a -o switch with the absolute path
1472 -- of the executable in the exec directory.
1473
1474 if Look_For_Executable then
1475 for J in 1 .. Last_Switches.Last loop
1476 Arg := Last_Switches.Table (J);
1477 Last := 0;
1478
1479 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
1480 if Arg'Length > 4
1481 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
1482 then
1483 Last := Arg'Last - 4;
1484
1485 elsif Is_Regular_File (Arg.all & ".ali") then
1486 Last := Arg'Last;
1487 end if;
1488
1489 if Last /= 0 then
1490 Last_Switches.Increment_Last;
1491 Last_Switches.Table (Last_Switches.Last) :=
1492 new String'("-o");
1493 Get_Name_String (Project.Exec_Directory.Name);
1494 Last_Switches.Increment_Last;
1495 Last_Switches.Table (Last_Switches.Last) :=
1496 new String'(Name_Buffer (1 .. Name_Len) &
1497 Executable_Name
1498 (Base_Name (Arg (Arg'First .. Last))));
1499 exit;
1500 end if;
1501 end if;
1502 end loop;
1503 end if;
1504 end Process_Link;
1505
1506 ---------------------
1507 -- Set_Library_For --
1508 ---------------------
1509
1510 procedure Set_Library_For
1511 (Project : Project_Id;
1512 Tree : Project_Tree_Ref;
1513 Libraries_Present : in out Boolean)
1514 is
1515 pragma Unreferenced (Tree);
1516
1517 Path_Option : constant String_Access :=
1518 MLib.Linker_Library_Path_Option;
1519
1520 begin
1521 -- Case of library project
1522
1523 if Project.Library then
1524 Libraries_Present := True;
1525
1526 -- Add the -L switch
1527
1528 Last_Switches.Increment_Last;
1529 Last_Switches.Table (Last_Switches.Last) :=
1530 new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1531
1532 -- Add the -l switch
1533
1534 Last_Switches.Increment_Last;
1535 Last_Switches.Table (Last_Switches.Last) :=
1536 new String'("-l" & Get_Name_String (Project.Library_Name));
1537
1538 -- Add the directory to table Library_Paths, to be processed later
1539 -- if library is not static and if Path_Option is not null.
1540
1541 if Project.Library_Kind /= Static
1542 and then Path_Option /= null
1543 then
1544 Library_Paths.Increment_Last;
1545 Library_Paths.Table (Library_Paths.Last) :=
1546 new String'(Get_Name_String (Project.Library_Dir.Name));
1547 end if;
1548 end if;
1549 end Set_Library_For;
1550
1551 procedure Check_Version_And_Help is
1552 new Check_Version_And_Help_G (Usage);
1553
1554 -- Start of processing for GNATCmd
1555
1556 begin
1557 -- All output from GNATCmd is debugging or error output: send to stderr
1558
1559 Set_Standard_Error;
1560
1561 -- Initializations
1562
1563 Csets.Initialize;
1564 Snames.Initialize;
1565 Stringt.Initialize;
1566
1567 Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
1568
1569 Project_Node_Tree := new Project_Node_Tree_Data;
1570 Prj.Tree.Initialize (Project_Node_Tree);
1571
1572 Prj.Initialize (Project_Tree);
1573
1574 Last_Switches.Init;
1575 Last_Switches.Set_Last (0);
1576
1577 First_Switches.Init;
1578 First_Switches.Set_Last (0);
1579 Carg_Switches.Init;
1580 Carg_Switches.Set_Last (0);
1581 Rules_Switches.Init;
1582 Rules_Switches.Set_Last (0);
1583
1584 -- Set AAMP_On_Target from command name, for testing in Osint.Program_Name
1585 -- to handle the mapping of GNAAMP tool names. We don't extract it from
1586 -- system.ads, as there may be no default runtime.
1587
1588 Find_Program_Name;
1589 AAMP_On_Target := Name_Buffer (1 .. Name_Len) = "gnaampcmd";
1590
1591 -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
1592 -- so that the spawned tool may know the way the GNAT driver was invoked.
1593
1594 Name_Len := 0;
1595 Add_Str_To_Name_Buffer (Command_Name);
1596
1597 for J in 1 .. Argument_Count loop
1598 Add_Char_To_Name_Buffer (' ');
1599 Add_Str_To_Name_Buffer (Argument (J));
1600 end loop;
1601
1602 Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
1603
1604 -- Add the directory where the GNAT driver is invoked in front of the path,
1605 -- if the GNAT driver is invoked with directory information.
1606
1607 declare
1608 Command : constant String := Command_Name;
1609
1610 begin
1611 for Index in reverse Command'Range loop
1612 if Command (Index) = Directory_Separator then
1613 declare
1614 Absolute_Dir : constant String :=
1615 Normalize_Pathname
1616 (Command (Command'First .. Index));
1617
1618 PATH : constant String :=
1619 Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1620
1621 begin
1622 Setenv ("PATH", PATH);
1623 end;
1624
1625 exit;
1626 end if;
1627 end loop;
1628 end;
1629
1630 -- Scan the command line
1631
1632 -- First, scan to detect --version and/or --help
1633
1634 Check_Version_And_Help ("GNAT", "1996");
1635
1636 begin
1637 loop
1638 if Command_Arg <= Argument_Count
1639 and then Argument (Command_Arg) = "-v"
1640 then
1641 Verbose_Mode := True;
1642 Command_Arg := Command_Arg + 1;
1643
1644 elsif Command_Arg <= Argument_Count
1645 and then Argument (Command_Arg) = "-dn"
1646 then
1647 Keep_Temporary_Files := True;
1648 Command_Arg := Command_Arg + 1;
1649
1650 else
1651 exit;
1652 end if;
1653 end loop;
1654
1655 -- If there is no command, just output the usage
1656
1657 if Command_Arg > Argument_Count then
1658 Usage;
1659 return;
1660 end if;
1661
1662 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1663
1664 exception
1665 when Constraint_Error =>
1666
1667 -- Check if it is an alternate command
1668
1669 declare
1670 Alternate : Alternate_Command;
1671
1672 begin
1673 Alternate := Alternate_Command'Value
1674 (Argument (Command_Arg));
1675 The_Command := Corresponding_To (Alternate);
1676
1677 exception
1678 when Constraint_Error =>
1679 Usage;
1680 Fail ("unknown command: " & Argument (Command_Arg));
1681 end;
1682 end;
1683
1684 -- Get the arguments from the command line and from the eventual
1685 -- argument file(s) specified on the command line.
1686
1687 for Arg in Command_Arg + 1 .. Argument_Count loop
1688 declare
1689 The_Arg : constant String := Argument (Arg);
1690
1691 begin
1692 -- Check if an argument file is specified
1693
1694 if The_Arg (The_Arg'First) = '@' then
1695 declare
1696 Arg_File : Ada.Text_IO.File_Type;
1697 Line : String (1 .. 256);
1698 Last : Natural;
1699
1700 begin
1701 -- Open the file and fail if the file cannot be found
1702
1703 begin
1704 Open
1705 (Arg_File, In_File,
1706 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1707
1708 exception
1709 when others =>
1710 Put (Standard_Error, "Cannot open argument file """);
1711 Put (Standard_Error,
1712 The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1713 Put_Line (Standard_Error, """");
1714 raise Error_Exit;
1715 end;
1716
1717 -- Read line by line and put the content of each non-
1718 -- empty line in the Last_Switches table.
1719
1720 while not End_Of_File (Arg_File) loop
1721 Get_Line (Arg_File, Line, Last);
1722
1723 if Last /= 0 then
1724 Last_Switches.Increment_Last;
1725 Last_Switches.Table (Last_Switches.Last) :=
1726 new String'(Line (1 .. Last));
1727 end if;
1728 end loop;
1729
1730 Close (Arg_File);
1731 end;
1732
1733 else
1734 -- It is not an argument file; just put the argument in
1735 -- the Last_Switches table.
1736
1737 Last_Switches.Increment_Last;
1738 Last_Switches.Table (Last_Switches.Last) :=
1739 new String'(The_Arg);
1740 end if;
1741 end;
1742 end loop;
1743
1744 declare
1745 Program : String_Access;
1746 Exec_Path : String_Access;
1747
1748 begin
1749 if The_Command = Stack then
1750
1751 -- Never call gnatstack with a prefix
1752
1753 Program := new String'(Command_List (The_Command).Unixcmd.all);
1754
1755 else
1756 Program :=
1757 Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1758 end if;
1759
1760 -- For the tools where the GNAT driver processes the project files,
1761 -- allow shared library projects to import projects that are not shared
1762 -- library projects, to avoid adding a switch for these tools. For the
1763 -- builder (gnatmake), if a shared library project imports a project
1764 -- that is not a shared library project and the appropriate switch is
1765 -- not specified, the invocation of gnatmake will fail.
1766
1767 Opt.Unchecked_Shared_Lib_Imports := True;
1768
1769 -- Locate the executable for the command
1770
1771 Exec_Path := Locate_Exec_On_Path (Program.all);
1772
1773 if Exec_Path = null then
1774 Put_Line (Standard_Error, "could not locate " & Program.all);
1775 raise Error_Exit;
1776 end if;
1777
1778 -- If there are switches for the executable, put them as first switches
1779
1780 if Command_List (The_Command).Unixsws /= null then
1781 for J in Command_List (The_Command).Unixsws'Range loop
1782 First_Switches.Increment_Last;
1783 First_Switches.Table (First_Switches.Last) :=
1784 Command_List (The_Command).Unixsws (J);
1785 end loop;
1786 end if;
1787
1788 -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1789 -- SYNC and XREF, look for project file related switches.
1790
1791 case The_Command is
1792 when Bind =>
1793 Tool_Package_Name := Name_Binder;
1794 Packages_To_Check := Packages_To_Check_By_Binder;
1795 when Check =>
1796 Tool_Package_Name := Name_Check;
1797 Packages_To_Check := Packages_To_Check_By_Check;
1798 when Elim =>
1799 Tool_Package_Name := Name_Eliminate;
1800 Packages_To_Check := Packages_To_Check_By_Eliminate;
1801 when Find =>
1802 Tool_Package_Name := Name_Finder;
1803 Packages_To_Check := Packages_To_Check_By_Finder;
1804 when Link =>
1805 Tool_Package_Name := Name_Linker;
1806 Packages_To_Check := Packages_To_Check_By_Linker;
1807 when List =>
1808 Tool_Package_Name := Name_Gnatls;
1809 Packages_To_Check := Packages_To_Check_By_Gnatls;
1810 when Metric =>
1811 Tool_Package_Name := Name_Metrics;
1812 Packages_To_Check := Packages_To_Check_By_Metric;
1813 when Pretty =>
1814 Tool_Package_Name := Name_Pretty_Printer;
1815 Packages_To_Check := Packages_To_Check_By_Pretty;
1816 when Stack =>
1817 Tool_Package_Name := Name_Stack;
1818 Packages_To_Check := Packages_To_Check_By_Stack;
1819 when Stub =>
1820 Tool_Package_Name := Name_Gnatstub;
1821 Packages_To_Check := Packages_To_Check_By_Gnatstub;
1822 when Sync =>
1823 Tool_Package_Name := Name_Synchronize;
1824 Packages_To_Check := Packages_To_Check_By_Sync;
1825 when Xref =>
1826 Tool_Package_Name := Name_Cross_Reference;
1827 Packages_To_Check := Packages_To_Check_By_Xref;
1828 when others =>
1829 Tool_Package_Name := No_Name;
1830 end case;
1831
1832 if Tool_Package_Name /= No_Name then
1833
1834 -- Check that the switches are consistent. Detect project file
1835 -- related switches.
1836
1837 Inspect_Switches : declare
1838 Arg_Num : Positive := 1;
1839 Argv : String_Access;
1840
1841 procedure Remove_Switch (Num : Positive);
1842 -- Remove a project related switch from table Last_Switches
1843
1844 -------------------
1845 -- Remove_Switch --
1846 -------------------
1847
1848 procedure Remove_Switch (Num : Positive) is
1849 begin
1850 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1851 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1852 Last_Switches.Decrement_Last;
1853 end Remove_Switch;
1854
1855 -- Start of processing for Inspect_Switches
1856
1857 begin
1858 while Arg_Num <= Last_Switches.Last loop
1859 Argv := Last_Switches.Table (Arg_Num);
1860
1861 if Argv (Argv'First) = '-' then
1862 if Argv'Length = 1 then
1863 Fail
1864 ("switch character cannot be followed by a blank");
1865 end if;
1866
1867 -- The two style project files (-p and -P) cannot be used
1868 -- together
1869
1870 if (The_Command = Find or else The_Command = Xref)
1871 and then Argv (2) = 'p'
1872 then
1873 Old_Project_File_Used := True;
1874 if Project_File /= null then
1875 Fail ("-P and -p cannot be used together");
1876 end if;
1877 end if;
1878
1879 -- --subdirs=... Specify Subdirs
1880
1881 if Argv'Length > Makeutl.Subdirs_Option'Length
1882 and then
1883 Argv
1884 (Argv'First ..
1885 Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1886 Makeutl.Subdirs_Option
1887 then
1888 Subdirs :=
1889 new String'
1890 (Argv
1891 (Argv'First + Makeutl.Subdirs_Option'Length ..
1892 Argv'Last));
1893
1894 Remove_Switch (Arg_Num);
1895
1896 -- -aPdir Add dir to the project search path
1897
1898 elsif Argv'Length > 3
1899 and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
1900 then
1901 Prj.Env.Add_Directories
1902 (Root_Environment.Project_Path,
1903 Argv (Argv'First + 3 .. Argv'Last));
1904
1905 -- Pass -aPdir to gnatls, but not to other tools
1906
1907 if The_Command = List then
1908 Arg_Num := Arg_Num + 1;
1909 else
1910 Remove_Switch (Arg_Num);
1911 end if;
1912
1913 -- -eL Follow links for files
1914
1915 elsif Argv.all = "-eL" then
1916 Follow_Links_For_Files := True;
1917 Follow_Links_For_Dirs := True;
1918
1919 Remove_Switch (Arg_Num);
1920
1921 -- -vPx Specify verbosity while parsing project files
1922
1923 elsif Argv'Length >= 3
1924 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1925 then
1926 if Argv'Length = 4
1927 and then Argv (Argv'Last) in '0' .. '2'
1928 then
1929 case Argv (Argv'Last) is
1930 when '0' =>
1931 Current_Verbosity := Prj.Default;
1932 when '1' =>
1933 Current_Verbosity := Prj.Medium;
1934 when '2' =>
1935 Current_Verbosity := Prj.High;
1936 when others =>
1937
1938 -- Cannot happen
1939
1940 raise Program_Error;
1941 end case;
1942 else
1943 Fail ("invalid verbosity level: "
1944 & Argv (Argv'First + 3 .. Argv'Last));
1945 end if;
1946
1947 Remove_Switch (Arg_Num);
1948
1949 -- -Pproject_file Specify project file to be used
1950
1951 elsif Argv (Argv'First + 1) = 'P' then
1952
1953 -- Only one -P switch can be used
1954
1955 if Project_File /= null then
1956 Fail
1957 (Argv.all
1958 & ": second project file forbidden (first is """
1959 & Project_File.all
1960 & """)");
1961
1962 -- The two style project files (-p and -P) cannot be
1963 -- used together.
1964
1965 elsif Old_Project_File_Used then
1966 Fail ("-p and -P cannot be used together");
1967
1968 elsif Argv'Length = 2 then
1969
1970 -- There is space between -P and the project file
1971 -- name. -P cannot be the last option.
1972
1973 if Arg_Num = Last_Switches.Last then
1974 Fail ("project file name missing after -P");
1975
1976 else
1977 Remove_Switch (Arg_Num);
1978 Argv := Last_Switches.Table (Arg_Num);
1979
1980 -- After -P, there must be a project file name,
1981 -- not another switch.
1982
1983 if Argv (Argv'First) = '-' then
1984 Fail ("project file name missing after -P");
1985
1986 else
1987 Project_File := new String'(Argv.all);
1988 end if;
1989 end if;
1990
1991 else
1992 -- No space between -P and project file name
1993
1994 Project_File :=
1995 new String'(Argv (Argv'First + 2 .. Argv'Last));
1996 end if;
1997
1998 Remove_Switch (Arg_Num);
1999
2000 -- -Xexternal=value Specify an external reference to be
2001 -- used in project files
2002
2003 elsif Argv'Length >= 5
2004 and then Argv (Argv'First + 1) = 'X'
2005 then
2006 if not Check (Root_Environment.External,
2007 Argv (Argv'First + 2 .. Argv'Last))
2008 then
2009 Fail (Argv.all
2010 & " is not a valid external assignment.");
2011 end if;
2012
2013 Remove_Switch (Arg_Num);
2014
2015 elsif
2016 (The_Command = Check or else
2017 The_Command = Sync or else
2018 The_Command = Pretty or else
2019 The_Command = Metric or else
2020 The_Command = Stack or else
2021 The_Command = List)
2022 and then Argv'Length = 2
2023 and then Argv (2) = 'U'
2024 then
2025 All_Projects := True;
2026 Remove_Switch (Arg_Num);
2027
2028 else
2029 Arg_Num := Arg_Num + 1;
2030 end if;
2031
2032 elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
2033 or else The_Command = Sync
2034 or else The_Command = Metric
2035 or else The_Command = Pretty)
2036 and then Project_File /= null
2037 and then All_Projects
2038 then
2039 if ASIS_Main /= null then
2040 Fail ("cannot specify more than one main after -U");
2041 else
2042 ASIS_Main := Argv;
2043 Remove_Switch (Arg_Num);
2044 end if;
2045
2046 else
2047 Arg_Num := Arg_Num + 1;
2048 end if;
2049 end loop;
2050 end Inspect_Switches;
2051 end if;
2052
2053 -- Add the default project search directories now, after the directories
2054 -- that have been specified by switches -aP<dir>.
2055
2056 Prj.Env.Initialize_Default_Project_Path
2057 (Root_Environment.Project_Path,
2058 Target_Name => Sdefault.Target_Name.all);
2059
2060 -- If there is a project file specified, parse it, get the switches
2061 -- for the tool and setup PATH environment variables.
2062
2063 if Project_File /= null then
2064 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
2065
2066 Prj.Pars.Parse
2067 (Project => Project,
2068 In_Tree => Project_Tree,
2069 In_Node_Tree => Project_Node_Tree,
2070 Project_File_Name => Project_File.all,
2071 Env => Root_Environment,
2072 Packages_To_Check => Packages_To_Check);
2073
2074 -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
2075
2076 Set_Standard_Error;
2077
2078 if Project = Prj.No_Project then
2079 Fail ("""" & Project_File.all & """ processing failed");
2080
2081 elsif Project.Qualifier = Aggregate then
2082 Fail ("aggregate projects are not supported");
2083
2084 elsif Aggregate_Libraries_In (Project_Tree) then
2085 Fail ("aggregate library projects are not supported");
2086 end if;
2087
2088 -- Check if a package with the name of the tool is in the project
2089 -- file and if there is one, get the switches, if any, and scan them.
2090
2091 declare
2092 Pkg : constant Prj.Package_Id :=
2093 Prj.Util.Value_Of
2094 (Name => Tool_Package_Name,
2095 In_Packages => Project.Decl.Packages,
2096 Shared => Project_Tree.Shared);
2097
2098 Element : Package_Element;
2099
2100 Switches_Array : Array_Element_Id;
2101
2102 The_Switches : Prj.Variable_Value;
2103 Current : Prj.String_List_Id;
2104 The_String : String_Element;
2105
2106 Main : String_Access := null;
2107
2108 begin
2109 if Pkg /= No_Package then
2110 Element := Project_Tree.Shared.Packages.Table (Pkg);
2111
2112 -- Packages Gnatls and Gnatstack have a single attribute
2113 -- Switches, that is not an associative array.
2114
2115 if The_Command = List or else The_Command = Stack then
2116 The_Switches :=
2117 Prj.Util.Value_Of
2118 (Variable_Name => Snames.Name_Switches,
2119 In_Variables => Element.Decl.Attributes,
2120 Shared => Project_Tree.Shared);
2121
2122 -- Packages Binder (for gnatbind), Cross_Reference (for
2123 -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
2124 -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
2125 -- (for gnatcheck), and Metric (for gnatmetric) have an
2126 -- attributed Switches, an associative array, indexed by the
2127 -- name of the file.
2128
2129 -- They also have an attribute Default_Switches, indexed by the
2130 -- name of the programming language.
2131
2132 else
2133 -- First check if there is a single main
2134
2135 for J in 1 .. Last_Switches.Last loop
2136 if Last_Switches.Table (J) (1) /= '-' then
2137 if Main = null then
2138 Main := Last_Switches.Table (J);
2139
2140 else
2141 Main := null;
2142 exit;
2143 end if;
2144 end if;
2145 end loop;
2146
2147 if Main /= null then
2148 Switches_Array :=
2149 Prj.Util.Value_Of
2150 (Name => Name_Switches,
2151 In_Arrays => Element.Decl.Arrays,
2152 Shared => Project_Tree.Shared);
2153 Name_Len := 0;
2154
2155 -- If the single main has been specified as an absolute
2156 -- path, use only the simple file name. If the absolute
2157 -- path is incorrect, an error will be reported by the
2158 -- underlying tool and it does not make a difference
2159 -- what switches are used.
2160
2161 if Is_Absolute_Path (Main.all) then
2162 Add_Str_To_Name_Buffer (File_Name (Main.all));
2163 else
2164 Add_Str_To_Name_Buffer (Main.all);
2165 end if;
2166
2167 The_Switches := Prj.Util.Value_Of
2168 (Index => Name_Find,
2169 Src_Index => 0,
2170 In_Array => Switches_Array,
2171 Shared => Project_Tree.Shared);
2172 end if;
2173
2174 if The_Switches.Kind = Prj.Undefined then
2175 Switches_Array :=
2176 Prj.Util.Value_Of
2177 (Name => Name_Default_Switches,
2178 In_Arrays => Element.Decl.Arrays,
2179 Shared => Project_Tree.Shared);
2180 The_Switches := Prj.Util.Value_Of
2181 (Index => Name_Ada,
2182 Src_Index => 0,
2183 In_Array => Switches_Array,
2184 Shared => Project_Tree.Shared);
2185 end if;
2186 end if;
2187
2188 -- If there are switches specified in the package of the
2189 -- project file corresponding to the tool, scan them.
2190
2191 case The_Switches.Kind is
2192 when Prj.Undefined =>
2193 null;
2194
2195 when Prj.Single =>
2196 declare
2197 Switch : constant String :=
2198 Get_Name_String (The_Switches.Value);
2199
2200 begin
2201 if Switch'Length > 0 then
2202 First_Switches.Increment_Last;
2203 First_Switches.Table (First_Switches.Last) :=
2204 new String'(Switch);
2205 end if;
2206 end;
2207
2208 when Prj.List =>
2209 Current := The_Switches.Values;
2210 while Current /= Prj.Nil_String loop
2211 The_String := Project_Tree.Shared.String_Elements.
2212 Table (Current);
2213
2214 declare
2215 Switch : constant String :=
2216 Get_Name_String (The_String.Value);
2217
2218 begin
2219 if Switch'Length > 0 then
2220 First_Switches.Increment_Last;
2221 First_Switches.Table (First_Switches.Last) :=
2222 new String'(Switch);
2223 end if;
2224 end;
2225
2226 Current := The_String.Next;
2227 end loop;
2228 end case;
2229 end if;
2230 end;
2231
2232 if The_Command = Bind or else
2233 The_Command = Link or else
2234 The_Command = Elim
2235 then
2236 if Project.Object_Directory.Name = No_Path then
2237 Fail ("project " & Get_Name_String (Project.Display_Name)
2238 & " has no object directory");
2239 end if;
2240
2241 Change_Dir (Get_Name_String (Project.Object_Directory.Name));
2242 end if;
2243
2244 -- Set up the env vars for project path files
2245
2246 Prj.Env.Set_Ada_Paths
2247 (Project, Project_Tree, Including_Libraries => True);
2248
2249 -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
2250 -- a configuration pragmas file, if necessary.
2251
2252 if The_Command = Pretty
2253 or else The_Command = Metric
2254 or else The_Command = Stub
2255 or else The_Command = Elim
2256 or else The_Command = Check
2257 or else The_Command = Sync
2258 then
2259 -- If there are switches in package Compiler, put them in the
2260 -- Carg_Switches table.
2261
2262 declare
2263 Pkg : constant Prj.Package_Id :=
2264 Prj.Util.Value_Of
2265 (Name => Name_Compiler,
2266 In_Packages => Project.Decl.Packages,
2267 Shared => Project_Tree.Shared);
2268
2269 Element : Package_Element;
2270
2271 Switches_Array : Array_Element_Id;
2272
2273 The_Switches : Prj.Variable_Value;
2274 Current : Prj.String_List_Id;
2275 The_String : String_Element;
2276
2277 Main : String_Access := null;
2278 Main_Id : Name_Id;
2279
2280 begin
2281 if Pkg /= No_Package then
2282
2283 -- First, check if there is a single main specified
2284
2285 for J in 1 .. Last_Switches.Last loop
2286 if Last_Switches.Table (J) (1) /= '-' then
2287 if Main = null then
2288 Main := Last_Switches.Table (J);
2289
2290 else
2291 Main := null;
2292 exit;
2293 end if;
2294 end if;
2295 end loop;
2296
2297 Element := Project_Tree.Shared.Packages.Table (Pkg);
2298
2299 -- If there is a single main and there is compilation
2300 -- switches specified in the project file, use them.
2301
2302 if Main /= null and then not All_Projects then
2303 Name_Len := Main'Length;
2304 Name_Buffer (1 .. Name_Len) := Main.all;
2305 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2306 Main_Id := Name_Find;
2307
2308 Switches_Array :=
2309 Prj.Util.Value_Of
2310 (Name => Name_Switches,
2311 In_Arrays => Element.Decl.Arrays,
2312 Shared => Project_Tree.Shared);
2313 The_Switches := Prj.Util.Value_Of
2314 (Index => Main_Id,
2315 Src_Index => 0,
2316 In_Array => Switches_Array,
2317 Shared => Project_Tree.Shared);
2318 end if;
2319
2320 -- Otherwise, get the Default_Switches ("Ada")
2321
2322 if The_Switches.Kind = Undefined then
2323 Switches_Array :=
2324 Prj.Util.Value_Of
2325 (Name => Name_Default_Switches,
2326 In_Arrays => Element.Decl.Arrays,
2327 Shared => Project_Tree.Shared);
2328 The_Switches := Prj.Util.Value_Of
2329 (Index => Name_Ada,
2330 Src_Index => 0,
2331 In_Array => Switches_Array,
2332 Shared => Project_Tree.Shared);
2333 end if;
2334
2335 -- If there are switches specified, put them in the
2336 -- Carg_Switches table.
2337
2338 case The_Switches.Kind is
2339 when Prj.Undefined =>
2340 null;
2341
2342 when Prj.Single =>
2343 declare
2344 Switch : constant String :=
2345 Get_Name_String (The_Switches.Value);
2346 begin
2347 if Switch'Length > 0 then
2348 Add_To_Carg_Switches (new String'(Switch));
2349 end if;
2350 end;
2351
2352 when Prj.List =>
2353 Current := The_Switches.Values;
2354 while Current /= Prj.Nil_String loop
2355 The_String := Project_Tree.Shared.String_Elements
2356 .Table (Current);
2357
2358 declare
2359 Switch : constant String :=
2360 Get_Name_String (The_String.Value);
2361 begin
2362 if Switch'Length > 0 then
2363 Add_To_Carg_Switches (new String'(Switch));
2364 end if;
2365 end;
2366
2367 Current := The_String.Next;
2368 end loop;
2369 end case;
2370 end if;
2371 end;
2372
2373 -- If -cargs is one of the switches, move the following switches
2374 -- to the Carg_Switches table.
2375
2376 for J in 1 .. First_Switches.Last loop
2377 if First_Switches.Table (J).all = "-cargs" then
2378 declare
2379 K : Positive;
2380 Last : Natural;
2381
2382 begin
2383 -- Move the switches that are before -rules when the
2384 -- command is CHECK.
2385
2386 K := J + 1;
2387 while K <= First_Switches.Last
2388 and then
2389 (The_Command /= Check
2390 or else First_Switches.Table (K).all /= "-rules")
2391 loop
2392 Add_To_Carg_Switches (First_Switches.Table (K));
2393 K := K + 1;
2394 end loop;
2395
2396 if K > First_Switches.Last then
2397 First_Switches.Set_Last (J - 1);
2398
2399 else
2400 Last := J - 1;
2401 while K <= First_Switches.Last loop
2402 Last := Last + 1;
2403 First_Switches.Table (Last) :=
2404 First_Switches.Table (K);
2405 K := K + 1;
2406 end loop;
2407
2408 First_Switches.Set_Last (Last);
2409 end if;
2410 end;
2411
2412 exit;
2413 end if;
2414 end loop;
2415
2416 for J in 1 .. Last_Switches.Last loop
2417 if Last_Switches.Table (J).all = "-cargs" then
2418 declare
2419 K : Positive;
2420 Last : Natural;
2421
2422 begin
2423 -- Move the switches that are before -rules when the
2424 -- command is CHECK.
2425
2426 K := J + 1;
2427 while K <= Last_Switches.Last
2428 and then
2429 (The_Command /= Check
2430 or else Last_Switches.Table (K).all /= "-rules")
2431 loop
2432 Add_To_Carg_Switches (Last_Switches.Table (K));
2433 K := K + 1;
2434 end loop;
2435
2436 if K > Last_Switches.Last then
2437 Last_Switches.Set_Last (J - 1);
2438
2439 else
2440 Last := J - 1;
2441 while K <= Last_Switches.Last loop
2442 Last := Last + 1;
2443 Last_Switches.Table (Last) :=
2444 Last_Switches.Table (K);
2445 K := K + 1;
2446 end loop;
2447
2448 Last_Switches.Set_Last (Last);
2449 end if;
2450 end;
2451
2452 exit;
2453 end if;
2454 end loop;
2455
2456 declare
2457 CP_File : constant Path_Name_Type := Configuration_Pragmas_File;
2458 M_File : constant Path_Name_Type := Mapping_File;
2459
2460 begin
2461 if CP_File /= No_Path then
2462 if The_Command = Elim then
2463 First_Switches.Increment_Last;
2464 First_Switches.Table (First_Switches.Last) :=
2465 new String'("-C" & Get_Name_String (CP_File));
2466
2467 else
2468 Add_To_Carg_Switches
2469 (new String'("-gnatec=" & Get_Name_String (CP_File)));
2470 end if;
2471 end if;
2472
2473 if M_File /= No_Path then
2474 Add_To_Carg_Switches
2475 (new String'("-gnatem=" & Get_Name_String (M_File)));
2476 end if;
2477
2478 -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
2479 -- indicate a global configuration pragmas file and, if -U
2480 -- is not used, a local one.
2481
2482 if The_Command = Check or else
2483 The_Command = Pretty or else
2484 The_Command = Stub or else
2485 The_Command = Metric
2486 then
2487 declare
2488 Pkg : constant Prj.Package_Id :=
2489 Prj.Util.Value_Of
2490 (Name => Name_Builder,
2491 In_Packages => Project.Decl.Packages,
2492 Shared => Project_Tree.Shared);
2493
2494 Variable : Variable_Value :=
2495 Prj.Util.Value_Of
2496 (Name => No_Name,
2497 Attribute_Or_Array_Name =>
2498 Name_Global_Configuration_Pragmas,
2499 In_Package => Pkg,
2500 Shared => Project_Tree.Shared);
2501
2502 begin
2503 if (Variable = Nil_Variable_Value
2504 or else Length_Of_Name (Variable.Value) = 0)
2505 and then Pkg /= No_Package
2506 then
2507 Variable :=
2508 Prj.Util.Value_Of
2509 (Name => Name_Ada,
2510 Attribute_Or_Array_Name =>
2511 Name_Global_Config_File,
2512 In_Package => Pkg,
2513 Shared => Project_Tree.Shared);
2514 end if;
2515
2516 if Variable /= Nil_Variable_Value
2517 and then Length_Of_Name (Variable.Value) /= 0
2518 then
2519 declare
2520 Path : constant String :=
2521 Absolute_Path
2522 (Path_Name_Type (Variable.Value),
2523 Variable.Project);
2524 begin
2525 Add_To_Carg_Switches
2526 (new String'("-gnatec=" & Path));
2527 end;
2528 end if;
2529 end;
2530
2531 if not All_Projects then
2532 declare
2533 Pkg : constant Prj.Package_Id :=
2534 Prj.Util.Value_Of
2535 (Name => Name_Compiler,
2536 In_Packages => Project.Decl.Packages,
2537 Shared => Project_Tree.Shared);
2538
2539 Variable : Variable_Value :=
2540 Prj.Util.Value_Of
2541 (Name => No_Name,
2542 Attribute_Or_Array_Name =>
2543 Name_Local_Configuration_Pragmas,
2544 In_Package => Pkg,
2545 Shared => Project_Tree.Shared);
2546
2547 begin
2548 if (Variable = Nil_Variable_Value
2549 or else Length_Of_Name (Variable.Value) = 0)
2550 and then Pkg /= No_Package
2551 then
2552 Variable :=
2553 Prj.Util.Value_Of
2554 (Name => Name_Ada,
2555 Attribute_Or_Array_Name =>
2556 Name_Local_Config_File,
2557 In_Package => Pkg,
2558 Shared =>
2559 Project_Tree.Shared);
2560 end if;
2561
2562 if Variable /= Nil_Variable_Value
2563 and then Length_Of_Name (Variable.Value) /= 0
2564 then
2565 declare
2566 Path : constant String :=
2567 Absolute_Path
2568 (Path_Name_Type (Variable.Value),
2569 Variable.Project);
2570 begin
2571 Add_To_Carg_Switches
2572 (new String'("-gnatec=" & Path));
2573 end;
2574 end if;
2575 end;
2576 end if;
2577 end if;
2578 end;
2579 end if;
2580
2581 if The_Command = Link then
2582 Process_Link;
2583 end if;
2584
2585 if The_Command = Link or else The_Command = Bind then
2586
2587 -- For files that are specified as relative paths with directory
2588 -- information, we convert them to absolute paths, with parent
2589 -- being the current working directory if specified on the command
2590 -- line and the project directory if specified in the project
2591 -- file. This is what gnatmake is doing for linker and binder
2592 -- arguments.
2593
2594 for J in 1 .. Last_Switches.Last loop
2595 GNATCmd.Ensure_Absolute_Path
2596 (Last_Switches.Table (J), Current_Work_Dir);
2597 end loop;
2598
2599 Get_Name_String (Project.Directory.Name);
2600
2601 declare
2602 Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2603 begin
2604 for J in 1 .. First_Switches.Last loop
2605 GNATCmd.Ensure_Absolute_Path
2606 (First_Switches.Table (J), Project_Dir);
2607 end loop;
2608 end;
2609
2610 elsif The_Command = Stub then
2611 declare
2612 File_Index : Integer := 0;
2613 Dir_Index : Integer := 0;
2614 Last : constant Integer := Last_Switches.Last;
2615 Lang : constant Language_Ptr :=
2616 Get_Language_From_Name (Project, "ada");
2617
2618 begin
2619 for Index in 1 .. Last loop
2620 if Last_Switches.Table (Index)
2621 (Last_Switches.Table (Index)'First) /= '-'
2622 then
2623 File_Index := Index;
2624 exit;
2625 end if;
2626 end loop;
2627
2628 -- If the project file naming scheme is not standard, and if
2629 -- the file name ends with the spec suffix, then indicate to
2630 -- gnatstub the name of the body file with a -o switch.
2631
2632 if Lang /= No_Language_Index
2633 and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data)
2634 then
2635 if File_Index /= 0 then
2636 declare
2637 Spec : constant String :=
2638 Base_Name
2639 (Last_Switches.Table (File_Index).all);
2640 Last : Natural := Spec'Last;
2641
2642 begin
2643 Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2644
2645 if Spec'Length > Name_Len
2646 and then Spec (Last - Name_Len + 1 .. Last) =
2647 Name_Buffer (1 .. Name_Len)
2648 then
2649 Last := Last - Name_Len;
2650 Get_Name_String
2651 (Lang.Config.Naming_Data.Body_Suffix);
2652 Last_Switches.Increment_Last;
2653 Last_Switches.Table (Last_Switches.Last) :=
2654 new String'("-o");
2655 Last_Switches.Increment_Last;
2656 Last_Switches.Table (Last_Switches.Last) :=
2657 new String'(Spec (Spec'First .. Last) &
2658 Name_Buffer (1 .. Name_Len));
2659 end if;
2660 end;
2661 end if;
2662 end if;
2663
2664 -- Add the directory of the spec as the destination directory
2665 -- of the body, if there is no destination directory already
2666 -- specified.
2667
2668 if File_Index /= 0 then
2669 for Index in File_Index + 1 .. Last loop
2670 if Last_Switches.Table (Index)
2671 (Last_Switches.Table (Index)'First) /= '-'
2672 then
2673 Dir_Index := Index;
2674 exit;
2675 end if;
2676 end loop;
2677
2678 if Dir_Index = 0 then
2679 Last_Switches.Increment_Last;
2680 Last_Switches.Table (Last_Switches.Last) :=
2681 new String'
2682 (Dir_Name (Last_Switches.Table (File_Index).all));
2683 end if;
2684 end if;
2685 end;
2686 end if;
2687
2688 -- For gnatmetric, the generated files should be put in the object
2689 -- directory. This must be the first switch, because it may be
2690 -- overridden by a switch in package Metrics in the project file or
2691 -- by a command line option. Note that we don't add the -d= switch
2692 -- if there is no object directory available.
2693
2694 if The_Command = Metric
2695 and then Project.Object_Directory /= No_Path_Information
2696 then
2697 First_Switches.Increment_Last;
2698 First_Switches.Table (2 .. First_Switches.Last) :=
2699 First_Switches.Table (1 .. First_Switches.Last - 1);
2700 First_Switches.Table (1) :=
2701 new String'("-d=" &
2702 Get_Name_String (Project.Object_Directory.Name));
2703 end if;
2704
2705 -- For gnat check, -rules and the following switches need to be the
2706 -- last options, so move all these switches to table Rules_Switches.
2707
2708 if The_Command = Check then
2709 declare
2710 New_Last : Natural;
2711 -- Set to rank of options preceding "-rules"
2712
2713 In_Rules_Switches : Boolean;
2714 -- Set to True when options "-rules" is found
2715
2716 begin
2717 New_Last := First_Switches.Last;
2718 In_Rules_Switches := False;
2719
2720 for J in 1 .. First_Switches.Last loop
2721 if In_Rules_Switches then
2722 Add_To_Rules_Switches (First_Switches.Table (J));
2723
2724 elsif First_Switches.Table (J).all = "-rules" then
2725 New_Last := J - 1;
2726 In_Rules_Switches := True;
2727 end if;
2728 end loop;
2729
2730 if In_Rules_Switches then
2731 First_Switches.Set_Last (New_Last);
2732 end if;
2733
2734 New_Last := Last_Switches.Last;
2735 In_Rules_Switches := False;
2736
2737 for J in 1 .. Last_Switches.Last loop
2738 if In_Rules_Switches then
2739 Add_To_Rules_Switches (Last_Switches.Table (J));
2740
2741 elsif Last_Switches.Table (J).all = "-rules" then
2742 New_Last := J - 1;
2743 In_Rules_Switches := True;
2744 end if;
2745 end loop;
2746
2747 if In_Rules_Switches then
2748 Last_Switches.Set_Last (New_Last);
2749 end if;
2750 end;
2751 end if;
2752
2753 -- For gnat check, sync, metric or pretty with -U + a main, get the
2754 -- list of sources from the closure and add them to the arguments.
2755
2756 if ASIS_Main /= null then
2757 Get_Closure;
2758
2759 -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2760 -- and gnat stack, if no file has been put on the command line, call
2761 -- tool with all the sources of the main project.
2762
2763 elsif The_Command = Check or else
2764 The_Command = Sync or else
2765 The_Command = Pretty or else
2766 The_Command = Metric or else
2767 The_Command = List or else
2768 The_Command = Stack
2769 then
2770 Check_Files;
2771 end if;
2772 end if;
2773
2774 -- Gather all the arguments and invoke the executable
2775
2776 declare
2777 The_Args : Argument_List
2778 (1 .. First_Switches.Last +
2779 Last_Switches.Last +
2780 Carg_Switches.Last +
2781 Rules_Switches.Last);
2782 Arg_Num : Natural := 0;
2783
2784 begin
2785 for J in 1 .. First_Switches.Last loop
2786 Arg_Num := Arg_Num + 1;
2787 The_Args (Arg_Num) := First_Switches.Table (J);
2788 end loop;
2789
2790 for J in 1 .. Last_Switches.Last loop
2791 Arg_Num := Arg_Num + 1;
2792 The_Args (Arg_Num) := Last_Switches.Table (J);
2793 end loop;
2794
2795 for J in 1 .. Carg_Switches.Last loop
2796 Arg_Num := Arg_Num + 1;
2797 The_Args (Arg_Num) := Carg_Switches.Table (J);
2798 end loop;
2799
2800 for J in 1 .. Rules_Switches.Last loop
2801 Arg_Num := Arg_Num + 1;
2802 The_Args (Arg_Num) := Rules_Switches.Table (J);
2803 end loop;
2804
2805 if Verbose_Mode then
2806 Output.Write_Str (Exec_Path.all);
2807
2808 for Arg in The_Args'Range loop
2809 Output.Write_Char (' ');
2810 Output.Write_Str (The_Args (Arg).all);
2811 end loop;
2812
2813 Output.Write_Eol;
2814 end if;
2815
2816 My_Exit_Status :=
2817 Exit_Status (Spawn (Exec_Path.all, The_Args));
2818 raise Normal_Exit;
2819 end;
2820 end;
2821
2822 exception
2823 when Error_Exit =>
2824 if not Keep_Temporary_Files then
2825 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2826 Delete_Temp_Config_Files;
2827 end if;
2828
2829 Set_Exit_Status (Failure);
2830
2831 when Normal_Exit =>
2832 if not Keep_Temporary_Files then
2833 Prj.Delete_All_Temp_Files (Project_Tree.Shared);
2834 Delete_Temp_Config_Files;
2835 end if;
2836
2837 Set_Exit_Status (My_Exit_Status);
2838 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org