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