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