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