OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [gnatcmd.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.