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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-conf.adb] - Blame information for rev 778

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             P R J . C O N F                             --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--            Copyright (C) 2006-2012, 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 Hostparm;
27
with Makeutl;  use Makeutl;
28
with MLib.Tgt;
29
with Opt;      use Opt;
30
with Output;   use Output;
31
with Prj.Env;
32
with Prj.Err;
33
with Prj.Part;
34
with Prj.PP;
35
with Prj.Proc; use Prj.Proc;
36
with Prj.Tree; use Prj.Tree;
37
with Prj.Util; use Prj.Util;
38
with Prj;      use Prj;
39
with Snames;   use Snames;
40
 
41
with Ada.Directories; use Ada.Directories;
42
with Ada.Exceptions;  use Ada.Exceptions;
43
 
44
with GNAT.Case_Util; use GNAT.Case_Util;
45
with GNAT.HTable;    use GNAT.HTable;
46
 
47
package body Prj.Conf is
48
 
49
   Auto_Cgpr : constant String := "auto.cgpr";
50
 
51
   Default_Name : constant String := "default.cgpr";
52
   --  Default configuration file that will be used if found
53
 
54
   Config_Project_Env_Var : constant String := "GPR_CONFIG";
55
   --  Name of the environment variable that provides the name of the
56
   --  configuration file to use.
57
 
58
   Gprconfig_Name : constant String := "gprconfig";
59
 
60
   package RTS_Languages is new GNAT.HTable.Simple_HTable
61
     (Header_Num => Prj.Header_Num,
62
      Element    => Name_Id,
63
      No_Element => No_Name,
64
      Key        => Name_Id,
65
      Hash       => Prj.Hash,
66
      Equal      => "=");
67
   --  Stores the runtime names for the various languages. This is in general
68
   --  set from a --RTS command line option.
69
 
70
   -----------------------
71
   -- Local_Subprograms --
72
   -----------------------
73
 
74
   procedure Add_Attributes
75
     (Project_Tree : Project_Tree_Ref;
76
      Conf_Decl    : Declarations;
77
      User_Decl    : in out Declarations);
78
   --  Process the attributes in the config declarations.
79
   --  For single string values, if the attribute is not declared in the user
80
   --  declarations, declare it with the value in the config declarations.
81
   --  For string list values, prepend the value in the user declarations with
82
   --  the value in the config declarations.
83
 
84
   function Check_Target
85
     (Config_File        : Prj.Project_Id;
86
      Autoconf_Specified : Boolean;
87
      Project_Tree       : Prj.Project_Tree_Ref;
88
      Target             : String := "") return Boolean;
89
   --  Check that the config file's target matches Target.
90
   --  Target should be set to the empty string when the user did not specify
91
   --  a target. If the target in the configuration file is invalid, this
92
   --  function will raise Invalid_Config with an appropriate message.
93
   --  Autoconf_Specified should be set to True if the user has used
94
   --  autoconf.
95
 
96
   function Locate_Config_File (Name : String) return String_Access;
97
   --  Search for Name in the config files directory. Return full path if
98
   --  found, or null otherwise.
99
 
100
   procedure Raise_Invalid_Config (Msg : String);
101
   pragma No_Return (Raise_Invalid_Config);
102
   --  Raises exception Invalid_Config with given message
103
 
104
   procedure Apply_Config_File
105
     (Config_File  : Prj.Project_Id;
106
      Project_Tree : Prj.Project_Tree_Ref);
107
   --  Apply the configuration file settings to all the projects in the
108
   --  project tree. The Project_Tree must have been parsed first, and
109
   --  processed through the first phase so that all its projects are known.
110
   --
111
   --  Currently, this will add new attributes and packages in the various
112
   --  projects, so that when the second phase of the processing is performed
113
   --  these attributes are automatically taken into account.
114
 
115
   --------------------
116
   -- Add_Attributes --
117
   --------------------
118
 
119
   procedure Add_Attributes
120
     (Project_Tree : Project_Tree_Ref;
121
      Conf_Decl    : Declarations;
122
      User_Decl    : in out Declarations)
123
   is
124
      Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
125
      Conf_Attr_Id       : Variable_Id;
126
      Conf_Attr          : Variable;
127
      Conf_Array_Id      : Array_Id;
128
      Conf_Array         : Array_Data;
129
      Conf_Array_Elem_Id : Array_Element_Id;
130
      Conf_Array_Elem    : Array_Element;
131
      Conf_List          : String_List_Id;
132
      Conf_List_Elem     : String_Element;
133
 
134
      User_Attr_Id       : Variable_Id;
135
      User_Attr          : Variable;
136
      User_Array_Id      : Array_Id;
137
      User_Array         : Array_Data;
138
      User_Array_Elem_Id : Array_Element_Id;
139
      User_Array_Elem    : Array_Element;
140
 
141
   begin
142
      Conf_Attr_Id := Conf_Decl.Attributes;
143
      User_Attr_Id := User_Decl.Attributes;
144
      while Conf_Attr_Id /= No_Variable loop
145
         Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
146
         User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
147
 
148
         if not Conf_Attr.Value.Default then
149
            if User_Attr.Value.Default then
150
 
151
               --  No attribute declared in user project file: just copy the
152
               --  value of the configuration attribute.
153
 
154
               User_Attr.Value := Conf_Attr.Value;
155
               Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
156
 
157
            elsif User_Attr.Value.Kind = List
158
              and then Conf_Attr.Value.Values /= Nil_String
159
            then
160
               --  List attribute declared in both the user project and the
161
               --  configuration project: prepend the user list with the
162
               --  configuration list.
163
 
164
               declare
165
                  User_List : constant String_List_Id :=
166
                                User_Attr.Value.Values;
167
                  Conf_List : String_List_Id := Conf_Attr.Value.Values;
168
                  Conf_Elem : String_Element;
169
                  New_List  : String_List_Id;
170
                  New_Elem  : String_Element;
171
 
172
               begin
173
                  --  Create new list
174
 
175
                  String_Element_Table.Increment_Last
176
                    (Shared.String_Elements);
177
                  New_List :=
178
                    String_Element_Table.Last (Shared.String_Elements);
179
 
180
                  --  Value of attribute is new list
181
 
182
                  User_Attr.Value.Values := New_List;
183
                  Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
184
 
185
                  loop
186
                     --  Get each element of configuration list
187
 
188
                     Conf_Elem := Shared.String_Elements.Table (Conf_List);
189
                     New_Elem  := Conf_Elem;
190
                     Conf_List := Conf_Elem.Next;
191
 
192
                     if Conf_List = Nil_String then
193
 
194
                        --  If it is the last element in the list, connect to
195
                        --  first element of user list, and we are done.
196
 
197
                        New_Elem.Next := User_List;
198
                        Shared.String_Elements.Table (New_List) := New_Elem;
199
                        exit;
200
 
201
                     else
202
                        --  If it is not the last element in the list, add to
203
                        --  new list.
204
 
205
                        String_Element_Table.Increment_Last
206
                          (Shared.String_Elements);
207
                        New_Elem.Next :=
208
                          String_Element_Table.Last (Shared.String_Elements);
209
                        Shared.String_Elements.Table (New_List) := New_Elem;
210
                        New_List := New_Elem.Next;
211
                     end if;
212
                  end loop;
213
               end;
214
            end if;
215
         end if;
216
 
217
         Conf_Attr_Id := Conf_Attr.Next;
218
         User_Attr_Id := User_Attr.Next;
219
      end loop;
220
 
221
      Conf_Array_Id := Conf_Decl.Arrays;
222
      while Conf_Array_Id /= No_Array loop
223
         Conf_Array := Shared.Arrays.Table (Conf_Array_Id);
224
 
225
         User_Array_Id := User_Decl.Arrays;
226
         while User_Array_Id /= No_Array loop
227
            User_Array := Shared.Arrays.Table (User_Array_Id);
228
            exit when User_Array.Name = Conf_Array.Name;
229
            User_Array_Id := User_Array.Next;
230
         end loop;
231
 
232
         --  If this associative array does not exist in the user project file,
233
         --  do a shallow copy of the full associative array.
234
 
235
         if User_Array_Id = No_Array then
236
            Array_Table.Increment_Last (Shared.Arrays);
237
            User_Array := Conf_Array;
238
            User_Array.Next := User_Decl.Arrays;
239
            User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
240
            Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
241
 
242
         --  Otherwise, check each array element
243
 
244
         else
245
            Conf_Array_Elem_Id := Conf_Array.Value;
246
            while Conf_Array_Elem_Id /= No_Array_Element loop
247
               Conf_Array_Elem :=
248
                 Shared.Array_Elements.Table (Conf_Array_Elem_Id);
249
 
250
               User_Array_Elem_Id := User_Array.Value;
251
               while User_Array_Elem_Id /= No_Array_Element loop
252
                  User_Array_Elem :=
253
                    Shared.Array_Elements.Table (User_Array_Elem_Id);
254
                  exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
255
                  User_Array_Elem_Id := User_Array_Elem.Next;
256
               end loop;
257
 
258
               --  If the array element doesn't exist in the user array, insert
259
               --  a shallow copy of the conf array element in the user array.
260
 
261
               if User_Array_Elem_Id = No_Array_Element then
262
                  Array_Element_Table.Increment_Last (Shared.Array_Elements);
263
                  User_Array_Elem := Conf_Array_Elem;
264
                  User_Array_Elem.Next := User_Array.Value;
265
                  User_Array.Value :=
266
                    Array_Element_Table.Last (Shared.Array_Elements);
267
                  Shared.Array_Elements.Table (User_Array.Value) :=
268
                    User_Array_Elem;
269
                  Shared.Arrays.Table (User_Array_Id) := User_Array;
270
 
271
               --  Otherwise, if the value is a string list, prepend the conf
272
               --  array element value to the array element.
273
 
274
               elsif Conf_Array_Elem.Value.Kind = List then
275
                  Conf_List := Conf_Array_Elem.Value.Values;
276
 
277
                  if Conf_List /= Nil_String then
278
                     declare
279
                        Link     : constant String_List_Id :=
280
                                     User_Array_Elem.Value.Values;
281
                        Previous : String_List_Id := Nil_String;
282
                        Next     : String_List_Id;
283
 
284
                     begin
285
                        loop
286
                           Conf_List_Elem :=
287
                             Shared.String_Elements.Table (Conf_List);
288
                           String_Element_Table.Increment_Last
289
                             (Shared.String_Elements);
290
                           Next :=
291
                             String_Element_Table.Last
292
                               (Shared.String_Elements);
293
                           Shared.String_Elements.Table (Next) :=
294
                             Conf_List_Elem;
295
 
296
                           if Previous = Nil_String then
297
                              User_Array_Elem.Value.Values := Next;
298
                              Shared.Array_Elements.Table
299
                                (User_Array_Elem_Id) := User_Array_Elem;
300
 
301
                           else
302
                              Shared.String_Elements.Table
303
                                (Previous).Next := Next;
304
                           end if;
305
 
306
                           Previous := Next;
307
 
308
                           Conf_List := Conf_List_Elem.Next;
309
 
310
                           if Conf_List = Nil_String then
311
                              Shared.String_Elements.Table (Previous).Next :=
312
                                Link;
313
                              exit;
314
                           end if;
315
                        end loop;
316
                     end;
317
                  end if;
318
               end if;
319
 
320
               Conf_Array_Elem_Id := Conf_Array_Elem.Next;
321
            end loop;
322
         end if;
323
 
324
         Conf_Array_Id := Conf_Array.Next;
325
      end loop;
326
   end Add_Attributes;
327
 
328
   ------------------------------------
329
   -- Add_Default_GNAT_Naming_Scheme --
330
   ------------------------------------
331
 
332
   procedure Add_Default_GNAT_Naming_Scheme
333
     (Config_File  : in out Project_Node_Id;
334
      Project_Tree : Project_Node_Tree_Ref)
335
   is
336
      procedure Create_Attribute
337
        (Name  : Name_Id;
338
         Value : String;
339
         Index : String := "";
340
         Pkg   : Project_Node_Id := Empty_Node);
341
 
342
      ----------------------
343
      -- Create_Attribute --
344
      ----------------------
345
 
346
      procedure Create_Attribute
347
        (Name  : Name_Id;
348
         Value : String;
349
         Index : String := "";
350
         Pkg   : Project_Node_Id := Empty_Node)
351
      is
352
         Attr : Project_Node_Id;
353
         pragma Unreferenced (Attr);
354
 
355
         Expr   : Name_Id         := No_Name;
356
         Val    : Name_Id         := No_Name;
357
         Parent : Project_Node_Id := Config_File;
358
 
359
      begin
360
         if Index /= "" then
361
            Name_Len := Index'Length;
362
            Name_Buffer (1 .. Name_Len) := Index;
363
            Val := Name_Find;
364
         end if;
365
 
366
         if Pkg /= Empty_Node then
367
            Parent := Pkg;
368
         end if;
369
 
370
         Name_Len := Value'Length;
371
         Name_Buffer (1 .. Name_Len) := Value;
372
         Expr := Name_Find;
373
 
374
         Attr := Create_Attribute
375
           (Tree       => Project_Tree,
376
            Prj_Or_Pkg => Parent,
377
            Name       => Name,
378
            Index_Name => Val,
379
            Kind       => Prj.Single,
380
            Value      => Create_Literal_String (Expr, Project_Tree));
381
      end Create_Attribute;
382
 
383
      --  Local variables
384
 
385
      Name     : Name_Id;
386
      Naming   : Project_Node_Id;
387
      Compiler : Project_Node_Id;
388
 
389
   --  Start of processing for Add_Default_GNAT_Naming_Scheme
390
 
391
   begin
392
      if Config_File = Empty_Node then
393
 
394
         --  Create a dummy config file is none was found
395
 
396
         Name_Len := Auto_Cgpr'Length;
397
         Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
398
         Name := Name_Find;
399
 
400
         --  An invalid project name to avoid conflicts with user-created ones
401
 
402
         Name_Len := 5;
403
         Name_Buffer (1 .. Name_Len) := "_auto";
404
 
405
         Config_File :=
406
           Create_Project
407
             (In_Tree        => Project_Tree,
408
              Name           => Name_Find,
409
              Full_Path      => Path_Name_Type (Name),
410
              Is_Config_File => True);
411
 
412
         --  Setup library support
413
 
414
         case MLib.Tgt.Support_For_Libraries is
415
            when None =>
416
               null;
417
 
418
            when Static_Only =>
419
               Create_Attribute (Name_Library_Support, "static_only");
420
 
421
            when Full =>
422
               Create_Attribute (Name_Library_Support, "full");
423
         end case;
424
 
425
         if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
426
            Create_Attribute (Name_Library_Auto_Init_Supported, "true");
427
         else
428
            Create_Attribute (Name_Library_Auto_Init_Supported, "false");
429
         end if;
430
 
431
         --  Setup Ada support (Ada is the default language here, since this
432
         --  is only called when no config file existed initially, ie for
433
         --  gnatmake).
434
 
435
         Create_Attribute (Name_Default_Language, "ada");
436
 
437
         Compiler := Create_Package (Project_Tree, Config_File, "compiler");
438
         Create_Attribute
439
           (Name_Driver, "gcc", "ada", Pkg => Compiler);
440
         Create_Attribute
441
           (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
442
         Create_Attribute
443
           (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
444
 
445
         Naming := Create_Package (Project_Tree, Config_File, "naming");
446
         Create_Attribute (Name_Spec_Suffix, ".ads", "ada",     Pkg => Naming);
447
         Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
448
         Create_Attribute (Name_Body_Suffix, ".adb", "ada",     Pkg => Naming);
449
         Create_Attribute (Name_Dot_Replacement, "-",           Pkg => Naming);
450
         Create_Attribute (Name_Casing,          "lowercase",   Pkg => Naming);
451
 
452
         if Current_Verbosity = High then
453
            Write_Line ("Automatically generated (in-memory) config file");
454
            Prj.PP.Pretty_Print
455
              (Project                => Config_File,
456
               In_Tree                => Project_Tree,
457
               Backward_Compatibility => False);
458
         end if;
459
      end if;
460
   end Add_Default_GNAT_Naming_Scheme;
461
 
462
   -----------------------
463
   -- Apply_Config_File --
464
   -----------------------
465
 
466
   procedure Apply_Config_File
467
     (Config_File  : Prj.Project_Id;
468
      Project_Tree : Prj.Project_Tree_Ref)
469
   is
470
      Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
471
 
472
      Conf_Decl    : constant Declarations := Config_File.Decl;
473
      Conf_Pack_Id : Package_Id;
474
      Conf_Pack    : Package_Element;
475
 
476
      User_Decl    : Declarations;
477
      User_Pack_Id : Package_Id;
478
      User_Pack    : Package_Element;
479
      Proj         : Project_List;
480
 
481
   begin
482
      Debug_Output ("Applying config file to a project tree");
483
 
484
      Proj := Project_Tree.Projects;
485
      while Proj /= null loop
486
         if Proj.Project /= Config_File then
487
            User_Decl := Proj.Project.Decl;
488
            Add_Attributes
489
              (Project_Tree      => Project_Tree,
490
               Conf_Decl         => Conf_Decl,
491
               User_Decl         => User_Decl);
492
 
493
            Conf_Pack_Id := Conf_Decl.Packages;
494
            while Conf_Pack_Id /= No_Package loop
495
               Conf_Pack := Shared.Packages.Table (Conf_Pack_Id);
496
 
497
               User_Pack_Id := User_Decl.Packages;
498
               while User_Pack_Id /= No_Package loop
499
                  User_Pack := Shared.Packages.Table (User_Pack_Id);
500
                  exit when User_Pack.Name = Conf_Pack.Name;
501
                  User_Pack_Id := User_Pack.Next;
502
               end loop;
503
 
504
               if User_Pack_Id = No_Package then
505
                  Package_Table.Increment_Last (Shared.Packages);
506
                  User_Pack := Conf_Pack;
507
                  User_Pack.Next := User_Decl.Packages;
508
                  User_Decl.Packages := Package_Table.Last (Shared.Packages);
509
                  Shared.Packages.Table (User_Decl.Packages) := User_Pack;
510
 
511
               else
512
                  Add_Attributes
513
                    (Project_Tree => Project_Tree,
514
                     Conf_Decl    => Conf_Pack.Decl,
515
                     User_Decl    => Shared.Packages.Table
516
                                       (User_Pack_Id).Decl);
517
               end if;
518
 
519
               Conf_Pack_Id := Conf_Pack.Next;
520
            end loop;
521
 
522
            Proj.Project.Decl := User_Decl;
523
 
524
            --  For aggregate projects, we need to apply the config to all
525
            --  their aggregated trees as well.
526
 
527
            if Proj.Project.Qualifier in Aggregate_Project then
528
               declare
529
                  List : Aggregated_Project_List;
530
               begin
531
                  List := Proj.Project.Aggregated_Projects;
532
                  while List /= null loop
533
                     Debug_Output
534
                       ("Recursively apply config to aggregated tree",
535
                        List.Project.Name);
536
                     Apply_Config_File
537
                       (Config_File, Project_Tree => List.Tree);
538
                     List := List.Next;
539
                  end loop;
540
               end;
541
            end if;
542
         end if;
543
 
544
         Proj := Proj.Next;
545
      end loop;
546
   end Apply_Config_File;
547
 
548
   ------------------
549
   -- Check_Target --
550
   ------------------
551
 
552
   function Check_Target
553
     (Config_File        : Project_Id;
554
      Autoconf_Specified : Boolean;
555
      Project_Tree       : Prj.Project_Tree_Ref;
556
      Target             : String := "") return Boolean
557
   is
558
      Shared   : constant Shared_Project_Tree_Data_Access :=
559
                   Project_Tree.Shared;
560
      Variable : constant Variable_Value :=
561
                   Value_Of
562
                     (Name_Target, Config_File.Decl.Attributes, Shared);
563
      Tgt_Name : Name_Id := No_Name;
564
      OK       : Boolean;
565
 
566
   begin
567
      if Variable /= Nil_Variable_Value and then not Variable.Default then
568
         Tgt_Name := Variable.Value;
569
      end if;
570
 
571
      if Target = "" then
572
         OK := not Autoconf_Specified or else Tgt_Name = No_Name;
573
      else
574
         OK := Tgt_Name /= No_Name
575
                 and then Target = Get_Name_String (Tgt_Name);
576
      end if;
577
 
578
      if not OK then
579
         if Autoconf_Specified then
580
            if Verbose_Mode then
581
               Write_Line ("inconsistent targets, performing autoconf");
582
            end if;
583
 
584
            return False;
585
 
586
         else
587
            if Tgt_Name /= No_Name then
588
               Raise_Invalid_Config
589
                 ("invalid target name """
590
                  & Get_Name_String (Tgt_Name) & """ in configuration");
591
            else
592
               Raise_Invalid_Config
593
                 ("no target specified in configuration file");
594
            end if;
595
         end if;
596
      end if;
597
 
598
      return True;
599
   end Check_Target;
600
 
601
   --------------------------------------
602
   -- Get_Or_Create_Configuration_File --
603
   --------------------------------------
604
 
605
   procedure Get_Or_Create_Configuration_File
606
     (Project                    : Project_Id;
607
      Project_Tree               : Project_Tree_Ref;
608
      Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
609
      Env                        : in out Prj.Tree.Environment;
610
      Allow_Automatic_Generation : Boolean;
611
      Config_File_Name           : String := "";
612
      Autoconf_Specified         : Boolean;
613
      Target_Name                : String := "";
614
      Normalized_Hostname        : String;
615
      Packages_To_Check          : String_List_Access := null;
616
      Config                     : out Prj.Project_Id;
617
      Config_File_Path           : out String_Access;
618
      Automatically_Generated    : out Boolean;
619
      On_Load_Config             : Config_File_Hook := null)
620
   is
621
      Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
622
 
623
      At_Least_One_Compiler_Command : Boolean := False;
624
      --  Set to True if at least one attribute Ide'Compiler_Command is
625
      --  specified for one language of the system.
626
 
627
      function Default_File_Name return String;
628
      --  Return the name of the default config file that should be tested
629
 
630
      procedure Do_Autoconf;
631
      --  Generate a new config file through gprconfig. In case of error, this
632
      --  raises the Invalid_Config exception with an appropriate message
633
 
634
      function Get_Config_Switches return Argument_List_Access;
635
      --  Return the --config switches to use for gprconfig
636
 
637
      function Might_Have_Sources (Project : Project_Id) return Boolean;
638
      --  True if the specified project might have sources (ie the user has not
639
      --  explicitly specified it. We haven't checked the file system, nor do
640
      --  we need to at this stage.
641
 
642
      -----------------------
643
      -- Default_File_Name --
644
      -----------------------
645
 
646
      function Default_File_Name return String is
647
         Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
648
         Tmp     : String_Access;
649
 
650
      begin
651
         if Target_Name /= "" then
652
            if Ada_RTS /= "" then
653
               return Target_Name & '-' & Ada_RTS
654
                 & Config_Project_File_Extension;
655
            else
656
               return Target_Name & Config_Project_File_Extension;
657
            end if;
658
 
659
         elsif Ada_RTS /= "" then
660
            return Ada_RTS & Config_Project_File_Extension;
661
 
662
         else
663
            Tmp := Getenv (Config_Project_Env_Var);
664
 
665
            declare
666
               T : constant String := Tmp.all;
667
 
668
            begin
669
               Free (Tmp);
670
 
671
               if T'Length = 0 then
672
                  return Default_Name;
673
               else
674
                  return T;
675
               end if;
676
            end;
677
         end if;
678
      end Default_File_Name;
679
 
680
      ------------------------
681
      -- Might_Have_Sources --
682
      ------------------------
683
 
684
      function Might_Have_Sources (Project : Project_Id) return Boolean is
685
         Variable : Variable_Value;
686
 
687
      begin
688
         Variable :=
689
           Value_Of
690
             (Name_Source_Dirs,
691
              Project.Decl.Attributes,
692
              Shared);
693
 
694
         if Variable = Nil_Variable_Value
695
           or else Variable.Default
696
           or else Variable.Values /= Nil_String
697
         then
698
            Variable :=
699
              Value_Of
700
                (Name_Source_Files,
701
                 Project.Decl.Attributes,
702
                 Shared);
703
            return Variable = Nil_Variable_Value
704
              or else Variable.Default
705
              or else Variable.Values /= Nil_String;
706
 
707
         else
708
            return False;
709
         end if;
710
      end Might_Have_Sources;
711
 
712
      -------------------------
713
      -- Get_Config_Switches --
714
      -------------------------
715
 
716
      function Get_Config_Switches return Argument_List_Access is
717
 
718
         package Language_Htable is new GNAT.HTable.Simple_HTable
719
           (Header_Num => Prj.Header_Num,
720
            Element    => Name_Id,
721
            No_Element => No_Name,
722
            Key        => Name_Id,
723
            Hash       => Prj.Hash,
724
            Equal      => "=");
725
         --  Hash table to keep the languages used in the project tree
726
 
727
         IDE : constant Package_Id :=
728
                 Value_Of (Name_Ide, Project.Decl.Packages, Shared);
729
 
730
         procedure Add_Config_Switches_For_Project
731
           (Project    : Project_Id;
732
            Tree       : Project_Tree_Ref;
733
            With_State : in out Integer);
734
         --  Add all --config switches for this project. This is also called
735
         --  for aggregate projects.
736
 
737
         -------------------------------------
738
         -- Add_Config_Switches_For_Project --
739
         -------------------------------------
740
 
741
         procedure Add_Config_Switches_For_Project
742
           (Project    : Project_Id;
743
            Tree       : Project_Tree_Ref;
744
            With_State : in out Integer)
745
         is
746
            pragma Unreferenced (With_State);
747
 
748
            Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
749
 
750
            Variable      : Variable_Value;
751
            Check_Default : Boolean;
752
            Lang          : Name_Id;
753
            List          : String_List_Id;
754
            Elem          : String_Element;
755
 
756
         begin
757
            if Might_Have_Sources (Project) then
758
               Variable :=
759
                 Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
760
 
761
               if Variable = Nil_Variable_Value or else Variable.Default then
762
 
763
                  --  Languages is not declared. If it is not an extending
764
                  --  project, or if it extends a project with no Languages,
765
                  --  check for Default_Language.
766
 
767
                  Check_Default := Project.Extends = No_Project;
768
 
769
                  if not Check_Default then
770
                     Variable :=
771
                       Value_Of
772
                         (Name_Languages,
773
                          Project.Extends.Decl.Attributes,
774
                          Shared);
775
                     Check_Default :=
776
                       Variable /= Nil_Variable_Value
777
                         and then Variable.Values = Nil_String;
778
                  end if;
779
 
780
                  if Check_Default then
781
                     Variable :=
782
                       Value_Of
783
                         (Name_Default_Language,
784
                          Project.Decl.Attributes,
785
                          Shared);
786
 
787
                     if Variable /= Nil_Variable_Value
788
                       and then not Variable.Default
789
                     then
790
                        Get_Name_String (Variable.Value);
791
                        To_Lower (Name_Buffer (1 .. Name_Len));
792
                        Lang := Name_Find;
793
                        Language_Htable.Set (Lang, Lang);
794
 
795
                     --  If no default language is declared, default to Ada
796
 
797
                     else
798
                        Language_Htable.Set (Name_Ada, Name_Ada);
799
                     end if;
800
                  end if;
801
 
802
               elsif Variable.Values /= Nil_String then
803
 
804
                  --  Attribute Languages is declared with a non empty list:
805
                  --  put all the languages in Language_HTable.
806
 
807
                  List := Variable.Values;
808
                  while List /= Nil_String loop
809
                     Elem := Shared.String_Elements.Table (List);
810
 
811
                     Get_Name_String (Elem.Value);
812
                     To_Lower (Name_Buffer (1 .. Name_Len));
813
                     Lang := Name_Find;
814
                     Language_Htable.Set (Lang, Lang);
815
 
816
                     List := Elem.Next;
817
                  end loop;
818
               end if;
819
            end if;
820
         end Add_Config_Switches_For_Project;
821
 
822
         procedure For_Every_Imported_Project is new For_Every_Project_Imported
823
           (State => Integer, Action => Add_Config_Switches_For_Project);
824
         --  Document this procedure ???
825
 
826
         --  Local variables
827
 
828
         Name     : Name_Id;
829
         Count    : Natural;
830
         Result   : Argument_List_Access;
831
         Variable : Variable_Value;
832
         Dummy    : Integer := 0;
833
 
834
      --  Start of processing for Get_Config_Switches
835
 
836
      begin
837
         For_Every_Imported_Project
838
           (By                 => Project,
839
            Tree               => Project_Tree,
840
            With_State         => Dummy,
841
            Include_Aggregated => True);
842
 
843
         Name  := Language_Htable.Get_First;
844
         Count := 0;
845
         while Name /= No_Name loop
846
            Count := Count + 1;
847
            Name := Language_Htable.Get_Next;
848
         end loop;
849
 
850
         Result := new String_List (1 .. Count);
851
 
852
         Count := 1;
853
         Name  := Language_Htable.Get_First;
854
         while Name /= No_Name loop
855
 
856
            --  Check if IDE'Compiler_Command is declared for the language.
857
            --  If it is, use its value to invoke gprconfig.
858
 
859
            Variable :=
860
              Value_Of
861
                (Name,
862
                 Attribute_Or_Array_Name => Name_Compiler_Command,
863
                 In_Package              => IDE,
864
                 Shared                  => Shared,
865
                 Force_Lower_Case_Index  => True);
866
 
867
            declare
868
               Config_Command : constant String :=
869
                                  "--config=" & Get_Name_String (Name);
870
 
871
               Runtime_Name   : constant String :=
872
                                  Runtime_Name_For (Name);
873
 
874
            begin
875
               if Variable = Nil_Variable_Value
876
                 or else Length_Of_Name (Variable.Value) = 0
877
               then
878
                  Result (Count) :=
879
                    new String'(Config_Command & ",," & Runtime_Name);
880
 
881
               else
882
                  At_Least_One_Compiler_Command := True;
883
 
884
                  declare
885
                     Compiler_Command : constant String :=
886
                                          Get_Name_String (Variable.Value);
887
 
888
                  begin
889
                     if Is_Absolute_Path (Compiler_Command) then
890
                        Result (Count) :=
891
                          new String'
892
                            (Config_Command & ",," & Runtime_Name & "," &
893
                             Containing_Directory (Compiler_Command) & "," &
894
                             Simple_Name (Compiler_Command));
895
                     else
896
                        Result (Count) :=
897
                          new String'
898
                            (Config_Command & ",," & Runtime_Name & ",," &
899
                             Compiler_Command);
900
                     end if;
901
                  end;
902
               end if;
903
            end;
904
 
905
            Count := Count + 1;
906
            Name  := Language_Htable.Get_Next;
907
         end loop;
908
 
909
         return Result;
910
      end Get_Config_Switches;
911
 
912
      -----------------
913
      -- Do_Autoconf --
914
      -----------------
915
 
916
      procedure Do_Autoconf is
917
         Obj_Dir : constant Variable_Value :=
918
                     Value_Of
919
                       (Name_Object_Dir,
920
                        Project.Decl.Attributes,
921
                        Shared);
922
 
923
         Gprconfig_Path  : String_Access;
924
         Success         : Boolean;
925
 
926
      begin
927
         Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
928
 
929
         if Gprconfig_Path = null then
930
            Raise_Invalid_Config
931
              ("could not locate gprconfig for auto-configuration");
932
         end if;
933
 
934
         --  First, find the object directory of the user's project
935
 
936
         if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
937
            Get_Name_String (Project.Directory.Display_Name);
938
 
939
         else
940
            if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
941
               Get_Name_String (Obj_Dir.Value);
942
 
943
            else
944
               Name_Len := 0;
945
               Add_Str_To_Name_Buffer
946
                 (Get_Name_String (Project.Directory.Display_Name));
947
               Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
948
            end if;
949
         end if;
950
 
951
         if Subdirs /= null then
952
            Add_Char_To_Name_Buffer (Directory_Separator);
953
            Add_Str_To_Name_Buffer (Subdirs.all);
954
         end if;
955
 
956
         for J in 1 .. Name_Len loop
957
            if Name_Buffer (J) = '/' then
958
               Name_Buffer (J) := Directory_Separator;
959
            end if;
960
         end loop;
961
 
962
         --  Make sure that Obj_Dir ends with a directory separator
963
 
964
         if Name_Buffer (Name_Len) /= Directory_Separator then
965
            Name_Len := Name_Len + 1;
966
            Name_Buffer (Name_Len) := Directory_Separator;
967
         end if;
968
 
969
         declare
970
            Obj_Dir         : constant String := Name_Buffer (1 .. Name_Len);
971
            Config_Switches : Argument_List_Access;
972
            Args            : Argument_List (1 .. 5);
973
            Arg_Last        : Positive;
974
            Obj_Dir_Exists  : Boolean := True;
975
 
976
         begin
977
            --  Check if the object directory exists. If Setup_Projects is True
978
            --  (-p) and directory does not exist, attempt to create it.
979
            --  Otherwise, if directory does not exist, fail without calling
980
            --  gprconfig.
981
 
982
            if not Is_Directory (Obj_Dir)
983
              and then (Setup_Projects or else Subdirs /= null)
984
            then
985
               begin
986
                  Create_Path (Obj_Dir);
987
 
988
                  if not Quiet_Output then
989
                     Write_Str ("object directory """);
990
                     Write_Str (Obj_Dir);
991
                     Write_Line (""" created");
992
                  end if;
993
 
994
               exception
995
                  when others =>
996
                     Raise_Invalid_Config
997
                       ("could not create object directory " & Obj_Dir);
998
               end;
999
            end if;
1000
 
1001
            if not Is_Directory (Obj_Dir) then
1002
               case Env.Flags.Require_Obj_Dirs is
1003
                  when Error =>
1004
                     Raise_Invalid_Config
1005
                       ("object directory " & Obj_Dir & " does not exist");
1006
 
1007
                  when Warning =>
1008
                     Prj.Err.Error_Msg
1009
                       (Env.Flags,
1010
                        "?object directory " & Obj_Dir & " does not exist");
1011
                     Obj_Dir_Exists := False;
1012
 
1013
                  when Silent =>
1014
                     null;
1015
               end case;
1016
            end if;
1017
 
1018
            --  If no switch --RTS have been specified on the command line,
1019
            --  look for --RTS switches in the Builder switches.
1020
 
1021
            if RTS_Languages.Get_First = No_Name then
1022
               declare
1023
                  Builder : constant Package_Id :=
1024
                              Value_Of
1025
                                (Name_Builder, Project.Decl.Packages, Shared);
1026
                  Switch_Array_Id : Array_Element_Id;
1027
 
1028
                  procedure Check_RTS_Switches;
1029
                  --  Take into account eventual switches --RTS in
1030
                  --  Switch_Array_Id.
1031
 
1032
                  ------------------------
1033
                  -- Check_RTS_SWitches --
1034
                  ------------------------
1035
 
1036
                  procedure Check_RTS_Switches is
1037
                     Switch_Array : Array_Element;
1038
                     Switch_List  : String_List_Id := Nil_String;
1039
                     Switch       : String_Element;
1040
                     Lang         : Name_Id;
1041
                     Lang_Last    : Positive;
1042
 
1043
                  begin
1044
                     while Switch_Array_Id /= No_Array_Element loop
1045
                        Switch_Array :=
1046
                          Shared.Array_Elements.Table (Switch_Array_Id);
1047
 
1048
                        Switch_List := Switch_Array.Value.Values;
1049
                        while Switch_List /= Nil_String loop
1050
                           Switch :=
1051
                             Shared.String_Elements.Table (Switch_List);
1052
 
1053
                           if Switch.Value /= No_Name then
1054
                              Get_Name_String (Switch.Value);
1055
 
1056
                              if Name_Len >= 7 and then
1057
                                Name_Buffer (1 .. 5) = "--RTS"
1058
                              then
1059
                                 if Name_Buffer (6) = '=' then
1060
                                    if not Runtime_Name_Set_For (Name_Ada) then
1061
                                       Set_Runtime_For
1062
                                         (Name_Ada,
1063
                                          Name_Buffer (7 .. Name_Len));
1064
                                    end if;
1065
 
1066
                                 elsif Name_Len > 7 and then
1067
                                   Name_Buffer (6) = ':' and then
1068
                                   Name_Buffer (7) /= '='
1069
                                 then
1070
                                    Lang_Last := 7;
1071
                                    while Lang_Last < Name_Len and then
1072
                                      Name_Buffer (Lang_Last + 1) /= '='
1073
                                    loop
1074
                                       Lang_Last := Lang_Last + 1;
1075
                                    end loop;
1076
 
1077
                                    if Name_Buffer (Lang_Last + 1) = '=' then
1078
                                       declare
1079
                                          RTS : constant String :=
1080
                                                  Name_Buffer (Lang_Last + 2 ..
1081
                                                               Name_Len);
1082
                                       begin
1083
                                          Name_Buffer (1 .. Lang_Last - 6) :=
1084
                                            Name_Buffer (7 .. Lang_Last);
1085
                                          Name_Len := Lang_Last - 6;
1086
                                          To_Lower
1087
                                            (Name_Buffer (1 .. Name_Len));
1088
                                          Lang := Name_Find;
1089
 
1090
                                          if not
1091
                                            Runtime_Name_Set_For (Lang)
1092
                                          then
1093
                                             Set_Runtime_For (Lang, RTS);
1094
                                          end if;
1095
                                       end;
1096
                                    end if;
1097
                                 end if;
1098
                              end if;
1099
                           end if;
1100
 
1101
                           Switch_List := Switch.Next;
1102
                        end loop;
1103
 
1104
                        Switch_Array_Id := Switch_Array.Next;
1105
                     end loop;
1106
                  end Check_RTS_Switches;
1107
 
1108
               begin
1109
                  if Builder /= No_Package then
1110
                     Switch_Array_Id :=
1111
                       Value_Of
1112
                         (Name      => Name_Switches,
1113
                          In_Arrays =>
1114
                            Shared.Packages.Table (Builder).Decl.Arrays,
1115
                          Shared    => Shared);
1116
                     Check_RTS_Switches;
1117
 
1118
                     Switch_Array_Id :=
1119
                       Value_Of
1120
                         (Name      => Name_Default_Switches,
1121
                          In_Arrays =>
1122
                            Shared.Packages.Table (Builder).Decl.Arrays,
1123
                          Shared    => Shared);
1124
                     Check_RTS_Switches;
1125
                  end if;
1126
               end;
1127
            end if;
1128
 
1129
            --  Get the config switches. This should be done only now, as some
1130
            --  runtimes may have been found if the Builder switches.
1131
 
1132
            Config_Switches := Get_Config_Switches;
1133
 
1134
            --  Invoke gprconfig
1135
 
1136
            Args (1) := new String'("--batch");
1137
            Args (2) := new String'("-o");
1138
 
1139
            --  If no config file was specified, set the auto.cgpr one
1140
 
1141
            if Config_File_Name = "" then
1142
               if Obj_Dir_Exists then
1143
                  Args (3) := new String'(Obj_Dir & Auto_Cgpr);
1144
 
1145
               else
1146
                  declare
1147
                     Path_FD   : File_Descriptor;
1148
                     Path_Name : Path_Name_Type;
1149
 
1150
                  begin
1151
                     Prj.Env.Create_Temp_File
1152
                       (Shared    => Project_Tree.Shared,
1153
                        Path_FD   => Path_FD,
1154
                        Path_Name => Path_Name,
1155
                        File_Use  => "configuration file");
1156
 
1157
                     if Path_FD /= Invalid_FD then
1158
                        declare
1159
                           Temp_Dir : constant String :=
1160
                                        Containing_Directory
1161
                                          (Get_Name_String (Path_Name));
1162
                        begin
1163
                           GNAT.OS_Lib.Close (Path_FD);
1164
                           Args (3) :=
1165
                             new String'(Temp_Dir &
1166
                                         Directory_Separator &
1167
                                         Auto_Cgpr);
1168
                           Delete_File (Get_Name_String (Path_Name));
1169
                        end;
1170
 
1171
                     else
1172
                        --  We'll have an error message later on
1173
 
1174
                        Args (3) := new String'(Obj_Dir & Auto_Cgpr);
1175
                     end if;
1176
                  end;
1177
               end if;
1178
            else
1179
               Args (3) := new String'(Config_File_Name);
1180
            end if;
1181
 
1182
            if Normalized_Hostname = "" then
1183
               Arg_Last := 3;
1184
            else
1185
               if Target_Name = "" then
1186
                  if At_Least_One_Compiler_Command then
1187
                     Args (4) := new String'("--target=all");
1188
 
1189
                  else
1190
                     Args (4) :=
1191
                       new String'("--target=" & Normalized_Hostname);
1192
                  end if;
1193
 
1194
               else
1195
                  Args (4) := new String'("--target=" & Target_Name);
1196
               end if;
1197
 
1198
               Arg_Last := 4;
1199
            end if;
1200
 
1201
            if not Verbose_Mode then
1202
               Arg_Last := Arg_Last + 1;
1203
               Args (Arg_Last) := new String'("-q");
1204
            end if;
1205
 
1206
            if Verbose_Mode then
1207
               Write_Str (Gprconfig_Name);
1208
 
1209
               for J in 1 .. Arg_Last loop
1210
                  Write_Char (' ');
1211
                  Write_Str (Args (J).all);
1212
               end loop;
1213
 
1214
               for J in Config_Switches'Range loop
1215
                  Write_Char (' ');
1216
                  Write_Str (Config_Switches (J).all);
1217
               end loop;
1218
 
1219
               Write_Eol;
1220
 
1221
            elsif not Quiet_Output then
1222
               --  Display no message if we are creating auto.cgpr, unless in
1223
               --  verbose mode
1224
 
1225
               if Config_File_Name /= ""
1226
                 or else Verbose_Mode
1227
               then
1228
                  Write_Str ("creating ");
1229
                  Write_Str (Simple_Name (Args (3).all));
1230
                  Write_Eol;
1231
               end if;
1232
            end if;
1233
 
1234
            Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
1235
                   Config_Switches.all,
1236
                   Success);
1237
 
1238
            Free (Config_Switches);
1239
 
1240
            Config_File_Path := Locate_Config_File (Args (3).all);
1241
 
1242
            if Config_File_Path = null then
1243
               Raise_Invalid_Config
1244
                 ("could not create " & Args (3).all);
1245
            end if;
1246
 
1247
            for F in Args'Range loop
1248
               Free (Args (F));
1249
            end loop;
1250
         end;
1251
      end Do_Autoconf;
1252
 
1253
      Success             : Boolean;
1254
      Config_Project_Node : Project_Node_Id := Empty_Node;
1255
 
1256
   begin
1257
      pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1258
 
1259
      Free (Config_File_Path);
1260
      Config := No_Project;
1261
 
1262
      if Config_File_Name /= "" then
1263
         Config_File_Path := Locate_Config_File (Config_File_Name);
1264
      else
1265
         Config_File_Path := Locate_Config_File (Default_File_Name);
1266
      end if;
1267
 
1268
      if Config_File_Path = null then
1269
         if (not Allow_Automatic_Generation)
1270
           and then Config_File_Name /= ""
1271
         then
1272
            Raise_Invalid_Config
1273
              ("could not locate main configuration project "
1274
               & Config_File_Name);
1275
         end if;
1276
      end if;
1277
 
1278
      Automatically_Generated :=
1279
        Allow_Automatic_Generation and then Config_File_Path = null;
1280
 
1281
      <<Process_Config_File>>
1282
 
1283
      if Automatically_Generated then
1284
         if Hostparm.OpenVMS then
1285
 
1286
            --  There is no gprconfig on VMS
1287
 
1288
            Raise_Invalid_Config
1289
              ("could not locate any configuration project file");
1290
 
1291
         else
1292
            --  This might raise an Invalid_Config exception
1293
 
1294
            Do_Autoconf;
1295
         end if;
1296
 
1297
      --  If the config file is not auto-generated, warn if there is any --RTS
1298
      --  switch on the command line.
1299
 
1300
      elsif RTS_Languages.Get_First /= No_Name
1301
        and then Opt.Warning_Mode /= Opt.Suppress
1302
      then
1303
         Write_Line
1304
           ("warning: --RTS is taken into account only in auto-configuration");
1305
      end if;
1306
 
1307
      --  Parse the configuration file
1308
 
1309
      if Verbose_Mode and then Config_File_Path /= null then
1310
         Write_Str  ("Checking configuration ");
1311
         Write_Line (Config_File_Path.all);
1312
      end if;
1313
 
1314
      if On_Load_Config /= null then
1315
         On_Load_Config
1316
           (Config_File       => Config_Project_Node,
1317
            Project_Node_Tree => Project_Node_Tree);
1318
 
1319
      elsif Config_File_Path /= null then
1320
         Prj.Part.Parse
1321
           (In_Tree           => Project_Node_Tree,
1322
            Project           => Config_Project_Node,
1323
            Project_File_Name => Config_File_Path.all,
1324
            Errout_Handling   => Prj.Part.Finalize_If_Error,
1325
            Packages_To_Check => Packages_To_Check,
1326
            Current_Directory => Current_Directory,
1327
            Is_Config_File    => True,
1328
            Env               => Env);
1329
      else
1330
         Config_Project_Node := Empty_Node;
1331
      end if;
1332
 
1333
      if Config_Project_Node /= Empty_Node then
1334
         Prj.Proc.Process_Project_Tree_Phase_1
1335
           (In_Tree                => Project_Tree,
1336
            Project                => Config,
1337
            Packages_To_Check      => Packages_To_Check,
1338
            Success                => Success,
1339
            From_Project_Node      => Config_Project_Node,
1340
            From_Project_Node_Tree => Project_Node_Tree,
1341
            Env                    => Env,
1342
            Reset_Tree             => False);
1343
      end if;
1344
 
1345
      if Config_Project_Node = Empty_Node
1346
        or else Config = No_Project
1347
      then
1348
         Raise_Invalid_Config
1349
           ("processing of configuration project """
1350
            & Config_File_Path.all & """ failed");
1351
      end if;
1352
 
1353
      --  Check that the target of the configuration file is the one the user
1354
      --  specified on the command line. We do not need to check that when in
1355
      --  auto-conf mode, since the appropriate target was passed to gprconfig.
1356
 
1357
      if not Automatically_Generated
1358
        and then not
1359
          Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
1360
      then
1361
         Automatically_Generated := True;
1362
         goto Process_Config_File;
1363
      end if;
1364
   end Get_Or_Create_Configuration_File;
1365
 
1366
   ------------------------
1367
   -- Locate_Config_File --
1368
   ------------------------
1369
 
1370
   function Locate_Config_File (Name : String) return String_Access is
1371
      Prefix_Path : constant String := Executable_Prefix_Path;
1372
   begin
1373
      if Prefix_Path'Length /= 0 then
1374
         return Locate_Regular_File
1375
           (Name,
1376
            "." & Path_Separator &
1377
            Prefix_Path & "share" & Directory_Separator & "gpr");
1378
      else
1379
         return Locate_Regular_File (Name, ".");
1380
      end if;
1381
   end Locate_Config_File;
1382
 
1383
   ------------------------------------
1384
   -- Parse_Project_And_Apply_Config --
1385
   ------------------------------------
1386
 
1387
   procedure Parse_Project_And_Apply_Config
1388
     (Main_Project               : out Prj.Project_Id;
1389
      User_Project_Node          : out Prj.Tree.Project_Node_Id;
1390
      Config_File_Name           : String := "";
1391
      Autoconf_Specified         : Boolean;
1392
      Project_File_Name          : String;
1393
      Project_Tree               : Prj.Project_Tree_Ref;
1394
      Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1395
      Env                        : in out Prj.Tree.Environment;
1396
      Packages_To_Check          : String_List_Access;
1397
      Allow_Automatic_Generation : Boolean := True;
1398
      Automatically_Generated    : out Boolean;
1399
      Config_File_Path           : out String_Access;
1400
      Target_Name                : String := "";
1401
      Normalized_Hostname        : String;
1402
      On_Load_Config             : Config_File_Hook := null)
1403
   is
1404
   begin
1405
      pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1406
 
1407
      --  Parse the user project tree
1408
 
1409
      Prj.Initialize (Project_Tree);
1410
 
1411
      Main_Project := No_Project;
1412
      Automatically_Generated := False;
1413
 
1414
      Prj.Part.Parse
1415
        (In_Tree           => Project_Node_Tree,
1416
         Project           => User_Project_Node,
1417
         Project_File_Name => Project_File_Name,
1418
         Errout_Handling   => Prj.Part.Finalize_If_Error,
1419
         Packages_To_Check => Packages_To_Check,
1420
         Current_Directory => Current_Directory,
1421
         Is_Config_File    => False,
1422
         Env               => Env);
1423
 
1424
      if User_Project_Node = Empty_Node then
1425
         User_Project_Node := Empty_Node;
1426
         return;
1427
      end if;
1428
 
1429
      Process_Project_And_Apply_Config
1430
        (Main_Project               => Main_Project,
1431
         User_Project_Node          => User_Project_Node,
1432
         Config_File_Name           => Config_File_Name,
1433
         Autoconf_Specified         => Autoconf_Specified,
1434
         Project_Tree               => Project_Tree,
1435
         Project_Node_Tree          => Project_Node_Tree,
1436
         Env                        => Env,
1437
         Packages_To_Check          => Packages_To_Check,
1438
         Allow_Automatic_Generation => Allow_Automatic_Generation,
1439
         Automatically_Generated    => Automatically_Generated,
1440
         Config_File_Path           => Config_File_Path,
1441
         Target_Name                => Target_Name,
1442
         Normalized_Hostname        => Normalized_Hostname,
1443
         On_Load_Config             => On_Load_Config);
1444
   end Parse_Project_And_Apply_Config;
1445
 
1446
   --------------------------------------
1447
   -- Process_Project_And_Apply_Config --
1448
   --------------------------------------
1449
 
1450
   procedure Process_Project_And_Apply_Config
1451
     (Main_Project               : out Prj.Project_Id;
1452
      User_Project_Node          : Prj.Tree.Project_Node_Id;
1453
      Config_File_Name           : String := "";
1454
      Autoconf_Specified         : Boolean;
1455
      Project_Tree               : Prj.Project_Tree_Ref;
1456
      Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1457
      Env                        : in out Prj.Tree.Environment;
1458
      Packages_To_Check          : String_List_Access;
1459
      Allow_Automatic_Generation : Boolean := True;
1460
      Automatically_Generated    : out Boolean;
1461
      Config_File_Path           : out String_Access;
1462
      Target_Name                : String := "";
1463
      Normalized_Hostname        : String;
1464
      On_Load_Config             : Config_File_Hook := null;
1465
      Reset_Tree                 : Boolean := True)
1466
   is
1467
      Shared              : constant Shared_Project_Tree_Data_Access :=
1468
                              Project_Tree.Shared;
1469
      Main_Config_Project : Project_Id;
1470
      Success             : Boolean;
1471
 
1472
   begin
1473
      Main_Project := No_Project;
1474
      Automatically_Generated := False;
1475
 
1476
      Process_Project_Tree_Phase_1
1477
        (In_Tree                => Project_Tree,
1478
         Project                => Main_Project,
1479
         Packages_To_Check      => Packages_To_Check,
1480
         Success                => Success,
1481
         From_Project_Node      => User_Project_Node,
1482
         From_Project_Node_Tree => Project_Node_Tree,
1483
         Env                    => Env,
1484
         Reset_Tree             => Reset_Tree);
1485
 
1486
      if not Success then
1487
         Main_Project := No_Project;
1488
         return;
1489
      end if;
1490
 
1491
      if Project_Tree.Source_Info_File_Name /= null then
1492
         if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
1493
            declare
1494
               Obj_Dir : constant Variable_Value :=
1495
                           Value_Of
1496
                             (Name_Object_Dir,
1497
                              Main_Project.Decl.Attributes,
1498
                              Shared);
1499
 
1500
            begin
1501
               if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
1502
                  Get_Name_String (Main_Project.Directory.Display_Name);
1503
 
1504
               else
1505
                  if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
1506
                     Get_Name_String (Obj_Dir.Value);
1507
 
1508
                  else
1509
                     Name_Len := 0;
1510
                     Add_Str_To_Name_Buffer
1511
                       (Get_Name_String (Main_Project.Directory.Display_Name));
1512
                     Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
1513
                  end if;
1514
               end if;
1515
 
1516
               Add_Char_To_Name_Buffer (Directory_Separator);
1517
               Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
1518
               Free (Project_Tree.Source_Info_File_Name);
1519
               Project_Tree.Source_Info_File_Name :=
1520
                 new String'(Name_Buffer (1 .. Name_Len));
1521
            end;
1522
         end if;
1523
 
1524
         Read_Source_Info_File (Project_Tree);
1525
      end if;
1526
 
1527
      --  Find configuration file
1528
 
1529
      Get_Or_Create_Configuration_File
1530
        (Config                     => Main_Config_Project,
1531
         Project                    => Main_Project,
1532
         Project_Tree               => Project_Tree,
1533
         Project_Node_Tree          => Project_Node_Tree,
1534
         Env                        => Env,
1535
         Allow_Automatic_Generation => Allow_Automatic_Generation,
1536
         Config_File_Name           => Config_File_Name,
1537
         Autoconf_Specified         => Autoconf_Specified,
1538
         Target_Name                => Target_Name,
1539
         Normalized_Hostname        => Normalized_Hostname,
1540
         Packages_To_Check          => Packages_To_Check,
1541
         Config_File_Path           => Config_File_Path,
1542
         Automatically_Generated    => Automatically_Generated,
1543
         On_Load_Config             => On_Load_Config);
1544
 
1545
      Apply_Config_File (Main_Config_Project, Project_Tree);
1546
 
1547
      --  Finish processing the user's project
1548
 
1549
      Prj.Proc.Process_Project_Tree_Phase_2
1550
        (In_Tree                => Project_Tree,
1551
         Project                => Main_Project,
1552
         Success                => Success,
1553
         From_Project_Node      => User_Project_Node,
1554
         From_Project_Node_Tree => Project_Node_Tree,
1555
         Env                    => Env);
1556
 
1557
      if Success then
1558
         if Project_Tree.Source_Info_File_Name /= null
1559
           and then not Project_Tree.Source_Info_File_Exists
1560
         then
1561
            Write_Source_Info_File (Project_Tree);
1562
         end if;
1563
 
1564
      else
1565
         Main_Project := No_Project;
1566
      end if;
1567
   end Process_Project_And_Apply_Config;
1568
 
1569
   --------------------------
1570
   -- Raise_Invalid_Config --
1571
   --------------------------
1572
 
1573
   procedure Raise_Invalid_Config (Msg : String) is
1574
   begin
1575
      Raise_Exception (Invalid_Config'Identity, Msg);
1576
   end Raise_Invalid_Config;
1577
 
1578
   ----------------------
1579
   -- Runtime_Name_For --
1580
   ----------------------
1581
 
1582
   function Runtime_Name_For (Language : Name_Id) return String is
1583
   begin
1584
      if RTS_Languages.Get (Language) /= No_Name then
1585
         return Get_Name_String (RTS_Languages.Get (Language));
1586
      else
1587
         return "";
1588
      end if;
1589
   end Runtime_Name_For;
1590
 
1591
   --------------------------
1592
   -- Runtime_Name_Set_For --
1593
   --------------------------
1594
 
1595
   function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
1596
   begin
1597
      return RTS_Languages.Get (Language) /= No_Name;
1598
   end Runtime_Name_Set_For;
1599
 
1600
   ---------------------
1601
   -- Set_Runtime_For --
1602
   ---------------------
1603
 
1604
   procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1605
   begin
1606
      Name_Len := RTS_Name'Length;
1607
      Name_Buffer (1 .. Name_Len) := RTS_Name;
1608
      RTS_Languages.Set (Language, Name_Find);
1609
   end Set_Runtime_For;
1610
 
1611
end Prj.Conf;

powered by: WebSVN 2.1.0

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