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